漢数字変換

	import Graphics.UI.Gtk
	import Control.Monad
	k = reverse "極哉正澗溝穣杼垓京兆億万"
	c = repeat ','
	kmg = reverse "YZEPTGMK"
	rn = return . reverse
	restore = map reverse
	disp b x = do
	if head x == '-'
	then putChar '-' >> disp' b (tail x)
	else disp' b x
	disp' b x =
	case b of
	"k" -> grp4 x >>= dispk
	"c" -> grp3 x >>= dispc
	"kmg" -> grp3 x >>= dispg
	_ -> return ()
	u xs x = reverse $ take (length xs -1) x
	dispc xs = disp4 xs $ u xs c
	dispk xs | length xs >= 14 =putStr "無量大数"
	| otherwise = disp3 xs $ u xs k
	dispg xs | length xs >= 10 =putStr "BIGNUM"
	| otherwise = disp4 xs $ u xs kmg
	disp4 (x:xs) [] = putStr x
	disp4 (x:xs) (y:ys) = do
	putStr x
	putChar y
	disp4 xs ys
	disp3 (x:xs) [] = disp2 x
	disp3 (("0000"):xs) (y:ys) = do{putStr "" ;disp3 xs ys;}
	disp3 (x:xs) (y:ys) = do
	disp2 x
	putChar y
	disp3 xs ys
	disp2 "0000" = putStr ""
	disp2 (x:xs) |x /= '0' = putStr (x:xs)
	|otherwise = disp2 xs
	grp4 xs = return $ restore $ grp 4 xs []
	grp3 xs = return $ restore $ grp 3 xs []
	grp n [] ys = ys
	grp n xs ys = grp n (drop n xs) (take n xs : ys)
	toInt :: String -> Integer
	toInt = read
	titles = ["Chinese numerals","giga,mega,kilo","xxx,xxx,xxx"]
	main = do
	c <- getContents
	let i = toInt c
	initGUI
	w <- windowNew
	vBox <- vBoxNew False 0
	containerAdd w vBox
	set w[windowTitle := "漢数字変換",
	windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 500, windowDefaultHeight := 50]
	e <- entryNew
	set e [entryText := (show i)]
	e `on` entryActivate $ do
	f0 e
	f1 e
	f2 e
	bs <- mapM buttonNewWithLabel titles
	containerAdd vBox e
	mapM_ (containerAdd vBox) bs
	zipWithM (\b f -> (b `on` buttonActivated) (f e)) bs [f0,f1,f2]
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI
	f0 e = f' "k" e
	f1 e = f' "kmg" e
	f2 e = f' "c" e
	f' t e = get e entryText >>= rn >>= disp t >> putChar '\n'

view raw kNum.hs hosted with ❤ by GitHub

整数限定です。

$ echo "123456789" | runghc kNum.hs

手続き的なscanlの説明

手続き的なscanlの説明 foldの動作をｘへの代入、再代入と捉えると分かりやすくなります。 直接foldの動きを見るのではなく、 まずscanlの動作を見てみます。 scanlの型は Prelude> :t scanl scanl :: (a -> b -> a) -> a -> [b] -> [a] となっています。 scanlは、２引数の関数と初期値と何らかのリストを引数にとり、リストを返す関数です。 実際に動かしてみましょう。 Prelude> scanl(\x y -> x + y) 0 [1..3] [0,1,3,6] scanlが内部で何をやっているのか想像してみます。 まずscanlが呼び出されたとき、変数ｘに初期値、（この場合は「０」）を代入します。 次に変数ｙにリストの最初の要素（この場合は「１」）を代入します。 次にｘ＋ｙを計算して結果の「１」をｘに再代入します。 次にｙにリストの次の要素「２」を代入し、ｘ＋ｙを計算します。この時ｘは１になっていますので, 結果は「３」です。これをｘに再代入します。 次にｙにリストの次の要素「３」を代入し、ｘ＋ｙを計算します。この時ｘは３になっていますので,結果は「６」です。これをｘに再代入します。 リストの終わりに到達したので、リスト[0,1,3,6]を出力して終了します。 scanlはｘに値が代入された時はすべてその値をリストに保存するようです。 こう見ますとfoldlはscanlと動作は同じで終了時にｘの値のみを出力して終了する、と捉えることができます。 Prelude> :t foldl foldl :: (a -> b -> a) -> a -> [b] -> a foldlの型です。 同様にscanrの動作もみてみます。 scanrはxとyの役割が逆転しており、リストの作り方も異なっています。 Prelude> scanr (\x y -> x / y) 2 [3..5] [1.875,1.6,2.5,2.0] pythonで動きを追ってみると >>> x=5. >>> y=x/y >>> y 2.5 >>> x=4 >>> y=x/y >>> y 1.6 >>> x=3 >>> y=x/y >>> y 1.875 代入、再代入はｙに対しておこなわれます。 ｙに代入があった時、リストの先頭に値を保存します。 Prelude> 1.875:1.6:2.5:2.0:[] [1.875,1.6,2.5,2.0] haskellはソースコード上での、変数への値の再代入を許していません。 そのため繰り返しのための構文が用意されていません。 それが可能な言語、例えばPythonでは次のようなコードが書けます。

x=0

for y in [1,2,3]: 

　x=x+y 　print x

これは上記の説明のfoldと全く同じです。 つまりfoldは一般的な言語の繰り返し処理をHaskellで書くための一つの方法になっているわけです。

（PythonのFor文は他の凡百の言語のFor文とはまったく異なります。どちらかというとMapに近い。ただ書き換えのできるグローバル変数も使えるので非常に自由度が高い。）

---

fold を手続き的にとらえると考えやすくなる処理があります。

Data.List　モジュールには　insert という関数が用意されています。

Prelude> import Data.List
Prelude Data.List> :t insert

insert :: Ord a => a -> [a] -> [a]

ソート済みのリストに一つ要素を加えてソート順を崩さずに新たなリストを返す関数です。

他の関数が一般的なリスト処理の関数なのに比べてやや特殊な感じがあります。

たぶん「挿入ソートを実装してください」というメッセージだと思います。

挿入ソートは再起でも書けるとは思うのですが、いきなり　fold　を使ったほうがわかりやすい。

Prelude Data.List> foldl (\x y -> insert y x) [] [2,7,4,0]

[0,2,4,7]

まず初期値は空リストです。

ｘ　に　代入されます。

ｙ　には　リストの第一要素が代入されます。

ｘ　ｙ　をひっくり返して　insert 関数を適用します。

結果　ｘ　に　[2] が　ｙ　に　７　が代入されます。

７　を　[2]  に insert し　[2,7]  ・・・・（略）

この操作をリストの終わりまで繰り返します。　これでソート完了。

flip を使って書き直すと

Prelude Data.List> foldl (flip insert) [] [2,7,4,0]

[0,2,4,7]

さらに

Prelude Data.List> foldr insert [] [2,7,4,0]

[0,2,4,7]

foldl と　foldr　では動作が異なりますが、この場合は結果は同じです。

---

http://hhg2the-haskell.blogspot.com/2018/06/blog-post.html

も参照ください。

フィボナッチ数

	--fibo: 定義そのままの素朴な再帰。
	fibo 0 = 0
	fibo 1 = 1
	fibo n = fibo (n - 1) + fibo (n - 2)
	f0 = 0:1:(zipWith (+) f0 (tail f0))
	--f1: f0をリスト内包表記に置き換えたもの。-XParallelListComp　オプションが必要
	f1 = 0:1:[x+y|x<-f1|y<-tail f1]
	--f2: mainは　f2 (0,1)
	f2 (a,b) = do
	print a
	f2 (b,a+b)
	--以下はState　Monadを利用したLoop。　Control.Monad.State　のインポートが必要。
	--f3: mainは　runStateT f3 (0,1)
	f3 :: StateT (Integer, Integer) IO b
	f3 = do
	(a,b) <- get
	liftIO $ print a
	put (b,a+b)
	f3
	--f4: mainは　runStateT f4 [1:0]
	f4 :: StateT [Integer] IO b
	f4 = do
	l@(a:b:c) <- get
	liftIO $ print l
	put $ (a+b):a:b:c
	f4
	--f5: mainは　runStateT f5 ([0,1], 0)
	f5 :: StateT ([Integer], Int) IO b
	f5 = do
	(l,i) <- get
	liftIO $ print l
	put (l ++ [(l!!i + l!!(i+1))],i+1)
	f5
	f6 :: [[Integer]]
	f6 = scanl (\x@(a:b:_) _ -> (a+b):x) [1,0] [0..]
	--f7 main = print "put 0" >> f7 1
	f7 :: Integer ->IO ()
	f7 b = do
	l <- getLine
	let a = read l
	putStr "put "
	print b
	f7 $ a + b

view raw fibo.hs hosted with ❤ by GitHub

---

f6 の実行例

*Main> last $ take 10 f6
[55,34,21,13,8,5,3,2,1,1,0]

これは

foldl (\x@(a:b:_) _ -> (a+b):x) [1,0] [0..８]

と同じです。

フィボナッチ数列の隣り合う 2 項の比は黄金比に収束^Wします。

	f2 (a,b) = do
	print (a,b)
	f2 (b,a+b)
	main = f2 (1,2)

view raw fibo2.hs hosted with ❤ by GitHub

	import Data.Ratio
	go = do
	c <- getLine
	let (a,b) = read c :: (Integer, Integer)
	print $ fromRational $ b % a
	go
	main = go

view raw gr.hs hosted with ❤ by GitHub

$ runghc fibo2.hs | runghc gr.hs

~
~
~
1.618033988749895
1.618033988749895
1.618033988749895
~
~
~
Ctrl-Cを押して終了。

シェルピンスキーのギャスケット

ｐｂｍファイルでシェルピンスキーのギャスケットを描きます。
まずパスカルの三角形をつくります。

	import System.Environment
	pascal :: [Integer] -> [Integer]
	pascal l = 1:[x+y|x<-l|y<- tail l]++[1]
	pascalT :: [[Integer]]
	pascalT = scanl (\x _ -> pascal x) [1] [1..]
	pascalTri :: Int -> IO [[Integer]]
	pascalTri n = return $ take n pascalT
	getN = getArgs >>= \[n] -> return $ 2 ^ read n
	main = getN >>= pascalTri >>= mapM_ print

view raw pascal.hs hosted with ❤ by GitHub

---

$ runghc -XParallelListComp pascal.hs 3
[1]
[1,1]
[1,2,1]
[1,3,3,1]
[1,4,6,4,1]
[1,5,10,10,5,1]
[1,6,15,20,15,6,1]
[1,7,21,35,35,21,7,1]

---

奇数部を１、偶数部を０に置き換えます。

	import System.Environment
	pascal :: [Integer] -> [Integer]
	pascal l = 1:[x+y|x<-l|y<- tail l]++[1]
	pascalT :: [[Integer]]
	pascalT = scanl (\x _ -> pascal x) [1] [1..]
	pascalTri :: Int -> IO [[Integer]]
	pascalTri n = return $ take n pascalT
	getN = getArgs >>= \[n] -> return $ 2 ^ read n
	filt p xs = [if p x then '1' else '0'|x<-xs]
	filtAll p xs = return [filt p x|x<-xs]
	fill xs n = xs ++ replicate (n - length xs) '0'
	fillAll n = return . map (\x -> fill x n)
	unwords' :: [String] -> IO String
	unwords' = return . unwords
	main = do
	n <- getN
	str <- pascalTri n　>>=
	filtAll odd >>=
	fillAll n >>=
	unwords'
	let len = show n
	putStrLn ("P1 " ++ len ++ " " ++ len ++ " " ++ str)

view raw sierpinski.hs hosted with ❤ by GitHub

---

$ runghc -XParallelListComp sierpinski.hs 10 | display

描画には１０数秒かかります。

コンパイルすればほぼ一瞬で描画するようになります。

---

http://senjounosantafe.blogspot.com/2019/02/blog-post.html

上記のページに

Ｐｙｔｈｏｎ　のコードを出力し
Ｔｕｒｔｌｅ　グラフィックスで
シェルピンスキーのギャスケットを再帰的に描画するＨａｓｋｅｌｌのコードを置いています。

---

また１次元のセル・オートマトンにルール９０を適用することでもシェルピンスキーのギャスケットを描画できるそうです。

	import Data.Bits
	fs = replicate 31 '0' ++ "010" ++ replicate 31 '0'
	r s rule = let i = bToI (toBs s) in rule !! i
	where toBs = map (\x -> if x == '0' then False else True)
	loop l ll rule = do
	if length l == 2
	then ll
	else loop (tail l) (ll ++ [r (take 3 l) rule]) rule
	loop0 l n rule = do
	putStrLn l
	if n == 0 then return l
	else loop0 (last ll:ll++[head ll]) (n-1) rule
	where ll = loop l [] rule
	bToI :: [Bool] -> Int
	bToI bs = foldl (\x (y,z) -> if z then setBit x y else clearBit x y) (0::Int)
	$ zipWith (\a b -> (a,b)) [0 ..] $ reverse bs
	main = do
	loop0 fs 31 $ reverse "01011010"

view raw ca.hs hosted with ❤ by GitHub

---

実行例
$ runghc ca.hs

main を

main =  loop0 fs 31 $ reverse "11100001"

と書き換えるとルール２２５を描画します。

Intから２進数の文字列に変換するには
「2進、8進、10進、16進の各表現を相互に変換する」のページ

https://github.com/haskell-jp/recipe-collection/blob/master/%E6%95%B0%E5%80%A4/2%E9%80%B2%E3%80%818%E9%80%B2%E3%80%8110%E9%80%B2%E3%80%8116%E9%80%B2%E3%81%AE%E5%90%84%E8%A1%A8%E7%8F%BE%E3%82%92%E7%9B%B8%E4%BA%92%E3%81%AB%E5%A4%89%E6%8F%9B%E3%81%99%E3%82%8B.md


を参考に。

具体的には

ghci> import Numeric
ghci> import Data.Char
ghci> showIntAtBase 2 intToDigit 123 "" -- 123を2進数表記
"1111011"

ただし８桁になるように先頭にゼロを埋めること。

"1111011" -> "01111011"

---

参考ページ
Elementary Cellular Automata

http://atlas.wolfram.com/01/01/

---

その他のルールも適用可能にし精細な画像を描くにはこちら。

http://hhg2the-haskell.blogspot.com/2019/02/blog-post.html

マンデルブロ集合

