Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

add Data.Zip, defined some rendering

  • Loading branch information...
commit bf83625ae0ddc9a57337ea14102b544294d29c5c 1 parent 8cab35b
Paolo Veronelli authored November 09, 2011
16  Data/Tree/Missing.hs
@@ -2,7 +2,7 @@
2 2
 
3 3
 -- | Some useful functions to work with Data.Tree.Tree
4 4
 module Data.Tree.Missing  where
5  
-import Prelude hiding (mapM)
  5
+import Prelude hiding (mapM, zipWith)
6 6
 import Data.List (splitAt,inits,tails)
7 7
 import Data.Tree
8 8
 import Control.Monad hiding (mapM)
@@ -13,19 +13,14 @@ import Data.Foldable (toList)
13 13
 import Data.Traversable (mapAccumL, mapM)
14 14
 import Control.Monad.State.Lazy (evalState)
15 15
 import Control.Monad.State.Class (MonadState(..))
  16
+import Data.Zip
16 17
 ------------------------------------------------------------
17 18
 
18 19
 
  20
+instance Zip Tree where
  21
+    zipWith f (Node x xs) (Node y ys) = Node (f x y) $ zipWith (zipWith f) xs ys
19 22
 
20  
-zipTreeWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c
21  
-zipTreeWith f (Node x xs) (Node y ys) = Node (f x y) $ zipWith (zipTreeWith f) xs ys
22 23
 
23  
-type Ispettore b = Tree b -> ((b -> b) -> Tree b, [b])
24  
-
25  
-ispettore  :: (a -> Bool) -> Tree a  -> Ispettore b
26  
-ispettore t tr tr' = (flip  (fmap . ch)  &&&  map snd . filter (t . fst) . toList) $ zipTreeWith (,) tr tr' where
27  
-    ch f (x,y)    | t x  = f y
28  
-                  | otherwise = y
29 24
 
30 25
 recurseTreeAccum :: b -> (b -> a -> (b,c)) -> Tree a -> Tree c
31 26
 recurseTreeAccum x f n = recurse' x n where
@@ -43,7 +38,7 @@ labella xs = snd . mapAccumL (\(x:xs) _ -> (xs,x)) xs
43 38
 type Ricentratore b =  b -> (b -> b -> b) -> Tree b -> Tree b
44 39
 
45 40
 ricentratore :: Eq a => a -> Tree a -> Ricentratore b
46  
-ricentratore y tr x0 k  = fmap snd . catch .  move (const id) . zipTreeWith (,) tr  where
  41
+ricentratore y tr x0 k  = fmap snd . catch .  move (const id) . zipWith (,) tr  where
47 42
         catch = maybe (error "missing element in ricentratore") id
48 43
 	move c n@(Node (x,x2) ys)
49 44
 		| x == y = Just . Node (x, k x0 x2) $ c x2 ys
@@ -52,4 +47,3 @@ ricentratore y tr x0 k  = fmap snd . catch .  move (const id) . zipTreeWith (,)
52 47
 			yss = zipWith (++) (inits ys) . tail . tails $ ys
