SimpleDrawing/Turtle.hs at master · lebastr/SimpleDrawing · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
module Turtle ( Turtle (..)
              , penup
              , pendown
              , dippen
              , forward
              , turn
              , cstep
              , clean
              , reset
              , pop
              , push
              , send
              , getTurtle
              , mvarIO
              , turtleProcess
              , StateTurtle
              , MyColor
              , Distance
              , Angle
              , setpos
              , setangle ) where

import SimpleDrawing
import Control.Concurrent
import System.IO.Unsafe (unsafePerformIO)
import Control.Monad.State.Strict

mvar :: MVar (StateTurtle ())
mvar = unsafePerformIO newEmptyMVar

mvarIO :: MVar (IO ())
mvarIO = unsafePerformIO newEmptyMVar

type Distance = Radius
-- type Angle    = Double
type MyColor  = (GLfloat, GLfloat, GLfloat)

data Turtle = Turtle { position :: Point
                     , step     :: Distance
                     , angle    :: Angle
                     , pen      :: Bool
                     , color    :: MyColor } deriving (Show)

turtle0 = Turtle { position = (0,0)
                 , angle    = 0
                 , step     = 0.1
                 , pen      = True
                 , color    = (1,1,1)}

process = evalStateT program (turtle0, [])

type StateTurtle = StateT (Turtle,[Turtle]) IO

setpos (x,y) = do
  t <- getTurtle
  putTurtle (t {position = (x,y)})

setangle a = do
  t <- getTurtle
  putTurtle (t {angle = a})

penup :: StateT (Turtle, [Turtle]) IO ()
penup = do
  t <- getTurtle
  putTurtle (t {pen = False})

pendown :: StateT (Turtle, [Turtle]) IO ()
pendown = do
  t <- getTurtle
  putTurtle (t {pen = True})

dippen :: MyColor -> StateT (Turtle, [Turtle]) IO ()
dippen c = do
  t <- getTurtle
  putTurtle (t {color = c})

forward :: StateT (Turtle, [Turtle]) IO ()
forward = do
  turtle <- getTurtle
  let (x0,y0) = position turtle
      a = angle turtle
      d = step turtle
      (r,g,b) = color turtle
      (dx,dy) = fromPolar2D (d,a)
      (x1,y1) = (x0 + dx, y0 + dy)
      turtle' = turtle { position = (x1,y1) }
  putTurtle turtle'
  case pen turtle of
    True -> lift $ putMVar mvarIO $ do
      currentColor $= Color4 r g b 0
      draw $ Line (x0,y0) (x1,y1)
      flush
    False -> return ()

turn :: Angle -> StateT (Turtle, [Turtle]) IO ()
turn a = do
  t <- getTurtle
  putTurtle $ t { angle = angle t + (pi*a/180) }

cstep :: Distance -> StateT (Turtle, [Turtle]) IO ()
cstep k = do
  t <- getTurtle
  putTurtle $ t { step = k * step t }

clean :: StateTurtle ()
clean = lift $ putMVar mvarIO clear

reset :: StateTurtle ()
reset = put $ (turtle0, [])

getTurtle :: StateTurtle Turtle
getTurtle = fst `liftM` get

putTurtle :: Turtle -> StateTurtle ()
putTurtle t = do
  (_,s) <- get
  put (t,s)

pop :: StateTurtle ()
pop = do
  (x,s) <- get
  case null s of
    True  -> return ()
    False -> put (head s, tail s)

push :: StateTurtle ()
push = do
  (x,s) <- get
  put (x,x:s)

program :: StateTurtle ()
program = lift (takeMVar mvar) >>= id >> program

turtleProcess = evalStateT program (turtle0, [])

send :: StateTurtle () -> IO ()
send = putMVar mvar