ｐｂｍファイルに書き出してマンデルブロ集合を描きます。（画像サイズは１０００ｘ１０００に固定しています。）

	--mandel.hs
	import Data.Array.Repa
	import Data.Complex
	import Control.DeepSeq
	import Control.Parallel.Strategies
	import System.Environment
	getXY :: IO ((Double,Double),Double)
	getXY = getArgs >>= (\[x,y,xx,_] -> return ((read x,read y),read xx))
	getRep :: IO Int
	getRep = getArgs >>= (\ [_,_,_,rep] -> return $ read rep)
	mkRowInD :: Double -> Double -> Int -> [Double]
	mkRowInD a gap n = take n [x | x <- [a,(a+gap)..]]
	mkRowInRepa :: [Double] -> Array U DIM1 Double
	mkRowInRepa l = fromListUnboxed (Z :. (length l)::DIM1) l
	mkImgParts y gap n = mkRowInRepa ds
	where ds = mkRowInD y gap n
	initC :: (RealFloat a) => Complex a
	initC = 0:+0
	isMandel :: Double -> Double -> Int -> Char
	isMandel a b n = isMandel' initC z n where z = a :+ b
	isMandel' :: (Eq a, Num a, RealFloat a1) => Complex a1 -> Complex a1 -> a -> Char
	isMandel' z c n
	| n==0 = '1'
	| realPart newC >= 2 = '0'
	| imagPart newC >= 2 = '0'
	| otherwise = isMandel' newC c (n-1)
	where newC = z*z+c
	pMap = Prelude.map
	isMandels a0 d n r =
	take n $ pMap (\x -> let d0 = a0 ! (Z:.x)
	in isMandel d0 d r) [0..]
	lineAll a y gap n r =
	pMap (\x -> let d = (a' x) ! (Z:.x)in isMandels a d n r)
	[0..(n-1)]
	`using` parListChunk 100 rdeepseq
	where a' x = mkImgParts y gap n
	pix = 1000 :: Int
	main = do
	((x,y),xx) <- getXY
	rep <- getRep
	let gap = abs (x - xx) / fromIntegral pix
	let r = mkRowInD x gap pix
	let a0 = mkRowInRepa r
	putStrLn "P1 "
	print pix
	print pix
	print $ unwords $ lineAll a0 y (-gap) pix rep

view raw mandel.hs hosted with ❤ by GitHub

---

コンパイルします。

$ ghc -O2 -threaded -rtsopts --make -XFlexibleContexts -eventlog mandel.hs
$ ./mande -2 2 2 3000 +RTS -N2 -l | display

displayコマンドにパイプします。
動作を確認。
$ threadscope mamdel.eventlog

殆どの時間２Coreで動いています。

---

Data.Array.Repa.IO.BMP

モジュールには

readImageFromBMP :: FilePath -> IO (Either Error (Array U DIM2 (Word8, Word8, Word8)))

writeImageToBMP :: FilePath -> Array U DIM2 (Word8, Word8, Word8) -> IO ()

という関数がありBMPファイルの読み書きができる。


画像サイズもコマンドラインから与えます。

	import Data.Array.Repa.IO.BMP
	import Data.Array.Repa as R
	import Data.Complex
	import GHC.Word
	import System.Environment
	bk,wt :: (GHC.Word.Word8, GHC.Word.Word8, GHC.Word.Word8)
	bk = (0,0,0)
	wt = (255,255,255)
	getXY :: IO ((Double,Double),Double)
	getXY = getArgs >>= (\[x,y,xx,_,_] -> return ((read x,read y),read xx))
	getRep :: IO Int
	getRep = getArgs >>= (\ [_,_,_,_,rep] -> return $ read rep)
	getPix = getArgs >>= (\ [_,_,_,p,_] -> return $ read p)
	mkRowInD :: Double -> Double -> Int -> [Double]
	mkRowInD a gap n = Prelude.take n [x | x <- [a,(a+gap)..]]
	mkRowInRepa :: [Double] -> Array U DIM1 Double
	mkRowInRepa l = fromListUnboxed (Z :. (Prelude.length l)::DIM1) l
	mkRealPart x gap n = mkRowInRepa ds
	where ds = mkRowInD x gap n
	mkImgPart y gap n = mkRowInRepa ds
	where ds = mkRowInD y (-gap) n
	initC :: (RealFloat a) => Complex a
	initC = 0:+0
	isMandel a b n = isMandel' initC z n where z = a :+ b
	isMandel' z c n
	| n == 0 = True
	| realPart newC >= 2 = False
	| imagPart newC >= 2 = False
	| otherwise = isMandel' newC c (n-1)
	where newC = z*z+c
	lineAll x y r = R.map (\(a,b) ->
	if isMandel (x ! (Z :. b))
	(y ! (Z :. a))
	r
	then wt
	else bk)
	cros pix = [(x,y) | x <- [0..(pix-1)],y <- [0..(pix-1)]]
	main = do
	((x,y),xx) <- getXY
	pix <- getPix
	rep <- getRep
	let gap = abs (x - xx) / fromIntegral pix
	let ra = mkRealPart x gap pix
	let ia = mkImgPart y gap pix
	let vr = fromListUnboxed (Z :. (pix*pix)) $ cros pix :: Array U DIM1 (Int,Int)
	let bs = lineAll ra ia rep vr
	computeP $ reshape (Z :. pix :. pix) bs
	>>=
	(writeImageToBMP "a.bmp")

view raw mandel2.hs hosted with ❤ by GitHub

$ ./mandel2 -2 2 2 1000 3000 +RTS -N2 -l

1次元の配列に対し　map し、　reshape すればよいので、コード自体はわかりやすい。
index のTable (Int のタプルの配列)を作るのに時間がかかっているようなので、
配列を連結するやり方も試みた。

	import Data.Array.Repa.IO.BMP
	import Data.Array.Repa as R
	import Data.Complex
	import Data.Vector.Unboxed
	import Data.List(foldl1')
	import GHC.Word
	import System.Environment
	bk,wt :: (GHC.Word.Word8, GHC.Word.Word8, GHC.Word.Word8)
	bk = (0,0,0)
	wt = (255,255,255)
	getXY :: IO ((Double,Double),Double)
	getXY = getArgs >>= (\[x,y,xx,_,_] -> return ((read x,read y),read xx))
	getRep :: IO Int
	getRep = getArgs >>= (\ [_,_,_,_,rep] -> return $ read rep)
	getPix = getArgs >>= (\ [_,_,_,p,_] -> return $ read p)
	mkRowInD :: Double -> Double -> Int -> [Double]
	mkRowInD a gap n = Prelude.take n [x | x <- [a,(a+gap)..]]
	mkRowInRepa :: [Double] -> Array U DIM1 Double
	mkRowInRepa l = fromListUnboxed (Z :. (Prelude.length l)::DIM1) l
	mkRealPart x gap n = mkRowInRepa ds
	where ds = mkRowInD x gap n
	mkImgPart y gap n = mkRowInRepa ds
	where ds = mkRowInD y (-gap) n
	initC :: (RealFloat a) => Complex a
	initC = 0:+0
	isMandel a b n = isMandel' initC z n where z = a :+ b
	isMandel' z c n
	| n == 0 = True
	| realPart newC >= 2 = False
	| imagPart newC >= 2 = False
	| otherwise = isMandel' newC c (n-1)
	where newC = z*z+c
	oneLine is xd yd y pix r = R.map (\x -> isMandel (xd R.! (Z :. x)) (yd R.! (Z :. y)) r) is
	lineAll xs ys pix r =
	Prelude.map (\x -> oneLine is xs ys x pix r) [0.. (pix-1)]
	where is = fromUnboxed (Z :. (pix::Int)) (enumFromN (0 :: Int) pix)
	main = do
	((x,y),xx) <- getXY
	pix <- getPix
	rep <- getRep
	let gap = abs (x - xx) / fromIntegral pix
	let ra = mkRealPart x gap pix
	let ia = mkImgPart y gap pix
	let o = lineAll ra ia pix rep
	let pp = Data.List.foldl1' (\x y -> x R.++ y) o
	let ppp = R.map (\x -> if x then wt else bk) pp
	computeP $ reshape (Z :. pix :. pix) ppp
	>>=
	(writeImageToBMP "a.bmp")

view raw mandel3.hs hosted with ❤ by GitHub

---

また　 mandel2.hsにおいてIndexをIntではなくWord16に置き換えてみたが効果は微妙だった。

---

世の中にはGPUを使ってマンデルブロー集合を極めて高速に描画するプログラムもあるらしい。

画像ビューアー

	import Graphics.UI.Gtk as G
	main = do
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 500, windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb
	containerAdd w sw
	b <- buttonNew
	i <- imageNewFromFile "IMGP2850.JPG"
	buttonSetImage b i
	containerAdd hb b
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw view.hs hosted with ❤ by GitHub

---

この画像（IMGP2850.JPG）を表示します。

ただこのやり方だと元画像の大きさそのままで表示されます。
サイズを変更して表示するには一旦Pixbufのインスタンスをつくってから
Buttonに貼り付けます。

	import Graphics.UI.Gtk as G
	main = do
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 500, windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb
	containerAdd w sw
	b <- buttonNew
	p <- pixbufNewFromFileAtSize "IMGP2850.JPG" 64 64
	i <- imageNewFromPixbuf p
	b `set` [buttonImage := i]
	containerAdd hb b
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw view2.hs hosted with ❤ by GitHub

---

かんたんな画像のビューアーをつくります。 まずディレクトリーを選択するダイアログ。

	import Graphics.UI.Gtk
	main = do
	initGUI
	fchdal <- fileChooserDialogNew Nothing Nothing
	FileChooserActionSelectFolder
	[("Cancel", ResponseCancel), ("Select", ResponseAccept)]
	fchdal `set` [fileChooserDoOverwriteConfirmation := True]
	widgetShow fchdal
	response <- dialogRun fchdal
	case response of
	ResponseCancel -> putStrLn "You cancelled..."
	ResponseAccept -> do
	nwf <- fileChooserGetFilename fchdal
	case nwf of
	Nothing -> putStrLn "Nothing"
	Just path -> putStrLn path
	w <- windowNew
	w `set` [windowDefaultWidth := 16, windowDefaultHeight := 16]
	s <- spinnerNew
	containerAdd w s
	widgetShowAll w
	spinnerStart s
	widgetDestroy fchdal
	fchdal `on` objectDestroy $ mainQuit
	mainGUI

view raw dirchooser.hs hosted with ❤ by GitHub

---

dirというファイルにリダイレクトしておきます。

$ runghc dirchooser.hs > dir

---

ビューアー

---

	import System.FilePath.Posix
	import Graphics.UI.Gtk
	import System.Directory
	import Control.Monad
	import System.FilePath.Posix
	newPixBufs size = mapM (\fn -> pixbufNewFromFileAtSize fn size size)
	dirFile = "dir"
	getD = readFile dirFile >>= (return . head . lines)
	isJpg fn = ex == ".jpg" || ex == ".JPG" where ex = takeExtension fn
	getJpegFiles0 = do
	getD >>= getDirectoryContents >>= filterM (return . isJpg)
	getJpegFiles = do
	getJpegFiles0 >>= mapM (\x -> do {d <- getD;return (d++"/"++x)})
	newImgButton size f f' = do
	vb <- vBoxNew True 0
	p <- pixbufNewFromFileAtSize f size size
	i <- imageNewFromPixbuf p
	b <- buttonNew
	set b [buttonImage := i]
	l <- labelNew $ Just $ f' ++ " "
	containerAdd vb b
	containerAdd vb l
	return vb
	newImgButtons :: Int ->[FilePath] -> [FilePath]-> IO [VBox]
	newImgButtons size fs fs' = do
	bs <- zipWithM (\x y -> newImgButton size x y) fs fs'
	return bs
	main = do
	files <- getJpegFiles
	files' <- getJpegFiles0
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 1000, windowDefaultHeight := 150]
	hb <- hBoxNew False 0
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb
	containerAdd w sw
	bs <- newImgButtons 64 files files'
	mapM_ (containerAdd hb) bs
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw viewer.hs hosted with ❤ by GitHub

ただ表示するだけではあまりにも芸がないのでちょっとした操作をしてみます。

ソースコード

https://github.com/index333/image

---

まず補助的関数を集めたMyImageモジュール

	module MyImage where
	import System.Exit
	import System.FilePath.Posix
	import Graphics.UI.Gtk
	import System.Directory
	import Control.Monad
	dirFile = "dir"
	getD = readFile dirFile >>= (return . head . lines)
	isJpg fn = ex == ".jpg" || ex == ".JPG"
	where ex = takeExtension fn
	getJpegFiles0 = do
	getD
	>>=
	getDirectoryContents
	>>=
	filterM (return . isJpg)
	getJpegFiles = do
	getJpegFiles0
	>>=
	(\x -> if null x
	then do print " No Jpg file in this directory."
	exitWith ExitSuccess
	return x
	else return x)
	>>=
	mapM (\x -> do {d <- getD;return (d++"/"++x)})
	viewButtons pvs blist = zipWithM viewButton pvs $ map b2c $ pac4 blist
	viewButton' pv rotation = do
	b <- buttonNew
	pv' <- pixbufRotateSimple pv rotation
	i <- imageNewFromPixbuf pv'
	set b [buttonImage := i]
	return b
	viewButton pv "right" = viewButton' pv PixbufRotateClockwise
	viewButton pv "left" = viewButton' pv PixbufRotateCounterclockwise
	viewButton pv "updown" = viewButton' pv PixbufRotateUpsidedown
	viewButton pv _ = viewButton' pv PixbufRotateNone
	newPixBufs size = mapM (\fn -> pixbufNewFromFileAtSize fn size size)
	newImgButton p = do
	b <- buttonNew
	i <- imageNewFromPixbuf p
	set b [buttonImage := i]
	return b
	newImgButtons :: [Pixbuf] -> IO [Button]
	newImgButtons = mapM newImgButton
	newRadioButton c n = do
	b <- radioButtonNew
	p <- pixbufNewFromFileAtSize (c ++ ".png") 32 32
	i <- imageNewFromPixbuf p
	set b [buttonImage := i]
	return b
	newRadioButtons i = do
	bb@(b:bs) <- mapM (\x -> newRadioButton x i) ["keep","right","left","updown"]
	mapM_ (\x -> x `set` [radioButtonGroup := b]) bs
	return bb
	b2c :: [Bool] -> String
	b2c [True,False,False,False] = "keep"
	b2c [False,True,False,False] = "right"
	b2c [False,False,True,False] = "left"
	b2c [False,False,False,True ]= "updown"
	pac' _ [] l = reverse l
	pac' i l ll = pac' i (drop i l) (take i l : ll)
	pac i l = pac' i l []
	pac4 = pac 4
	toBoollist :: String -> [Bool]
	toBoollist = read

view raw MyImage.hs hosted with ❤ by GitHub

---

一括処理を選択します。

---

	import MyImage
	import Graphics.UI.Gtk
	import Control.Monad
	newSelectButton label box = do
	b <- buttonNewWithLabel label
	b `on` buttonActivated $ func1 b
	containerAdd box b
	return b
	newSelectButtons labels box = do
	mapM ((flip newSelectButton) box) labels
	func1 b = do
	b `get` buttonLabel
	>>=
	putStrLn
	>>
	mainQuit
	main = do
	fl <- getJpegFiles
	initGUI
	w <- windowNew
	set w [windowWindowPosition := WinPosCenter,
	windowDefaultWidth := 1000, windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	vb <- vBoxNew True 0
	let selections = [ "Right All",
	"Left All",
	"Right-Left",
	"Left-Right",
	"UpDown All",
	"Up-Down",
	"Down-Up",
	"NO Pattern" ]
	newSelectButtons selections hb
	containerAdd vb hb
	ps <- newPixBufs 50 fl
	bs <- newImgButtons ps
	zipWithM (\x y -> set x [buttonLabel := (show y)]) bs [0..(length fl - 1)]
	hb1 <- hBoxNew False 0
	mapM (containerAdd hb1) bs
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw hb1
	containerAdd vb sw
	containerAdd w vb
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw select.hs hosted with ❤ by GitHub

---

画像の回転指定

---

	import MyImage
	import Graphics.UI.Gtk
	import Control.Monad
	main = do
	fl <- getJpegFiles
	initGUI
	w <- windowNew
	set w [windowTitle := "Close this window, to go to the next step.",
	windowWindowPosition := WinPosCenter,
	windowDefaultWidth := (length fl * 100),
	windowDefaultHeight := 400]
	sw <- scrolledWindowNew Nothing Nothing
	hb <- hBoxNew True 0
	vb0 <- vBoxNew True 0
	pbs <- newPixBufs 50 fl
	pbs1 <- newPixBufs (size fl) fl
	ibs <- newImgButtons pbs
	rbs <- mapM newRadioButtons [0..(length fl - 1)]
	mapM_ (\x -> (x `on` buttonActivated)(update pbs1 (concat rbs))) (concat rbs)
	c <- getContents
	let c' = lines c
	if null c' then setActive "No Pattern" rbs else setActive (head c') rbs
	zipWithM (\x y -> do
	f <- frameNew
	vb <- vBoxNew True 0
	containerAdd f vb
	boxPackStart vb x PackNatural 0
	mapM_ (\z -> boxPackStart vb z PackNatural 0) y
	boxPackStart hb f PackNatural 0)
	ibs rbs
	boxPackStart vb0 hb PackNatural 0
	scrolledWindowAddWithViewport sw vb0
	containerAdd w sw
	widgetShowAll w
	w `on` unrealize $ end $ concat rbs
	mainGUI
	size fl | length fl < 15 = 50
	| otherwise = round $ 50 / d
	where len = fromIntegral $ length fl
	d = len / 15
	setActive' bs l =
	zipWithM(\x y->((x!!y) `set` [toggleButtonActive := True])) bs $ cycle l
	setActive "Right All" bs = setActive' bs [1]
	setActive "Left All" bs = setActive' bs [2]
	setActive "UpDown All" bs = setActive' bs [3]
	setActive "Right-Left" bs = setActive' bs [1,2]
	setActive "Left-Right" bs = setActive' bs [2,1]
	setActive "Up-Down" bs = setActive' bs [0,3]
	setActive "Down-Up" bs = setActive' bs [3,0]
	setActive _ bs = setActive' bs [0]
	update pbs rbs = do
	w <- windowNewPopup
	w `set` [windowDefaultWidth := width, windowDefaultHeight := 150]
	hb <- hBoxNew True 0
	hb1 <- hBoxNew True 0
	vb <- vBoxNew True 0
	label <- labelNew $ Just "Show modified pictures"
	boxPackStart hb label PackNatural 0
	l <- mapM ((flip get)toggleButtonActive) rbs
	vbs <- viewButtons pbs l
	mapM_ (\x -> boxPackStart hb1 x PackNatural 0) vbs
	mapM_ (\x -> boxPackStart vb x PackNatural 0) [hb,hb1]
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw vb
	containerAdd w sw
	widgetShowAll w
	where width | length pbs * 100 > 1000 = 1050
	| otherwise = length pbs * 100
	end rbs = do
	mapM ((flip get) toggleButtonActive) rbs
	>>=
	print
	>>
	mainQuit

view raw image.hs hosted with ❤ by GitHub

---

確認

---

	import MyTable
	import MyImage
	import Graphics.UI.Gtk
	import Control.Monad
	main = do
	c <- getContents
	let l = pac4 (toBoollist c)
	let coms = map b2c l
	fl <- getJpegFiles
	initGUI
	w <- windowNew
	set w[windowTitle := "Confirm window",
	windowWindowPosition := WinPosCenter,
	windowDefaultWidth := (length fl*100),
	windowDefaultHeight := 350]
	hb <- hBoxNew True 0
	hb1 <- hBoxNew True 0
	vb <- vBoxNew True 0
	let txt = "Close this window,to go to the next step.\n" ++
	"Modified pictures are in the upper row.\n" ++
	"Original pictures are in the lower row."
	l0 <- labelNew $ Just txt
	ps <- newPixBufs 50 fl
	bs <- newImgButtons ps
	zipWithM (\x y -> x `set` [buttonLabel := (show y)]) bs [0..(length fl - 1)]
	vbs <- zipWithM (viewButton) ps coms
	t <- mkTable [vbs, bs] (2::Row) ((length bs)::Col)
	sw <- scrolledWindowNew Nothing Nothing
	scrolledWindowAddWithViewport sw t
	boxPackStart hb l0 PackNatural 0
	boxPackStart vb hb PackNatural 0
	containerAdd vb sw
	containerAdd w vb
	widgetShowAll w
	w `on` unrealize $ mainQuit >> putStrLn c
	mainGUI

view raw confirm.hs hosted with ❤ by GitHub

---

MyTable モジュール

	module MyTable where
	import Graphics.UI.Gtk
	import Control.Monad
	type Row = Int
	type Col = Int
	mkTable :: (Foldable t, WidgetClass widget) => t [widget] -> Row -> Col -> IO Table
	mkTable ws rs cs = do
	t <- tableNew rs cs True
	zipWithM (\x (a,b,c,d)-> tableAttachDefaults t x a b c d)
	(concat ws)
	(mkPos rs cs)
	return t
	mkPos r c = let rc = cross r c in
	map (\(x,y) -> (y,y+1,x,x+1)) rc
	cross r c = [(a,b)|a <- [0..(r-1)],b <- [0..(c-1)]]

view raw MyTable.hs hosted with ❤ by GitHub

---

最後にConvertコマンドを実行します。

---

	import System.Process
	import System.Exit
	import Graphics.UI.Gtk
	import MyImage
	mkopt' dig f = ["-verbose","-rotate",dig,f,f]
	mkopt'' dig f = ["-rotate",dig,f]
	mkopt fu ("right",f) = fu "90" f
	mkopt fu ("left",f) = fu "-90" f
	mkopt fu ("updown",f) = fu "180" f
	mkopt _ _ = [] -- mkopt' "0" f
	disp coms = do
	fs0 <- getJpegFiles0
	let ops' = filter (\x -> null x == False)
	$ zipWith (\x y -> mkopt mkopt'' (x, y)) coms fs0
	mapM_ (\x -> do
	mapM_ (\y -> do {putStr y; putStr " "}) x
	putStrLn "")
	ops'
	main = do
	c <- getContents
	let l = pac4 (toBoollist c)
	fs <- getJpegFiles
	let coms = map b2c l
	let ops = filter (\x -> null x == False)
	$ zipWith (\x y -> mkopt mkopt' (x, y)) coms fs
	if null ops
	then exitWith ExitSuccess >> return ()
	else return ()
	disp coms
	initGUI
	dia <- dialogNew
	dialogAddButton dia stockApply ResponseApply
	dialogAddButton dia stockCancel ResponseCancel
	label <- labelNew (Just "Exec 'convert' command with these options?")
	upbox <- dialogGetUpper dia
	boxPackStart upbox label PackGrow 10
	widgetShowAll upbox
	answer <- dialogRun dia
	if answer == ResponseApply
	then do {mapM_ (rawSystem "convert") ops; return ()}
	else widgetDestroy dia
	dia `on` unrealize $ mainQuit

view raw mkCom.hs hosted with ❤ by GitHub

---

スクリプトは

runghc dirChooser.hs > dir
runghc select.hs > tmp
cat tmp | runghc image.hs > tmp1
cat tmp1 | runghc confirm.hs > tmp2
cat tmp2 | runghc mkCom.hs

アイコンが必要です。

keep.png  left.png  right.png  updown.png

gtk2hs

gtk2hsのインストールは

sudo apt install libghc-gtk-dev

先にGHCを単独でインストールしてしまうとgtk2hsを加えるときに非常に時間がかかります。
Gtk2hsを使う予定がなくてもいきなり入れてしまったほうが良い。
もちろんこれでGHCも使えるようになります。

	import Graphics.UI.Gtk
	main = do
	initGUI
	w <- windowNew
	widgetShowAll w
	w `on` unrealize $ mainQuit
	mainGUI

view raw test.hs hosted with ❤ by GitHub

---

このコードを実行してウィンドウが表示されればインストールは成功です。

ハノイの塔

	--hanoi.hs
	import System.Environment
	getN :: IO Int
	getN = do
	a:_ <- getArgs
	return $ read a
	main = do
	n <- getN
	hanoi [1..n] 'A' 'B' 'C'
	hanoi [] _ _ _ = return ()
	hanoi (x:xs) o d t = do
	hanoi xs o t d
	putStrLn $ o:'-':d:[]
	hanoi xs t d o

view raw hanoi.hs hosted with ❤ by GitHub

ハノイの塔の由来や、ルール、解き方のアルゴリズムは省略します。

---

hanoi.hs

実質３行のプログラムです。

haskellが提供する再帰とｄｏ記法で極めて簡潔に書くことができます。

実行例

$ runghc hanoi.hs 3

A-B

A-C

B-C

A-B

C-A

C-B

A-B

最短の解き手順を表示します。

円盤３枚の場合です。

A-Bというのは塔Aの一番上の円盤を塔Bに移動するという意味です。

---

GUI版

---

	import Graphics.UI.Gtk
	import System.IO.Error
	import Data.Char
	import Control.Exception
	import System.Environment
	import Control.Monad
	getNs :: IO (Int,Int)
	getNs = getArgs >>= \[a,b] -> return (read a,read b)
	getN, getT :: IO Int
	getN = getNs >>= \(a,_) -> return a
	getT = getNs >>= \(_,b) -> return b
	recompose :: String -> [Int]
	recompose s = map length (words s)
	recompose' ss = return [recompose x|x <- ss]
	filWith0 :: [Int] -> IO [Int]
	filWith0 il = do
	n <- getN
	return $ zeros n ++ il
	where zeros x = replicate (x-length il) (0 :: Int)
	showLst :: [Int] -> String
	showLst [] = []
	showLst (x:xs) | x == 0 = '\n' : showLst xs
	| otherwise = replicate x (toUpper (intToDigit x)) ++ "\n" ++ showLst xs
	showTowers tw lbs = zipWithM_ (\x y -> x `set` [labelText := y])
	lbs
	[showLst x| x<- tw]
	move "A-B" (a:as,b,c) = (as,a:b,c)
	move "A-C" (a:as,b,c) = (as,b,a:c)
	move "B-A" (a,b:bs,c) = (b:a,bs,c)
	move "B-C" (a,b:bs,c) = (a,bs,b:c)
	move "C-A" (a,b,c:cs) = (c:a,b,cs)
	move "C-B" (a,b,c:cs) = (a,c:b,cs)
	move _ x = x
	move' s [aa,bb,cc] = let (a,b,c) = move s (aa,bb,cc) in return [a,b,c]
	update towers lbs = do
	l <- (catchIOError getLine (\_ -> return ""))
	mapM labelGetText lbs
	>>= recompose'
	>>= move' l
	>>= mapM filWith0
	>>= flip showTowers lbs
	main = do
	n <- getN
	let nullList = [] :: [Int]
	let towers@(a,b,c) = ([1..n],nullList,nullList)
	initGUI
	window <- windowNew
	box <- hBoxNew False 0
	(la,fa) <- myLabelWithFrameNew $ showLst a
	(lb,fb) <- myLabelWithFrameNew $ showLst b
	(lc,fc) <- myLabelWithFrameNew $ showLst c
	mapM_ (\x -> boxPackStart box x PackNatural 0) [fa,fb,fc]
	containerAdd window box
	widgetShowAll window
	window `on` unrealize $ mainQuit
	getT >>= timeoutAdd (f towers [la,lb,lc])
	mainGUI
	f t l = do
	update t l
	return True
	myLabelWithFrameNew , myLabelWithFrameNew' :: String -> IO (Label,Frame)
	myLabelWithFrameNew' s = do
	(l,f) <- myLabelWithFrameNew s
	return (l,f)
	myLabelWithFrameNew s = do
	l <- labelNewWithMnemonic s
	l `set` [labelJustify := JustifyCenter]
	getN >>= labelSetWidthChars l
	frame <- frameNew
	containerAdd frame l
	frame `set` [frameShadowType := ShadowOut]
	return (l, frame)

view raw guihanoi.hs hosted with ❤ by GitHub

$ runghc hanoi.hs 3 | runghc guihanoi.hs 3 100

labelhanoi.hsへの第2引数はタイミングです。ミリ秒で指定します。

同じ引数を渡すのは面倒なのでhanoi という名前でスクリプトを書いておきます。

ｒunghc hanoi.hs $1 | runghc guihanoi.hs $1 $2

＄ ./hanoi 9 500

---

コンソール版

	import Control.Monad.State
	import System.Environment
	dohanoi :: StateT ([Int], [Int], [Int]) IO b
	dohanoi = do
	showTowers
	l <- liftIO $ getLine
	ts <- get
	move l
	dohanoi
	move "" = return ()
	move "A-B" = do{ (a:as,b,c) <- get; put (as,a:b,c)}
	move "A-C" = do{ (a:as,b,c) <- get; put (as,b,a:c)}
	move "B-A" = do{ (a,b:bs,c) <- get; put (b:a,bs,c)}
	move "B-C" = do{ (a,b:bs,c) <- get; put (a,bs,b:c)}
	move "C-A" = do{ (a,b,c:cs) <- get; put (c:a,b,cs)}
	move "C-B" = do{ (a,b,c:cs) <- get; put (a,c:b,cs)}
	showTowers = do
	(a,b,c) <- get
	mapM_ (liftIO . print . reverse) [a,b,c]
	liftIO $ print ()
	nullList = [] ::[Int]
	getN :: IO Int
	getN = do{a:_ <- getArgs; return $ read a;}
	main :: IO (a, ([Int], [Int], [Int]))
	main = do
	n <- getN
	let towers = ([1..n],nullList,nullList)
	runStateT dohanoi towers

view raw doHanoi.hs hosted with ❤ by GitHub

---

スクリプト

runghc hanoi.hs  $1 | runghc -XFlexibleContexts doHanoi.hs $1

実行例

./dohanoi 64

こちらも参照ください。

https://senjounosantafe.blogspot.com/2018/05/hanoi.html

πの計算

ライプニッツの公式

---

	import Data.Ratio
	a = cycle [1,-1]
	b = [1,3..]
	c = zipWith (\x y -> x * 1 % y) a b
	main = do
	let a = take 1000 c
	let b = sum a
	print $ fromRational $ b * 4

view raw l.hs hosted with ❤ by GitHub

---

実行結果
＄　runghc ｌ.hs
3.140592653839793

マチンの公式によるπ

---

	n=10^10^4
	m0 = 5
	m1 = 239
	g n m = let a = scanl f (n `div` m) [5,9..]
	b = scanl f ((n `div` m ^ 3) `div` 3) [7,11..]
	in sum (takeWhile (>0) a) - sum (takeWhile (>0) b)
	where f x y = (x `div` m^4)*(y-4) `div` y
	main = do
	let a = g n m0
	let b = g n m1
	let r =(a * 4 - b) * 4
	print r

view raw m.hs hosted with ❤ by GitHub

参考にしたページ
http://handasse.blogspot.com/2011/12/1.html

---

Parallel版

	import Control.Parallel
	import Control.Parallel.Strategies (rpar, Strategy, using)
	import Text.Printf
	n=10^18^4
	m0 = 5
	m1 = 239
	g n m = let a = scanl f (n `div` m) [5,9..]
	b = scanl f ((n `div` m ^ 3) `div` 3) [7,11..]
	in sum (takeWhile (>0) a) - sum (takeWhile (>0) b)
	where f x y = (x `div` m^4)*(y-4) `div` y
	main = print $ (a * 4 - b) * 4
	where (a,b) = (g n m0, g n m1) `using` parPair
	parPair :: Strategy (a,b)
	parPair (a,b) = do
	a' <- rpar a
	b' <- rpar b
	return (a',b')

view raw pm.hs hosted with ❤ by GitHub

1万桁では差がでないので
１０万桁ほど計算します。

コンパイルします。

ghc  --make -O2 pm.hs -rtsopts -threaded -eventlog

CPUはCore2Duo。デュアルコアなので　-N2 オプションで実行します。
$./pm +RTS -N2 -l
threadscope で動作を確認します。
$ threadscope pm.eventlog

僅かですが速くなっています。

並列計算を効率よく利用するには最初から並列化を意識してコードを書く必要があるようです。

---

spigot アルゴリズムをLoopで書いたコード
kk62526　さんが１０進Basicで書いたコードをそのまま移植しています。

	import Control.Monad.State
	loop = do
	(q,r,t,i,u,y) <- get
	liftIO $ putStr $ show y
	put(10*q*i*(2*i-1),10*u*(q*(5*i-2)+r-y*t),t*u,i+1,u,y)
	(q,r,t,i,u,y) <- get
	put (q,r,t,i,3 * (3 * i + 1) * (3 * i + 2),y)
	(q,r,t,i,u,y) <- get
	put (q,r,t,i,u,(q * (27 * i - 1) + 5 * r) `div` 5 `div` t)
	loop
	main = do
	let (q,r,t,i) = (1,180,60,2)
	let u = 3 * (3 * i + 1) * (3 * i + 2)
	let y = (q * (27 * i - 12) + 5 * r) `div` 5 `div` t
	runStateT loop (q,r,t,i,u,y)

view raw spi.hs hosted with ❤ by GitHub

グローバル変数　「i(注）」に現在何桁目を計算しているかが保持されてますので（ただし＋２された数字）
(注：　本当は無名ですが、こう捉えたほうが分かりやすいです。）
if (i-2) `mod` 100 == 0　then ・・・・・・
のようなコードを挿めば１００桁ごとに区切ったりできます。

	import Control.Monad.State
	f = do
	(q,r,t,i,u,y) <- get
	put(10*q*i*(2*i-1),10*u*(q*(5*i-2)+r-y*t),t*u,i+1,u,y)
	(q,r,t,i,u,y) <- get
	put (q,r,t,i,3 * (3 * i + 1) * (3 * i + 2),y)
	(q,r,t,i,u,y) <- get
	put (q,r,t,i,u,(q * (27 * i - 1) + 5 * r) `div` 5 `div` t)
	loop0 = liftIO (print 3) >> f >> loop
	loop = do
	(q,r,t,i,u,y) <- get
	liftIO $ putStr $ show y
	if (i-2) `mod` 100 == 0
	then do liftIO (print ())
	liftIO $ putStrLn $ show $ i - 2
	f
	loop
	else f >> loop
	main = do
	let (q,r,t,i) = (1,180,60,2)
	let u = 3 * (3 * i + 1) * (3 * i + 2)
	let y = (q * (27 * i - 12) + 5 * r) `div` 5 `div` t
	runStateT loop0 (q,r,t,i,u,y)

view raw p.hs hosted with ❤ by GitHub

実行結果
 $ runghc p.hs > a
$ less a
3 1415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679()
100 8214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196()
200 4428810975665933446128475648233786783165271201909145648566923460348610454326648213393607260249141273()
300
~
~
~
（略）
ちなみに１００００桁を計算し終えるのに２秒少々でした。
ギボンズ博士が spigot アルゴリズムに対し
"not competitive with state-of-the-art arithmetic-geometric mean algorithms"
と言うとおり決して高速とはいえませんが、いきなり１桁目から表示を始めますので、
体感的には超高速です。
(注：１００００桁の計算では８万数千桁のIntegerが３つ、作られます。）

ギボンズ博士のspigot アルゴリズムは
https://www.cs.ox.ac.uk/jeremy.gibbons/publications/spigot.pdf
コードだけ紹介しますと

	piG3 = g(1,180,60,2)
	where
	g(q,r,t,i) = let (u,y)=(3*(3*i+1)*(3*i+2),div(q*(27*i-12)+5*r)(5*t))
	in y : g(10*q*i*(2*i-1),10*u*(q*(5*i-2)+r-y*t),t*u,i+1)
	main = print piG3

view raw sppi.hs hosted with ❤ by GitHub

平方根、立方根

	import System.Environment
	import Data.List
	getNs :: IO [Integer]
	getNs = getArgs >>= mapM (return . read)
	f 2 x = x * 2 + 1
	f 3 x = x ^ 2 * 3 + x * 3 + 1
	next g l m =
	if null t then (0,0)
	else (last t, genericLength t)
	where t = takeWhile (<= l) $ scanl1 (+) $ map (f m) [g..]
	iPart i n m = let (r,d) = next i n m in return (d+1)
	loop c g l m root = do
	let (r,d) = next g l m
	putStr $ show d
	let nr = newroot d
	loop (c+1)(nr*10) ((l - r) * 10 ^ m) m nr
	where newroot d = root*10+d
	main = do
	n:m:[] <- getNs
	r <- iPart 1 n m
	print r
	if r ^ m == n
	then print ()
	else loop 1 (r * 10) ((n-r^m)*10^m) m r

view raw nroot.hs hosted with ❤ by GitHub

---

2の平方根

$ runghc nroot.hs 2 2 | tee a

2の立方根

$ runghc nroot.hs 2 ３ | tee ｂ

猛列な勢いで計算しますので適当なファイルに保存もしています。（Ctrl-Cで停止）

---

なお√２に限ればこう書けます。

	loop a b n = do
	let c = a*2+1
	if c<b then loop (a+1)(b-c)(n+1)
	else putStr (show n) >> loop (a*10)(b*100)0
	main = loop 1 1 1

view raw root2.hs hosted with ❤ by GitHub

One liner:

loop a b n = return (a*2+1) >>= \c -> if c<b then loop (a+1)(b-c)(n+1) else putStr (show n) >> loop (a*10)(b*100)0; main = loop 1 1 1

 

---

平方根は正方形の色紙を百分割して並べることで、
立方根は正四角形のサイコロを千分割して貼り付けていくことで深い桁まで計算をすすめることができます。

参照ページ
http://senjounosantafe.blogspot.com/2018/05/2.html

xgamma

---

画面が明る過ぎるとき、いちいちモニターを調節するのは面倒。

そんなときはガンマ調整で済まします。
ディストリビューションによっては
xbrightness-gamma
というプログラムが用意されています。

またxgamma コマンドでも可能。

% xgamma -gamma 0.3

などとします。

Haskellでフロントエンドを作っておきます。

---

	import Graphics.UI.Gtk
	import MySpinBox
	import System.Process
	main = do
	initGUI
	window <- windowNew
	hbox <- hBoxNew False 0
	vbox <- vBoxNew False 0
	boxPackStart vbox hbox PackNatural 0
	spmod <- mkAdjustment (0.5, 0.1, 1.0, 0.1, 0.1)
	[sps] <- myAddSpinButtons hbox ["gamma"] [spmod]
	update spmod
	onValueChanged spmod $ update spmod
	containerAdd window vbox
	widgetShowAll window
	window `on` unrealize $ mainQuit
	mainGUI
	update spmod = do
	r <- spmod `get` adjustmentValue
	rawSystem "xgamma" ["-gamma", show r] >>= print

view raw gamma.hs hosted with ❤ by GitHub

	module MySpinBox where
	import Graphics.UI.Gtk
	import Control.Monad
	mkAdjustment :: (Double, Double, Double, Double, Double) -> IO Adjustment
	mkAdjustment (v,l,u,s,p) = adjustmentNew v l u s p 0
	{-
	:: Double value - the initial value.
	-> Double lower - the minimum value.
	-> Double upper - the maximum value.
	-> Double stepIncrement - the step increment.
	-> Double pageIncrement - the page increment.
	-> Double pageSize - the page size.
	-}
	mkAdjustments :: [(Double, Double, Double, Double, Double)] ->
	IO [Adjustment]
	mkAdjustments = mapM mkAdjustment
	myAddSpinButtons :: HBox -> [String] ->[Adjustment] -> IO [SpinButton]
	myAddSpinButtons box names adjustments = do
	zipWithM (\x y -> myAddSpinButton box x y) names adjustments
	myAddSpinButton :: HBox -> String -> Adjustment -> IO SpinButton
	myAddSpinButton box name adj = do
	vbox <- vBoxNew False 0
	boxPackStart box vbox PackRepel 0
	label <- labelNew (Just name)
	miscSetAlignment label 0.0 0.5
	boxPackStart vbox label PackNatural 0
	spinb <- spinButtonNew adj 10 1
	boxPackStart vbox spinb PackGrow 0
	return spinb

view raw MySpinBox.hs hosted with ❤ by GitHub

---

スポーク長計算

https://github.com/index333/spcal

からソースがＤＬできます。

新バージョンは

https://github.com/index333/spcal2

---

各寸法の測り方は
https://www.sheldonbrown.com/spoke-length.html
を参考にしてください。

まずサンプルファイルを作っておきます。

426.0
45.0
37.3
45.0
20.7

次のスクリプトを実行します。

$ cat sample | runghc spcal.hs

---

	import Graphics.UI.Gtk
	import System.IO
	import MySpinBox
	import Round
	import Control.Monad
	readSample :: IO [Double]
	readSample = do
	r <- getContents
	return $ map read $ lines r
	rad d = ((2*pi)/360)*d
	dig r = r / (yen/360)
	yen = rad 360 :: Double
	hosei = 2.4 / 2 :: Double
	calLen a b d k h = sqrt ((a^2+b^2+d^2) - (2*a*b*(cos $ alfa h k))) - hosei
	where alfa h k = rad (360 / h * k)
	disp h a b c s = do
	print $ s++"-side"
	let l = map (\x -> calLen (a/2) (b/2) c x h) [0,2..8]
	zipWithM (\x y -> do
	putStr $ show x
	putStr "cross="
	putStr $ show $ round1 y
	putStrLn "mm")
	([0..4]::[Int])
	l
	print ()
	main = do
	a:b:c:d:e:[] <- readSample
	print $ a:b:c:d:e:[]
	initGUI
	window <- windowNew
	hbox <- hBoxNew False 0
	vbox <- vBoxNew False 0
	boxPackStart vbox hbox PackNatural 0
	let names = ["スポーク穴数",
	"erd(mm)",
	"pcd(mm)",
	"flange2center(mm)",
	"pcd(mm)",
	"flange2center(mm)"]
	adjs <- mkAdjustments [(32, 20, 40 ,4,4),
	(a,200, 700, 0.1,10),
	(b,30, 100 ,1,1),
	(c,10, 50, 0.1,1),
	(d,30, 100 ,1,1),
	(e,10, 50, 0.1,1)]
	spins@s0:s1:s2:s3:s4:s5 <- myAddSpinButtons hbox names adjs
	mapM_ ( `set` [spinButtonDigits := 0]) [s0,s2,s4]
	update adjs
	mapM (\x-> onValueChanged x (update adjs)) adjs
	containerAdd window vbox
	widgetShowAll window
	window `on` unrealize $ end adjs
	mainGUI
	end adjs = do
	l <- mapM (`get` adjustmentValue) adjs
	mapM_ (\x -> hPutStrLn stderr $ show x) $ tail l
	mainQuit
	update adjs = do
	h:a:b:c:d:e:_ <- mapM (`get` adjustmentValue) adjs
	disp h a b c "left"
	disp h a d e "right"

view raw spcal.hs hosted with ❤ by GitHub

MySpinBox モジュール

	module MySpinBox where
	import Graphics.UI.Gtk
	import Control.Monad
	mkAdjustment :: (Double, Double, Double, Double, Double) -> IO Adjustment
	mkAdjustment (v,l,u,s,p) = adjustmentNew v l u s p 0
	{-
	:: Double value - the initial value.
	-> Double lower - the minimum value.
	-> Double upper - the maximum value.
	-> Double stepIncrement - the step increment.
	-> Double pageIncrement - the page increment.
	-> Double pageSize - the page size.
	-}
	mkAdjustments :: [(Double, Double, Double, Double, Double)] ->
	IO [Adjustment]
	mkAdjustments = mapM mkAdjustment
	myAddSpinButtons :: HBox -> [String] ->[Adjustment] -> IO [SpinButton]
	myAddSpinButtons box names adjustments = do
	zipWithM (\x y -> myAddSpinButton box x y) names adjustments
	myAddSpinButton :: HBox -> String -> Adjustment -> IO SpinButton
	myAddSpinButton box name adj = do
	vbox <- vBoxNew False 0
	boxPackStart box vbox PackRepel 0
	label <- labelNew (Just name)
	miscSetAlignment label 0.0 0.5
	boxPackStart vbox label PackNatural 0
	spinb <- spinButtonNew adj 10 1
	boxPackStart vbox spinb PackGrow 0
	return spinb

view raw MySpinBox.hs hosted with ❤ by GitHub

Round モジュールも必要です。

	module Round where
	roundN :: Int -> Double -> Double
	roundN n d = fromIntegral (round (d * 10 ^ n)) / fromIntegral (10 ^ n)
	round1,round2 :: Double -> Double
	round1 = roundN 1
	round2 = roundN 2

view raw Round.hs hosted with ❤ by GitHub

Failed to load module “canberra-gtk-module” のようなエラーメッセージがでるかも知れません。

無視してもかまいませんが

libcanberra-gtk-module

をインストールすると解消します。

sudo apt-get install libcanberra-gtk-module

---

スポーク長の計算式は








aはErdの２分の１、ｂはｐｃｄの２分の１、ｄはフランジとセンター間の距離。 ｈはホール数、ｋは組数です。
Haskellでは

calLen a b d k h = sqrt ((a^2+b^2+d^2) - (2*a*b*(cos $ alfa h k)))　
     where alfa h k = rad (360 / h * k) 

この計算は同心円上の２点間の距離の問題に還元できます。このような計算は複素数で行うととても楽になります。

ハブ軸を原点に、交差する２本のスポークの交点を複素平面上の実数軸にあわせます。
（３２ホール、６本組）

（見やすいように、ハブは実際より大きく描いています。）

スポークの両端をハブ側をA点,リム側をB点としますと

点Aの位相(実数軸との角度）はどの組み方でも 
３６０度➗（リムの穴数➗２）　ｘ　（組数ー１）➗2
３２ホール、６本組の場合、２２．５度×２．５＝５６．２５度
絶対値（原点までの距離）はハブのPCＤの半分

点Bの位相は組み方に関係なく
 ３６０度➗リムの穴数×（−１）
３２ホール、６本組の場合、ー１１．２５度
絶対値はリムのERDの半分。
 これにハブの厚みとスポークの長さ表示方法を考慮して関数化すると

dist :: RealFloat a => Complex a -> Complex a -> a -> a
dist x y z = sqrt (l * l + z * z) where l = magnitude (x - y)
calLen a b d k h = dist x y d - hosei        
    where   x = mkPolar b (yen / (h / 2) * (k - 1) / 2)
                 y = mkPolar a (yen / h * (-1))
　　　　　yen = pi * 2

 どちらを使っても同じ結果になります。

なおラジアル組みの場合、簡易な計算で求められますが、
たまたま位相が一致する特殊なケースとして一般化できます。

---

Ｊａｖａなどのオブジェクト指向言語ではデータをオブジェクトのまま保存します。

Ｈａｓｋｅｌｌではdata型をＳｈｏｗして保存し、読み込んでＲｅａｄすると元のdata型に戻してくれます。

このやり方で新しく書き換えました。

$ runghc menu.hs

もう一度ソースの置き場所を・・・

https://github.com/index333/spcal2

なおリムやハブのデータはテストのための仮データです。

---

同じような画面構成の小さなプログラムを復数書かなければいけないとき、継承が恋しくなる。

---

一応テストはしてますが他のサイトでも検算して下さい。

http://spoke.gzmapss.com/

が使いやすいです。

---

後記：

しばらくたってから実際に使ってみると、復数開くウインドウの閉じ方に難があることがわかりました。
（＾＿＾；）

実用上は問題ないのですが・・・
Guiのプログラムを復数立ち上げるというのは独立したスレッドを生むことになるので制御がむつかしいケースが生じます。

気になる場合は、

runghc mkRim.hs
runghc selector.hs
runghc selectRim.hs
runghc selectHub.hs
runghc spcal.hs

のようなスクリプトを作ります。

stern-brocot 木

stern-brocot 木
Stern-Brocot 木の「親」の値は数直線の区間です。
頂点の親「根」の値は
０〜∞
左端が０で、右は無限大です。
それを分数で０/１、１/０とそれぞれ表します。
さらにHaskellではタプルで
(0,1) ,(1,0)
と表します。
つまりHaskellでStern-Brocot 木の根はタプルのタプルで
（(0,1) ,(1,0))
と表せます。
親はいつでも自動で左の子、右の子を生成することができます。
Haskellで書くとこのような関数になります。

sb ((x,y),(z,w)) = (a,b)  where  a = ((x,y),c) ; b = (c,(z,w)); c = (z+x,y+w)

aが左の子ｂが右の子です。左の子の右端と右の子の左端は同じです。分割点になります。

main = do
    let a = (0,1)
    let b = (1,0)
    let r = (a,b)
    print r
    print $ sb r

((0,1),(1,0))
(((0,1),(1,1)),((1,1),(1,0)))

数直線の区間
０〜∞
を
０〜１
と
１〜∞
の２つの区間に分割したのと同じです。

もう一世代増やしてみましょう。

main = do
    let a = (0,1)
    let b = (1,0)
    let r = (a,b)
   
    let (a,b) = sb r
    print $ sb a
    print $ sb b

(((0,1),(1,2)),((1,2),(1,1)))
(((1,1),(2,1)),((2,1),(1,0)))

これは
数直線の区間
０〜１
を
０〜０．５
と
０．５〜１
に
１〜∞
を
１〜２
と
２〜∞
に分割したのと同じです。
これを繰り返せば数直線を無限に分割できます。
Stern-Brocot 木の木構造としての性質等は
Spaghetti Source - Stern-Brocot 木
http://www.prefield.com/algorithm/math/stern_brocot_tree.html

を参照してください。
さてStern-Brocot木を２分探索してゆけば全ての少数を分数に変換できるのですが、
そのためにはStern-Brocot木を前もって作成しておく必要はありません。
与えられた少数と分割点とを比較しながら片側の子のみを辿ってゆけばよい。

この辺はコードにしたほうがわかりやすい。

---

	import Data.Ratio
	loop x a = do
	print a
	let (l,r) = sb a
	let (_,(d,e)) = l
	case compare (fromRational (d%e)) x of
	EQ -> return $ d%e
	GT -> loop x l
	LT -> loop x r
	sb((x,y),(z,w))=(a,b)
	where a = ((x,y),c)
	b= (c,(z,w))
	c= (z+x,y+w)
	main = do
	let a = (0,1)
	let b = (1,0)
	let r = (a,b)
	loop pi r >>= print

view raw sb.hs hosted with ❤ by GitHub

---

実行結果

245850922 % 78256779

---