53 48
 			mkc ys x' ys' = Node (x, k x' x2) (c x2 ys) : ys'
54 49
 
55  
-
47  Interfaccia.hs
@@ -7,36 +7,55 @@ module Interfaccia where
7 7
 
8 8
 
9 9
 import Linguaggio
10  
-       (deserializza, Sequenza(..), renderFigura, Rendering,
11  
-        Serializzazione(..))
12  
-import Data.Tree.Missing (Ispettore)
  10
+       ( Passo(..), deserializza, Sequenza(..) , Serializzazione(..))
13 11
 import Graphics.Gloss
14  
-       (line, displayInWindow, Picture, white, gameInWindow)
15  
-import Model (Relativo, Pezzo(..))
  12
+       (greyN, color, green, line, displayInWindow, Picture, white,
  13
+        gameInWindow)
  14
+import Model (Relativo, Pezzo(..), Figura, renderFigura, Rendering)
16 15
 import Graphics.Gloss.Interface.Game (Event)
17 16
 import Graphics.Gloss.Data.Picture (Picture(..))
18 17
 import Debug.Trace
  18
+import Data.Zip (Selector)
  19
+import Data.Tree (Tree)
  20
+import Data.List.Zipper (valore, elementi, Zipper(..))
  21
+
  22
+
  23
+data IFigura = IFigura
  24
+    {   ifigura :: Figura
  25
+    ,   irotazione :: Selector Tree (Pezzo Relativo)
  26
+    ,   ipov :: Figura -> Figura
  27
+    }
  28
+
  29
+type Cardini = Zipper IFigura
19 30
 
20 31
 
21 32
 data World = World
22  
-    {   persistente :: Serializzazione
23  
-    ,   volatile :: forall b . Maybe (Ispettore b)
24  
-    ,   rendereringWorld :: Rendering Picture
  33
+    {   cardini :: Cardini
  34
+    ,   renderering :: Rendering Picture
25 35
     }
26 36
 
  37
+-----------------------------   rendering ---------------------------------------------
  38
+renderIFigura re = Pictures . renderFigura re . ifigura
  39
+croce = Color green $ Pictures [line [(-200,0),(200,0)], line [(0,200),(0,-200)]]
27 40
 renderWorld :: World -> Picture
28  
-renderWorld (World se Nothing re ) = let
29  
-    ps = concatMap (renderFigura re . partenza) ss
30  
-    ss = deserializza se
31  
-    in Pictures ([line [(-100,0),(100,0)], line [(0,100),(0,-100)]] ++ ps)
  41
+renderWorld (World ca re ) = let
  42
+    ps =  Pictures . map (renderIFigura re) $ elementi  ca
  43
+    actual = (renderIFigura re) $ valore ca
  44
+    in Pictures [croce,color (greyN 0.5) ps, color (greyN 0.1) actual]
  45
+
  46
+
  47
+
  48
+-----------------------------  input ---------------------------------------------------
32 49
 
33 50
 changeWorld :: Event -> World -> World
34 51
 changeWorld = const id
35 52
 
  53
+
  54
+----------------------------- time -----------------------------------------------------
36 55
 stepWorld :: Float -> World -> World
37 56
 stepWorld = const id
38 57
 
39 58
 
40 59
 run :: World -> IO ()
41  
---run world = gameInWindow "marionetta" (300,300) (0,0) white 100 world renderWorld changeWorld stepWorld
42  
-run world = displayInWindow "marionetta" (300,300) (0,0) white $ renderWorld world
  60
+run world = gameInWindow "marionetta" (600,600) (0,0) white 100 world renderWorld changeWorld stepWorld
  61
+
23  Linguaggio.hs
@@ -16,25 +16,27 @@
16 16
 
17 17
 module Linguaggio  where
18 18
 
  19
+import Prelude hiding (zipWith)
19 20
 import Data.Tree (Tree)
20 21
 import Model
21 22
        (Angolo, assolutizza, relativizza, interpolazione, Assoluto,
22 23
         Punto(..), Pezzo(..), Pezzo, Relativo, Tempo(..), (.-.), (.+.),
23  
-        (./.), Normalizzato)
  24
+        (./.), Normalizzato,renderFigura, Renderer, Rendering, Figura)
24 25
 import Data.List (mapAccumL)
25 26
 import Control.Arrow (Arrow(..))
26 27
 import Data.Maybe (catMaybes, fromJust, isJust)
27 28
 import Control.Applicative ((<$>), liftA2)
28 29
 import Control.Monad (liftM2)
29 30
 import Data.Tree.Missing
30  
-       (zipTreeWith, ricentratore, Ricentratore, labella)
  31
+       ( ricentratore, Ricentratore, labella)
31 32
 import Data.Foldable (toList)
32  
-
  33
+import Data.Zip
33 34
 import Debug.Trace
34 35
 
35 36
 
36 37
 
37  
-type Figura = Tree (Pezzo Relativo)
  38
+
  39
+
38 40
 type Nome = Int
39 41
 
40 42
 data Passo     = Passo
@@ -66,18 +68,9 @@ deserializza s@(Serializzazione f0 ps) =  ss where
66 68
                     r' = relativizza . r (Pezzo c undefined undefined) gp . assolutizza
67 69
     gp :: Pezzo Assoluto -> Pezzo Assoluto -> Pezzo Assoluto
68 70
     gp (Pezzo c _ _) (Pezzo _ o alpha) = Pezzo c o alpha
69  
-
70  
-
71  
-type Renderer b = Pezzo Assoluto -> b
72  
-
73  
-type Rendering b = Tree (Renderer b)
74  
-
75  
-renderFigura :: Rendering b -> Figura -> [b]
76  
-renderFigura r x = trace (show x) . toList . zipTreeWith ($) r . assolutizza $ x
77  
-
78  
-
79  
-
80 71
 renderSequenza :: Rendering b -> Sequenza (Renderer b) -> Tempo Assoluto -> Tempo Assoluto -> [b]
81 72
 renderSequenza re (Sequenza f0 f1 r dt) t0 t = renderFigura (r re) . interpolazione f0 f1 $ (t .-. t0) ./. dt
82 73
 
83 74
 
  75
+
  76
+
24  Marionetta.cabal
@@ -6,15 +6,25 @@ license: BSD3
6 6
 license-file: LICENSE
7 7
 copyright:
8 8
 maintainer: paolo.veronelli@gmail.com
9  
-build-depends: base -any, containers -any, gloss -any, mtl -any
  9
+build-depends: base -any, base -any, base -any, base -any,
  10
+               base -any, base -any, base -any, base -any, base -any, base -any,
  11
+               base -any, base -any, base -any, base -any, base -any, base -any,
  12
+               containers -any, containers -any, containers -any, containers -any,
  13
+               containers -any, containers -any, containers -any, containers -any,
  14
+               containers -any, containers -any, containers -any, containers -any,
  15
+               containers -any, containers -any, containers -any, containers -any,
  16
+               gloss -any, gloss -any, gloss -any, gloss -any, gloss -any,
  17
+               gloss -any, gloss -any, gloss -any, gloss -any, gloss -any,
  18
+               gloss -any, gloss -any, gloss -any, gloss -any, gloss -any,
  19
+               gloss -any, mtl -any, mtl -any, mtl -any, mtl -any, mtl -any,
  20
+               mtl -any, mtl -any, mtl -any, mtl -any, mtl -any, mtl -any,
  21
+               mtl -any, mtl -any, mtl -any, mtl -any, mtl -any
10 22
 stability:
11 23
 homepage: https://github.com/paolino/marionetta
12 24
 package-url:
13 25
 bug-reports:
14 26
 synopsis: a framework to simulate marionetta movements
15 27
 description: .
16  
-             .
17  
-             .
18 28
 category: Data
19 29
 author: Paolo Veronelli
20 30
 tested-with:
@@ -22,7 +32,8 @@ data-files:
22 32
 data-dir: ""
23 33
 extra-source-files:
24 34
 extra-tmp-files:
25  
-exposed-modules: Data.Tree.Missing Interfaccia Linguaggio Model
  35
+exposed-modules: Data.List.Zipper Data.Tree.Missing Data.Zip
  36
+                 Interfaccia Linguaggio Model
26 37
 exposed: True
27 38
 buildable: True
28 39
 build-tools:
@@ -50,7 +61,7 @@ ghc-options:
50 61
 hugs-options:
51 62
 nhc98-options:
52 63
 jhc-options:
53  
-
  64
+ 
54 65
 executable: marionetta
55 66
 main-is: Marionetta.hs
56 67
 buildable: True
@@ -78,5 +89,4 @@ ghc-shared-options:
78 89
 ghc-options:
79 90
 hugs-options:
80 91
 nhc98-options:
81  
-jhc-options:
82  
-
  92
+jhc-options:
58  Marionetta.hs
@@ -3,10 +3,11 @@ import Debug.Trace
3 3
 import Graphics.Gloss
4 4
 import Data.Tree (Tree (Node))
5 5
 import Data.Tree.Missing (ricentratore, labella)
6  
-import Model
  6
+import Model (Figura, Rendering, Renderer,renderFigura, Punto (..), Pezzo (..), assolutizza, relativizza, Assoluto, vicino )
7 7
 import Interfaccia
8  
-import Linguaggio
9  
-       (Serializzazione(..), Figura, Rendering, Renderer, Passo (..), renderFigura)
  8
+import Control.Arrow
  9
+import Linguaggio (Serializzazione(..) , Passo (..))
  10
+import Data.List.Zipper
10 11
 
11 12
 
12 13
 -------------------------- esempio --------------------------------
@@ -17,6 +18,7 @@ elemento l u = Scale (1/u) 1 $  Circle l
17 18
 -- simmetrico :: Pezzo Relativo -> Pezzo Relativo
18 19
 simmetrico (Pezzo (Punto (x,y)) (Punto (xo,yo)) alpha)  =  Pezzo (Punto (-x,y)) (Punto (-xo,yo)) (pi - alpha)
19 20
 
  21
+
20 22
 pezzo :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> (Pezzo Assoluto, Picture)
21 23
 pezzo x y xo yo beta l u  = (Pezzo (Punto (x,y)) (Punto (xo, yo)) alpha ,elemento l u ) where
22 24
                 alpha = beta * pi / 180
@@ -28,24 +30,23 @@ renderer pc (Pezzo (Punto (cx,cy)) (Punto (ox,oy)) alpha ) = Pictures
28 30
     ]
29 31
 
30 32
 
31  
-testa   = pezzo 0 60 0 78 0 18 1.5
  33
+testa   = pezzo 0 60 0 80 0 20 1.5
32 34
 corpo   = pezzo 0 0 0 20 0 40 2
33  
-{-bracciodx     = pezzo 15 (-5) 300 25 3.5
34  
-avambracciodx     = pezzo 30 (-50) 325 20 3.5
35  
-cosciadx     = pezzo 10 (-80) 300 30 3
36  
-gambadx     = pezzo 30 (-55) 270 27 3
  35
+bracciodx     = pezzo 13 50 13 25 0 25 3.5
  36
+
  37
+avambracciodx     = pezzo 13 0 13 (-20) 0 20 3.5
37 38
 
38  
-marionetta' :: Tree Figura
39  
-marionetta' = Node corpo
  39
+cosciadx     = pezzo 10 (-10) 10 (-40) 0 30 3
  40
+gambadx     = pezzo 10 (-70) 10 (-97) 0 27 3
  41
+
  42
+-- marionetta :: Figura
  43
+marionetta = Node corpo
40 44
     [    Node testa []
41 45
     ,    Node bracciodx [Node avambracciodx []]
42  
-    ,    Node (simmetrico bracciodx) [Node (simmetrico avambracciodx) []]
  46
+    ,    Node (first simmetrico bracciodx) [Node (first simmetrico avambracciodx) []]
43 47
     ,    Node cosciadx [Node gambadx []]
44  
-    ,    Node (simmetrico cosciadx) [Node (simmetrico gambadx) []]
  48
+    ,    Node (first simmetrico cosciadx) [Node (first simmetrico gambadx) []]
45 49
     ]
46  
--}
47  
-
48  
-marionetta = Node corpo [Node testa []]
49 50
 
