diff --git a/src/Graphics/X11/Turtle.hs b/src/Graphics/X11/Turtle.hs --- a/src/Graphics/X11/Turtle.hs +++ b/src/Graphics/X11/Turtle.hs @@ -57,7 +57,7 @@ import Graphics.X11.TurtleMove( Field, Layer, Character, forkIOX, openField, closeField, - addCharacter, addLayer, layerSize, clearLayer, clearCharacter, + addCharacter, addLayer, fieldSize, clearLayer, clearCharacter, addThread, fieldColor, onclick, waitField, moveTurtle ) @@ -66,7 +66,7 @@ getTurtleStates, getPosition, getPendown, undonum, visible, direction ) import qualified Graphics.X11.TurtleInput as S(degrees) -import Graphics.X11.TurtleShape(lookupShape, classic) +import Graphics.X11.TurtleShape(lookupShape) import Control.Concurrent(Chan, writeChan, threadDelay, ThreadId, killThread) import Control.Monad(replicateM_, zipWithM_) import Prelude hiding(Left) @@ -76,9 +76,10 @@ import Data.Fixed(mod') xturtleVersion :: (Int, String) -xturtleVersion = (18, "0.0.11") +xturtleVersion = (21, "0.0.12") data Turtle = Turtle { + field :: Field, layer :: Layer, character :: Character, inputChan :: Chan TurtleInput, @@ -91,9 +92,10 @@ newTurtle f = do ch <- addCharacter f l <- addLayer f - (ic, sts) <- getTurtleStates classic + (ic, sts) <- getTurtleStates $ lookupShape "classic" si <- newIORef 1 let t = Turtle { + field = f, inputChan = ic, layer = l, character = ch, @@ -182,7 +184,7 @@ c = shift r 16 .|. shift g 8 .|. b [r, g, b] = map fromIntegral [r_, g_, b_] -pensize :: Turtle -> Int -> IO () +pensize :: Turtle -> Double -> IO () pensize t = sendCommand t . Pensize degrees :: Turtle -> Double -> IO () @@ -196,8 +198,8 @@ >>= flip replicateM_ (sendCommand t Undo) . undonum . (states t !!) windowWidth, windowHeight :: Turtle -> IO Double -windowWidth = fmap fst . layerSize . layer -windowHeight = fmap snd . layerSize . layer +windowWidth = fmap fst . fieldSize . field +windowHeight = fmap snd . fieldSize . field position :: Turtle -> IO (Double, Double) position Turtle{stateIndex = si, states = s} = diff --git a/src/Graphics/X11/TurtleInput.hs b/src/Graphics/X11/TurtleInput.hs --- a/src/Graphics/X11/TurtleInput.hs +++ b/src/Graphics/X11/TurtleInput.hs @@ -35,7 +35,7 @@ | Left Double | Undonum Int | Pencolor Color - | Pensize Int + | Pensize Double | Degrees Double deriving Show @@ -48,9 +48,10 @@ nextTurtle :: TurtleState -> TurtleInput -> TurtleState nextTurtle t (Shape sh) = (clearState t){shape = sh} -nextTurtle t (ShapeSize ss) = (clearState t){size = ss} +nextTurtle t (ShapeSize ss) = (clearState t){shapesize = ss} nextTurtle t (Goto x y) = (clearState t){position = (x, y), line = pendown t, - drawed = if pendown t then (pencolor t, position t, (x, y)) : drawed t else drawed t} + drawed = if pendown t then (pencolor t, pensize t, position t, (x, y)) + : drawed t else drawed t} nextTurtle t (Rotate d) = (clearState t){direction = d} nextTurtle t Pendown = (clearState t){pendown = True} nextTurtle t Penup = (clearState t){pendown = False} diff --git a/src/Graphics/X11/TurtleMove.hs b/src/Graphics/X11/TurtleMove.hs --- a/src/Graphics/X11/TurtleMove.hs +++ b/src/Graphics/X11/TurtleMove.hs @@ -8,7 +8,7 @@ closeField, addLayer, addCharacter, - layerSize, + fieldSize, clearLayer, clearCharacter, addThread, @@ -23,7 +23,7 @@ import Graphics.X11.WindowLayers( Field, Layer, Character, forkIOX, openField, closeField, flushLayer, - addLayer, addCharacter, layerSize, clearLayer, + addLayer, addCharacter, fieldSize, clearLayer, drawLine, drawCharacter, drawCharacterAndLine, undoLayer, drawLineNotFlush, clearCharacter, addThread, @@ -55,18 +55,18 @@ moveTurtle c l t0 t1 = do when (undo t1 && line t0) $ do done <- undoLayer l - unless done $ clearLayer l >> drawLines l (pensize t1) (drawed t1) - when (undo t1 && clear t0) $ drawLines l (pensize t1) $ drawed t1 + unless done $ clearLayer l >> drawLines l (drawed t1) + when (undo t1 && clear t0) $ drawLines l $ drawed t1 when (visible t1) $ do forM_ (getDirections (dir t0) (dir t1)) $ \d -> do - drawTurtle c (pencolor t1) (shape t1) (size t1) d + drawTurtle c (pencolor t1) (shape t1) (shapesize t1) d (pensize t1) p0 Nothing threadDelay rotateSpeed forM_ (getPositions x0 y0 x1 y1) $ \p -> do - drawTurtle c (pencolor t1) (shape t1) (size t1) + drawTurtle c (pencolor t1) (shape t1) (shapesize t1) (dir t1) (pensize t1) p lineOrigin threadDelay moveSpeed - drawTurtle c (pencolor t1) (shape t1) (size t1) (dir t1) + drawTurtle c (pencolor t1) (shape t1) (shapesize t1) (dir t1) (pensize t1) p1 lineOrigin unless (visible t1) $ clearCharacter c when (not (undo t1) && line t1) $ @@ -78,9 +78,9 @@ p0@(x0, y0) = position t0 p1@(x1, y1) = position t1 -drawLines :: Layer -> Int -> [(Color, (Double, Double), (Double, Double))] -> IO () -drawLines l lw ls = - mapM_ (\(clr, (x0, y0), (x1, y1)) -> drawLineNotFlush l lw clr x0 y0 x1 y1) $ reverse ls +drawLines :: Layer -> [(Color, Double, (Double, Double), (Double, Double))] -> IO () +drawLines l ls = + mapM_ (\(clr, lw, (x0, y0), (x1, y1)) -> drawLineNotFlush l lw clr x0 y0 x1 y1) $ reverse ls getPositions :: Double -> Double -> Double -> Double -> [Pos] getPositions x0 y0 x1 y1 = take num $ zip [x0, x0 + dx .. ] [y0, y0 + dy .. ] @@ -95,7 +95,7 @@ where dd = if de > ds then stepDir else - stepDir -drawTurtle :: Character -> Color -> [Pos] -> Double -> Double -> Int -> +drawTurtle :: Character -> Color -> [Pos] -> Double -> Double -> Double -> Pos -> Maybe Pos -> IO () drawTurtle c clr sh s d lw (px, py) org = do let sp = map (((+ px) *** (+ py)) . rotatePoint . ((* s) *** (* s))) sh diff --git a/src/Graphics/X11/TurtleShape.hs b/src/Graphics/X11/TurtleShape.hs --- a/src/Graphics/X11/TurtleShape.hs +++ b/src/Graphics/X11/TurtleShape.hs @@ -1,45 +1,14 @@ -module Graphics.X11.TurtleShape( - lookupShape, - classic - ) where +module Graphics.X11.TurtleShape(lookupShape) where -import Control.Arrow(second) -import Data.Maybe(fromMaybe) +import Control.Arrow(second, (&&&)) lookupShape :: String -> [(Double, Double)] -lookupShape sn = fromMaybe (error errMsg) $ lookup sn shapeList - where errMsg = "There is no shape named " ++ sn - -shapeList :: [(String, [(Double, Double)])] -shapeList = [ - ("classic", classic), - ("turtle", turtle) +lookupShape "classic" = unfold [(- 10, 0), (- 16, 6), (0, 0)] +lookupShape "turtle" = unfold [ + (- 10, 0), (- 8, 3), (- 10, 5), (- 7, 9), (- 5, 6), (0, 8), (4, 7), + (6, 10), (8, 7), (7, 5), (10, 2), (13, 3), (16, 0) ] - -classic :: [(Double, Double)] -classic = clssc ++ reverse (map (second negate) clssc) - where - clssc = [ - (- 10, 0), - (- 16, 6), - (0, 0) - ] +lookupShape name = error $ "There is no shape named " ++ name -turtle :: [(Double, Double)] -turtle = ttl ++ reverse (map (second negate) ttl) - where - ttl = [ - (- 10, 0), - (- 8, - 3), - (- 10, - 5), - (- 7, - 9), - (- 5, - 6), - (0, - 8), - (4, - 7), - (6, - 10), - (8, - 7), - (7, - 5), - (10, - 2), - (13, - 3), - (16, 0) - ] +unfold :: [(Double, Double)] -> [(Double, Double)] +unfold = uncurry (++) . (id &&& (reverse . map (second negate))) diff --git a/src/Graphics/X11/TurtleState.hs b/src/Graphics/X11/TurtleState.hs --- a/src/Graphics/X11/TurtleState.hs +++ b/src/Graphics/X11/TurtleState.hs @@ -9,36 +9,36 @@ type Color = Word32 data TurtleState = TurtleState { - shape :: [(Double, Double)], - size :: Double, position :: (Double, Double), direction :: Double, + degrees :: Double, pendown :: Bool, - drawed :: [(Color, (Double, Double), (Double, Double))], - line :: Bool, + pensize :: Double, + pencolor :: Color, + shape :: [(Double, Double)], + shapesize :: Double, + visible :: Bool, + clear :: Bool, undo :: Bool, + line :: Bool, undonum :: Int, - clear :: Bool, - visible :: Bool, - pencolor :: Color, - pensize :: Int, - degrees :: Double + drawed :: [(Color, Double, (Double, Double), (Double, Double))] } deriving Show initialTurtleState :: [(Double, Double)] -> TurtleState initialTurtleState sh = TurtleState { - shape = sh, - size = 1, position = (0, 0), direction = 0, + degrees = 360, pendown = True, - drawed = [], - line = False, + pensize = 0, + pencolor = 0x000000, + shape = sh, + shapesize = 1, + visible = True, + clear = False, undo = False, + line = False, undonum = 1, - clear = False, - visible = True, - pencolor = 0x000000, - pensize = 0, - degrees = 360 + drawed = [] } diff --git a/src/Graphics/X11/WindowLayers.hs b/src/Graphics/X11/WindowLayers.hs --- a/src/Graphics/X11/WindowLayers.hs +++ b/src/Graphics/X11/WindowLayers.hs @@ -7,7 +7,7 @@ closeField, waitField, fieldColor, - layerSize, + fieldSize, addLayer, addCharacter, @@ -221,9 +221,6 @@ addThread :: Field -> ThreadId -> IO () addThread f tid = modifyIORef (fRunning f) (tid :) -layerSize :: Layer -> IO (Double, Double) -layerSize = fieldSize . layerField - flushLayer :: Layer -> IO () flushLayer = flushWindow . layerField @@ -245,19 +242,24 @@ cl <- readIORef $ fClosed f if cl then return () else act >> return () -drawLineNotFlush :: Layer -> Int -> Pixel -> Double -> Double -> Double -> Double -> IO () -drawLineNotFlush l@Layer{layerField = f} lw clr x1 y1 x2 y2 = runIfOpened f $ do +drawLineNotFlush :: + Layer -> Double -> Pixel -> Double -> Double -> Double -> Double -> IO () +drawLineNotFlush l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do drawLineBuf f lw clr fBG x1 y1 x2 y2 addLayerAction l $ whether (drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2) (drawLineBuf f lw clr fBG x1 y1 x2 y2) + where + lw = round lw_ -drawLine :: Layer -> Int -> Pixel -> Double -> Double -> Double -> Double -> IO () -drawLine l@Layer{layerField = f} lw clr x1 y1 x2 y2 = runIfOpened f $ do +drawLine :: Layer -> Double -> Pixel -> Double -> Double -> Double -> Double -> IO () +drawLine l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do drawLineBuf f lw clr fBG x1 y1 x2 y2 >> redrawCharacters f addLayerAction l $ whether (drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2) (drawLineBuf f lw clr fBG x1 y1 x2 y2) + where + lw = round lw_ clearCharacter :: Character -> IO () clearCharacter c = runIfOpened (characterField c) $ @@ -269,12 +271,14 @@ setForeground (fDisplay f) (fGC f) clr fillPolygonBuf (characterField c) sh -drawCharacterAndLine :: Character -> Pixel -> [(Double, Double)] -> Int -> +drawCharacterAndLine :: Character -> Pixel -> [(Double, Double)] -> Double -> Double -> Double -> Double -> Double -> IO () -drawCharacterAndLine c@Character{characterField = f} clr ps lw x1 y1 x2 y2 = do +drawCharacterAndLine c@Character{characterField = f} clr ps lw_ x1 y1 x2 y2 = do runIfOpened f $ setCharacter c $ do setForeground (fDisplay f) (fGC f) clr fillPolygonBuf f ps >> drawLineBuf f lw clr fBuf x1 y1 x2 y2 + where + lw = round lw_ undoLayer :: Layer -> IO Bool undoLayer Layer{layerField = f, layerId = lid} = do diff --git a/xturtle.cabal b/xturtle.cabal --- a/xturtle.cabal +++ b/xturtle.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.6 name: xturtle -version: 0.0.11 +version: 0.0.12 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo