Permalink
Browse files

files

  • Loading branch information...
1 parent 4e8bc14 commit e2ad4a3c8a1f71e17a4f92d21b641b1b3fd8f695 paolino committed Oct 24, 2011
Showing with 255 additions and 0 deletions.
  1. +45 −0 Data/Tree/Missing.hs
  2. +30 −0 LICENSE
  3. +21 −0 Marionetta.cabal
  4. +61 −0 Marionetta.hs
  5. +75 −0 Model.hs
  6. +21 −0 Render/Gloss.hs
  7. +2 −0 Setup.hs
View
@@ -0,0 +1,45 @@
+-- | Some useful functions to work with Data.Tree.Tree
+module Data.Tree.Missing (TreePath, recurseTreeAccum, replaceTreeNode, zipTreeWith, modifyNode) where
+
+import Data.List (splitAt)
+import Data.Tree
+import Control.Monad.State
+import Control.Applicative
+import Data.Traversable
+import Data.Foldable
+import Control.Arrow
+------------------------------------------------------------
+
+replaceNodeList :: Int -> [a] -> (a,a -> [a])
+replaceNodeList n xs = case splitAt n xs of
+ (_,[]) -> error "path to a non-existent node"
+ (us,x:vs) -> (x,\x -> us ++ [x] ++ vs)
+
+type TreePath = [Int]
+
+replaceTreeNode :: (Tree a -> Tree a) -> TreePath -> Tree a -> Tree a
+replaceTreeNode f ns x = replaceNode' ns x where
+ replaceNode' [] x = f x
+ replaceNode' (n:ns) (Node a ts) = Node a . g $ replaceNode' ns t
+ where (t,g) = replaceNodeList n ts
+
+recurseTreeAccum :: b -> (b -> a -> (b,c)) -> Tree a -> Tree c
+recurseTreeAccum x f n = recurse' x n where
+ recurse' x (Node y ns) = let
+ (x',z) = f x y
+ ns' = map (recurse' x') ns
+ in Node z ns'
+
+modifyNode :: (a -> a) -> Tree a -> Tree a
+modifyNode f (Node x ns) = Node (f x) ns
+
+zipTreeWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c
+zipTreeWith f t1 t2 = evalState (traverse g t1) $ toList t2
+ where
+ g x = do
+ ys <- get
+ when (null ys) $ error "zipping on trees with different shape"
+ put $ tail ys
+ return $ f x (head ys)
+
+
View
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2011, Paolo Veronelli
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Paolo Veronelli nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
@@ -0,0 +1,21 @@
+-- Initial Marionetta.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: Marionetta
+version: 0.1
+synopsis: a framework to simulate marionetta movements
+-- description:
+homepage: https://github.com/paolino/marionetta
+license: BSD3
+license-file: LICENSE
+author: Paolo Veronelli
+maintainer: paolo.veronelli@gmail.com
+-- copyright:
+category: Data
+build-type: Simple
+cabal-version: >=1.8
+
+executable Marionetta
+ -- main-is:
+ -- other-modules:
+ -- build-depends:
View
@@ -0,0 +1,61 @@
+import Graphics.Gloss
+import Data.Tree (Tree (Node))
+import Model
+import Render.Gloss
+
+-------------------------- esempio --------------------------------
+
+stecco l u (Semiretta (Punto (x,y)) al)
+ = Translate x y
+ . Rotate (270-al)
+ . Translate 0 (-l)
+ . Scale (1/u) 1 $ Color (makeColor (abs (al/360)) 0 0 1) $ ThickCircle l (l/3)
+
+simmetrico (Semiretta (Punto (x,y)) al,pc) = (Semiretta (Punto (-x,y)) (180-al),pc)
+
+pezzo x y angolo lun lente = (Semiretta (Punto (x,y)) angolo, stecco lun lente)
+
+testa = pezzo 0 60 90 16 1
+corpo = pezzo 0 50 270 40 2
+bracciodx = pezzo 15 45 300 25 3.5
+avambracciodx = pezzo 45 (-5) (-35) 20 3.5
+cosciadx = pezzo 10 (-30) 300 30 3
+gambadx = pezzo 40 (-85) 270 20 3
+
+
+
+marionetta :: Tree (Semiretta, Semiretta -> Picture)
+marionetta = Node corpo
+ [ Node testa []
+ , Node bracciodx [Node avambracciodx []]
+ , Node (simmetrico bracciodx) [Node (simmetrico avambracciodx) []]
+ , Node cosciadx [Node gambadx []]
+ , Node (simmetrico cosciadx) [Node (simmetrico gambadx) []]
+ ]
+semirette = fmap fst marionetta
+pezzi = fmap snd marionetta
+
+m1 = configura (100) [1,0]. configura (-100) [2,0]. configura (120) [1]. configura (-120) [2] $ semirette
+m2 = configura (-60) [3] m1
+
+m3 = configura (-100) [1]. configura (-175) [1,0] $m2
+m3'5 = configura (-30) [] m3
+m3'7 = configura (60) [] m3'5
+m4 = configura (-45) [1] m3'7
+
+animazione :: [(Int,Tree Semiretta)]
+animazione =
+ [ (0,semirette)
+ , (50,m1)
+ , (50,m2)
+ , (50,m3)
+ , (50,m3'5)
+ , (50,m3'7)
+ , (50,m4)
+ , (50,semirette)
+ ]
+
+tempo = 5
+fluido = 8
+main = animateInWindow "marionetta" (300,300) (0,0) white $ renderFilm pezzi (film 5 animazione) 3
+
View
@@ -0,0 +1,75 @@
+module Model (Punto (..), Semiretta (..), Angolo , TreePath, Tree, Accelerazione, configura, film) where
+
+import Data.Tree (Tree)
+import Data.Tree.Missing (replaceTreeNode, zipTreeWith, recurseTreeAccum, TreePath, modifyNode)
+import Control.Applicative ((<$>))
+import Data.Foldable (toList)
+
+
+-- | un punto nel piano 2d ascissa e ordinata
+newtype Punto = Punto (Float,Float) deriving (Eq,Show, Read)
+
+-- | un angolo
+type Angolo = Float
+
+instance Num Punto where
+ (+) (Punto (x,y)) (Punto (x1,y1)) = Punto (x+x1,y+y1)
+ negate (Punto (x,y)) = Punto (negate x,negate y)
+ (*) = error "Punto Num method undefined used"
+ abs = error "Punto Num method undefined used"
+ signum = error "Punto Num method undefined used"
+ fromInteger = error "Punto Num method undefined used"
+
+-- Calcola le coordinate del punto ruotato di un angolo rispetto ad un punto data
+ruota :: Punto -> Angolo -> Punto -> Punto
+ruota q x p = let
+ Punto (a,o) = p - q
+ z = x*pi/180 + atan2 o a
+ r = sqrt (a ^ 2 + o ^ 2)
+ in q + Punto (r * cos z, r * sin z)
+
+-- | Astrazione minima per un elemento solido in 2 dimensioni
+data Semiretta = Semiretta Punto Angolo deriving (Show,Read)
+
+type Tempo = Float
+
+type Spiazzamento = Punto -> Punto
+
+data Movimento = Movimento Spiazzamento Spiazzamento
+
+movimento = movimento' (Movimento id id) where
+ movimento' :: Movimento -> a -> Tree (Semiretta, a -> Angolo) -> Tree Semiretta
+ movimento' m w tr = recurseTreeAccum m f tr where
+ f (Movimento sposta gira) (Semiretta p y, a) = (Movimento sposta' (ruota p (a' - y)), Semiretta (sposta' p) a')
+ where sposta' = sposta . (+ (p' - p))
+ p' = gira p
+ a' = a w
+
+regolaAngolo :: Angolo -> Tree Semiretta -> Tree Semiretta
+regolaAngolo alpha = movimento () . modifyNode (\(Semiretta p y,_) -> (Semiretta p y, \() -> y + alpha)) . fmap (\s@(Semiretta p y) -> (s,const y))
+
+-- | imposta un angolo di una specifica semiretta in un grafo di semirette
+configura :: Angolo -- ^ valore assoluto dell'angolo in gradi
+ -> TreePath -- ^ percorso per la semiretta nel grafo , contando le dipendenze da sinistra
+ -> Tree Semiretta -- ^ grafo di semirette da correggere
+ -> Tree Semiretta -- ^ grafo corretto
+configura alpha tp tr = replaceTreeNode (regolaAngolo alpha) tp tr
+
+interpola :: Tree Semiretta -> Tree Semiretta -> Tree(Semiretta, Tempo -> Angolo)
+interpola t1 t2 = zipTreeWith f t1 t2 where
+ f (Semiretta p x) (Semiretta _ y) = (Semiretta p x , \t -> x + t*(y - x))
+
+sigmoide :: Float -> Float
+sigmoide t = 1/ (1 + exp (-t))
+
+-- | controlla lo strappo dei movimenti (valori > 0)
+type Accelerazione = Float
+
+-- | costruisce una sequenza di grafi che interpolano i grafi dati, assegnando il numero di passi indicato per ogni passaggio
+film :: Accelerazione -- ^ strappo dei movimenti
+ -> [(Int,Tree Semiretta)] -- ^ sequenza di configurazioni con i passi necessari a raggiungerla dalla precedente
+ -> [Tree Semiretta] -- ^ sequenza di grafi
+film l xs = do
+ ((_,x),(n,y)) <- zip xs (tail xs)
+ flip movimento (interpola x y) . sigmoide <$> take n [-l/2,(-l/2) + l/fromIntegral n..]
+
View
@@ -0,0 +1,21 @@
+module Render.Gloss where
+
+import Graphics.Gloss
+import Data.Tree (Tree (Node))
+import Data.Tree.Missing (zipTreeWith)
+import Data.Foldable (toList)
+import Model
+
+type Tempo = Float
+
+renderSemiretta :: Tree (Semiretta -> Picture) -> Tree Semiretta -> Picture
+renderSemiretta tsp ts = Pictures . toList $ zipTreeWith (flip ($)) ts tsp
+
+renderFilm :: Tree (Semiretta -> Picture) -> [Tree Semiretta] -> Tempo -> Tempo -> Picture
+renderFilm tp ts tmax = let
+ l = length ts
+ dt = tmax / (fromIntegral l)
+ tsr = map (renderSemiretta tp) ts
+ in \t -> tsr !! (floor (t/dt) `mod` l)
+
+
View
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

0 comments on commit e2ad4a3

Please sign in to comment.