50 51
 rendering :: Rendering Picture
51 52
 rendering = fmap (renderer . snd) $ marionetta
@@ -53,32 +54,9 @@ rendering = fmap (renderer . snd) $ marionetta
53 54
 figura :: Figura
54 55
 figura = relativizza $ fmap fst marionetta
55 56
 
56  
-rice  n p  = relativizza
57  
-        . ricentratore n (labella [0..] figura) (Pezzo (Punto p) undefined undefined) gp
58  
-        . assolutizza $ figura where
59  
-    gp :: Pezzo Assoluto -> Pezzo Assoluto -> Pezzo Assoluto
60  
-    gp (Pezzo c _ _) (Pezzo _ o alpha) = Pezzo c o alpha
61  
-
62  
-pictures' = concatMap (renderFigura rendering)
63  
-    [figura
64  
-    , rice 0 (10,5)
65  
-    , ruotaScelto (vicino (Punto (0,0)) (assolutizza figura)) (pi/16) $ rice 0 (10,5)
66  
---    , relativizza . assolutizza $ figura
67  
-    ]
68 57
 world :: World
69  
-world = World (Serializzazione figura
70  
-        [   Passo figura (Tempo  0) 0 (Punto (0,0))
71  
-        ,   Passo (ruotaScelto (vicino (Punto (0,0)) (assolutizza figura)) (pi/16) figura) (Tempo 0) 0 (Punto (30,30))
72  
-        ,   Passo figura (Tempo  0) 0 (Punto (0,0))
73  
-        ]
74  
-    )
75  
-    Nothing
76  
-    rendering
77  
-
78  
-
  58
