Permalink
Browse files

add Data.Zip, defined some rendering

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

0 comments on commit bf83625

Please sign in to comment.