Haskell＋Python.Turtleでハノイの塔をグラフィカルに解きます。

-- pbm.hs
import System.IO 
import System.Environment
getI :: IO Int 
getI = getArgs >>= (\(x:_) -> (return . read) x)
main = do
    n <- getI 
    mapM_ mkpbm [1..n]
mkpbm n = do
    h <- openFile ((show n) ++ ".pbm") WriteMode
    pbm h n
    hClose h
pbm h n = do
    hPutStrLn h "P1"
    hPutStrLn h $ show (10 * n)
    hPutStrLn h "10 "
    mapM_ (\x -> hPutStrLn h (line n)) [0..9]
    where line n = take (n*10) $ ['1','1' ..]

    
-- conv.hs
import System.Process
import System.FilePath
import System.Directory
main = do
    fs <- getCurrentDirectory >>= listDirectory 
    let fss = filter (\x -> "pbm" `isExtensionOf` x) fs
    print fs
    print fss
    mapM_ conv fss
--  % convert -fill 新しい色 -opaque 古い色 orig.png new.gif
conv i = do
    let o = nf
    createProcess (proc "convert" ["-fill","brown","-opaque","black", i ,o])
    where nf = replaceExtension i "gif" 

    
-- tHanoi.hs
import HTurtle
import Control.Monad
import Control.Monad.State
import Control.Exception
import System.IO.Error
main = do
    start
    line [(0,0),(0,100)]
    line [(100,0),(100,100)]
    line [(200,0),(200,100)]
    ts <- mapM tCons [1 .. 9]
    mapM_ (flip tSpeed 10) ts
    mapM_ tPenup ts
    putStrLn "s=getscreen()"
    mapM_ tReg gs
    zipWithM  tShape  ts gs
    zipWithM tMove ts p
    runStateT  loop (9,0,0)
    end
    where   p = [(0,x*10 - 10)|x <- [9,8..1]]
            gs = [show x++".gif"|x <- [1..9]]
tSpeed :: String -> Double -> IO()
tSpeed tn sn = do
    putStr tn
    putStr "."
    speed sn
tPenup :: String -> IO ()
tPenup tn = do
    putStr tn
    putStr "."
    penup
tCons :: Int -> IO String
tCons n = do
    putStr "t"
    putStr $ show n
    putStr "="
    putStrLn "Turtle()" 
    return $ 't':show n
tShape :: String -> String -> IO ()
tShape tname gifName = do
    putStr tname 
    putStr "."
    shape gifName
tReg :: String -> IO ()
tReg gn = do
    putStr "s"
    putStr "."
    putStr "register_shape"
    putStr "("
    putStr $ show gn
    putStrLn ")" 
tMove :: String -> Point -> IO()
tMove tn p = do
    putStr tn 
    putStr "." 　　
    setPos p
loop = do 
    [a,b,c] <- liftIO $ catchIOError getLine (\_ -> return "000")
    if a == '0' 
    then return ()
    else do
        let disc = "t" ++ [a]
        let tower = getTower c
        y <- update [b,c] 
        liftIO $ tMove disc (tower,fromIntegral (y*10))
        loop
getTower 'A' = 0
getTower 'B' = 100
getTower 'C' = 200
getTower _  = 0
update "AB" = do{(a,b,c) <- get;put(a-1,b+1,c);return b}
update "AC" = do{(a,b,c) <- get;put(a-1,b,c+1);return c}
update "BA" = do{(a,b,c) <- get;put(a+1,b-1,c);return a}
update "BC" = do{(a,b,c) <- get;put(a,b-1,c+1);return c}
update "CA" = do{(a,b,c) <- get;put(a+1,b,c-1);return a}
update "CB" = do{(a,b,c) <- get;put(a,b+1,c-1);return b}
update _ = return 0
 -- HTurtle.hs

module HTurtle where
type Point = (Double,Double)

f0 :: String -> IO()
f0 s = putStrLn s
f1 :: String -> IO()
f1 s = do
    putStr s
    putStrLn "()"
f2 :: String -> Double -> IO()
f2 s n = do
    putStr s
    putStr "("
    putStr $ show n
    putStrLn ")"
f2' :: String -> Point -> IO()
f2' s p = do
    putStr s
    putStrLn $ show p
f3 :: String -> String -> IO()
f3 s s1 = do
    putStr s
    putStr "("
    putStr "\""
    putStr s1
    putStr "\""
    putStrLn ")"
dig x = x / (pi / 180)
start = f0 "from turtle import *"
end = f1 "done"
getHeading = print "a = heading()"

pensize = f2 "pensize" 
screensize p = f2' "screensize" p
polygon :: [Point] -> String -> Bool -> IO ()
polygon pp@(p:ps) color True = do
    fillColor color
    beginFill
    penup
    setPos p
    pendown
    mapM_ setPos (ps ++ [p])
    endFill
line [a,b] = penup >> setPos a >> color "black" >> pendown >> setPos b  
erase [a,b] = penup >> setPos a >> color "white" >> pendown >> setPos b >> color "black" >> penup
dot p = penup >> setPos p >> pendown >> f1 "dot" >> pendown
penup = f1 "penup"
pendown = f1 "pendown"
triangle = polygon 
circle (a,b) x = penup >> setPos (a,b-x) >> pendown >> f2 "circle" x 
speed = f2 "speed" 
shape = f3 "shape" 
color = f3 "color" 
fillColor = f3 "fillcolor" 
beginFill = f1 "begin_fill"
endFill = f1 "end_fill"
setPos = f2' "setpos" 
setx = f2 "setx"
sety = f2 "sety" 
setH x = f2 "seth" (dig x)
foward x = pendown >> f2 "fd" x 
right = f2 "right" 
left = f2 "left" 
-- end of HTurtle.hs