+world = World  (mkZipper $ IFigura figura (vicino (Punto (0,0)) (assolutizza figura)) id) rendering
79 59
 
80  
--- main = animateInWindow "marionetta" (300,300) (0,0) white $ renderFilm pezzi (film 5 animazione) 3
81  
--- main = run world
82  
-main = displayInWindow "marionetta" (300,300) (0,0) white $ Pictures pictures'
  60
+main = run world
83 61
 
84 62
 
20  Model.hs
@@ -5,8 +5,9 @@
5 5
 
6 6
 module Model where -- (Punto (..), Semiretta (..), Angolo , TreePath, Tree, Accelerazione, configura, film) where
7 7
 
  8
+import Prelude hiding (zipWith)
8 9
 import Data.Tree (Tree(..))
9  
-import Data.Tree.Missing ( zipTreeWith, recurseTreeAccum,  ispettore , Ispettore)
  10
+import Data.Tree.Missing ( recurseTreeAccum)
10 11
 import Control.Applicative ((<$>))
11 12
 import Control.Monad (ap)
12 13
 import Data.Foldable (minimumBy, toList)
@@ -14,6 +15,7 @@ import Data.List.Zipper
14 15
 import Data.Ord (comparing)
15 16
 import Control.Arrow (Arrow(..))
16 17
 import Debug.Trace
  18
+import Data.Zip
17 19
 
18 20
 -- | un punto nel piano 2d ascissa e ordinata o anche un vettore
19 21
 newtype Punto = Punto (Float,Float) deriving (Eq,Show, Read)
@@ -64,13 +66,13 @@ relativizza = recurseTreeAccum (Punto (0,0)) f    where
64 66
     f q (Pezzo c o alpha) = (c, Pezzo (c - q) (o - c) alpha)
65 67
 
66 68
 -- prepara le ispezioni del pezzo nell'albero più vicino al punto dato
67  
-vicino :: Punto -> Tree (Pezzo Assoluto) -> Ispettore b
68  
-vicino x tr = ispettore ch tr where
  69
+vicino :: Punto -> Tree (Pezzo Assoluto) -> Selector Tree b
  70
+vicino x tr = mkSelector ch tr where
69 71
     x' = minimumBy (comparing $ modulus .  subtract x) . toList . fmap originePezzo $ tr
70 72
     ch (Pezzo _ o _) = o == x'
71 73
 
72 74
 -- ruota il solo pezzo specificato dall'ispettore
73  
-ruotaScelto :: Ispettore (Angolo, Pezzo Relativo) -> Angolo -> Tree (Pezzo Relativo) -> Tree (Pezzo Relativo)
  75
+ruotaScelto :: Selector Tree (Angolo, Pezzo Relativo) -> Angolo -> Tree (Pezzo Relativo) -> Tree (Pezzo Relativo)
74 76
 ruotaScelto m alpha tr = aggiorna . (\t -> fst (m  t) (\(_,p) -> (alpha,p))) . fmap ((,) 0) $ tr
75 77
 
76 78
 -- ruota tutti i pezzi dell'angolo assegnato
@@ -98,8 +100,16 @@ interpolazione      :: Tree (Pezzo Relativo)
98 100
                     -> Tree (Pezzo Relativo)
99 101
                     -> Tempo Normalizzato
100 102
                     -> Tree (Pezzo Relativo)
101  
-interpolazione t1 t2 t = aggiorna $ zipTreeWith variazioneAngolo  t1 t2 where
  103
+interpolazione t1 t2 t = aggiorna $ zipWith variazioneAngolo  t1 t2 where
102 104
     variazioneAngolo p p' = ((rotazionePezzo p' - rotazionePezzo p) /  tempo t, p)
  105
+type Figura = Tree (Pezzo Relativo)
  106
+type Renderer b = Pezzo Assoluto -> b
  107
+
  108
+type Rendering b = Tree (Renderer b)
  109
+
  110
+renderFigura :: Rendering b -> Figura -> [b]
  111
+renderFigura r x =  toList . zipWith ($) r . assolutizza $ x
  112
+
103 113
 
104 114
 
105 115
 

0 notes on commit bf83625

Please sign in to comment.
Something went wrong with that request. Please try again.