packages feed

marionetta (empty) → 0.1

raw patch · 13 files changed

+667/−0 lines, 13 filesdep +basedep +containersdep +glosssetup-changed

Dependencies added: base, containers, gloss, mtl

Files

+ Controller.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GADTs #-}++module Controller (Evento (..), catchEvento, mkWorld, World (..), Lasso (..), Verso (..)) where+++import Data.Maybe (fromMaybe)++import Data.List.Zipper (mkZipper, Zipper , inserisci, elimina, destra, sinistra, modifica)+import Data.Tree.Missing (inspectTop , forward, backward)+import Model (Figura,  Punto)+import IFigura (IFigura(IFigura), traslazione, rotazione, movimentoCentroTop, modificaSelettori, ricentra, iselectors)++data MoveEffect = Ruotando Punto | Traslando Punto | SpostandoCentro Punto | Niente++data World = World (Zipper IFigura) MoveEffect++mkWorld :: Figura -> World +mkWorld fig = World +	(mkZipper $ IFigura fig [] (forward (inspectTop fig) fig) (backward (inspectTop fig) fig))+	Niente++data Lasso = Inizio | Fine+data Verso = Destra | Sinistra++data Evento where+	Refresh ::  Evento +	Puntatore :: Punto -> Evento +	Rotazione :: Punto -> Lasso -> Evento +	Traslazione :: Punto -> Lasso -> Evento +	SpostamentoCentro :: Punto -> Lasso -> Evento +	Cancella :: Evento +	Clona :: Evento +	Fuoco :: Verso -> Evento +	Ricentra :: Punto -> Evento +	Seleziona :: Punto -> Evento +	Deseleziona :: Evento+	Silent :: Evento++catchEvento :: Evento -> World -> World+catchEvento Refresh (World z _) = World z Niente+catchEvento (Puntatore p) (World z Niente) = World z Niente+catchEvento (Puntatore p) (World z (Traslando q)) = World (modifica (traslazione q p) z) $ Traslando p +catchEvento (Puntatore p) (World z (Ruotando q)) = World (modifica (rotazione q p) z) $ Ruotando p +catchEvento (Puntatore p) (World z (SpostandoCentro q)) = World (modifica (movimentoCentroTop q p) z) $ SpostandoCentro p +catchEvento (Rotazione p Inizio) (World z _) = World z (Ruotando p)+catchEvento (Rotazione p Fine) (World z (Ruotando _)) = World z Niente+catchEvento (Rotazione p Fine) w = w+catchEvento (Traslazione p Inizio) (World z _) = World z (Traslando p)+catchEvento (Traslazione p Fine) (World z (Traslando _)) = World z Niente+catchEvento (Traslazione p Fine) w = w+catchEvento (SpostamentoCentro p Inizio) (World z _) = World z (SpostandoCentro p)+catchEvento (SpostamentoCentro p Fine) (World z (SpostandoCentro _)) = World z Niente+catchEvento (SpostamentoCentro p Fine) w = w+catchEvento Cancella (World z m) = World (fromMaybe z $ elimina z) m+catchEvento Clona (World z m) = World (inserisci id z) m+catchEvento (Fuoco Destra) (World z m) = World (destra z) m+catchEvento (Fuoco Sinistra) (World z m) = World (sinistra z) m+catchEvento (Seleziona p) (World z m) = World (modifica (modificaSelettori p) z) m+catchEvento Deseleziona (World z m) = World (modifica f z) m where+	f ifig = ifig {iselectors = []}+catchEvento (Ricentra p) (World z m)  = World (modifica (ricentra p) z) m+catchEvento Silent w = w+++++
+ Data/List/Zipper.hs view
@@ -0,0 +1,41 @@++-----------------------------------------------------------------------------+--+-- Module      :  Data.List.Zipper+-- Copyright   :  Paolo Veronelli+-- License     :  BSD3+--+-- Maintainer  :  paolo.veronelli@gmail.com+-- Stability   :  Stable+-- Portability :  Portable+--+-- | Zipper structure on list+--+-----------------------------------------------------------------------------++++module Data.List.Zipper where++data Zipper a = Zipper [a] [a]++sinistra z@(Zipper [] _) = z+sinistra (Zipper (x:xs) ys) = Zipper xs (x:ys)++destra z@(Zipper _ [x]) = z+destra (Zipper xs (y:ys)) = Zipper (y:xs) ys++mkZipper x = Zipper [] [x]+valore (Zipper _ (x:_)) = x++inserisci f (Zipper xs (y:ys)) = Zipper (y:xs) ((f y):ys)++elimina (Zipper [] [y]) = Nothing +elimina (Zipper (x:xs) [y]) = Just (Zipper xs [x])+elimina (Zipper xs (y:ys)) = Just (Zipper xs ys)++modifica f (Zipper xs (y:ys)) = Zipper xs (f y : ys)+elementi (Zipper xs ys) = xs ++ ys+++
+ Data/Tree/Missing.hs view
@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+--+-- Module      :  Data.Tree.Missing+-- Copyright   :  Paolo Veronelli+-- License     :  BSD3+--+-- Maintainer  :  paolo.veronelli@gmail.com+-- Stability   :  Unstable+-- Portability :  Portable+--+-- | Some operators for Tree structures.++-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-}++module Data.Tree.Missing (inspectTop, modifyTop, recurseTreeAccum, backward, forward, Routing, routingDumb) where++import Prelude hiding (zipWith)+import Control.Monad (msum)+import Data.List (splitAt,inits,tails)+import Data.Tree (Tree (Node))++import Data.Zip (Zip (..))++++instance Zip Tree where+    zipWith f (Node x xs) (Node y ys) =  Node (f x y) $ zipWith (zipWith f) xs ys++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'++inspectTop (Node x _) = x+modifyTop f (Node x xs) = Node (f x) xs+++dropAt n xs = let (as,_:bs) = splitAt n xs in as ++ bs+insertAt n x xs = let (as,bs) = splitAt n xs in as ++ x : bs+replaceAt n x xs = let (as,_:bs) = splitAt n xs in as ++ x:bs+++forward :: (Eq a) => a -> Tree a -> Routing b+forward y tr x0 f tr'@(Node x _) =   (,) x . fmap snd . maybe (error "missing element in ricentratore") id . move (const id) . zipWith (,) tr $ tr'+        where+            move c n@(Node (x,x2) ys)+                | x == y = Just $ Node (x,f x0 x2) $ c x2 ys+                | null ys = Nothing+                | otherwise = msum $ zipWith move (map mkc [0..]) ys+                    where  mkc n x0 ys' = (Node (x, f x0 x2) . c x2 $ dropAt n ys):ys'+++backward :: ( Eq a) => a -> Tree a -> Routing b+backward y tr x0 f =    maybe (error "missing element in ricentratore") id . move  Nothing $ tr+        where+            reverting Nothing mh (Node x (y:ys)) = maybe (x,Node x (y:ys)) (\h -> h (x,y) $ Node x ys) mh+            reverting (Just (n, (x1,Node x (y:ys)))) (Just h) (Node xy ysy) = let ys' = insertAt n (Node (f x xy) ysy) ys in h (x1,y) $ Node x ys'+            reverting (Just (n, (x1,Node x ys))) Nothing (Node xy ysy) = (x1,Node (f x0 x) $ insertAt n (Node (f x xy) ysy) ys)+            move h n@(Node x ys)+                | x == y = Just $ reverting Nothing h+                | null ys = Nothing+                | otherwise = msum $ zipWith move [Just $ \ y -> reverting (Just (n,y)) h | n <- [0..]] ys++type Routing b =  b -> (b -> b -> b) -> Tree b -> (b , Tree b)++routingDumb :: Routing b -> Tree b -> Tree b+routingDumb r = snd . r undefined (const id)++
+ Data/Zip.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+--+-- Module      :  Data.Zip+-- Copyright   :  Paolo Veronelli+-- License     :  BSD3+--+-- Maintainer  :  paolo.veronelli@gmail.com+-- Stability   :  Unstable+-- Portability :  Portable+--+-- | Zip class for structures supporting zipWith operation. +-- Selector operator to point to indexed elements in same shape structures.++-----------------------------------------------------------------------------++{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}++module Data.Zip  where+++import Prelude hiding (zipWith)++import qualified Prelude (zipWith)+import Control.Arrow ((&&&))+import Data.Foldable (Foldable, toList)+import Data.Traversable (mapAccumL, Traversable)++class Zip t where+    zipWith :: (a -> b -> c) -> t a -> t b -> t c++instance Zip [] where+    zipWith = Prelude.zipWith++type Selector t b = t b -> ((b -> b) -> t b, [b])++mkSelector  :: (Functor t, Foldable t ,Zip t) => (a -> Bool) -> t a  -> Selector  t b+mkSelector t tr tr' = (flip  (fmap . ch)  &&&  map snd . filter (t . fst) . toList) $ zipWith (,) tr tr' where+    ch f (x,y)    | t x  = f y+                  | otherwise = y++labella :: Traversable t => [a] -> t b -> t a+labella xs = snd . mapAccumL (\(x:xs) _ -> (xs,x)) xs++moveSelector :: (Functor t, Foldable t, Traversable t, Zip t)+    => t a -> (forall a . t a -> t a) -> Selector t Bool  -> Selector t b+moveSelector tr r s = mkSelector id . r $ fst (s . fmap (const False) $ tr) (const True)++filterDuplicates :: forall t a b . (Functor t, Foldable t, Traversable t, Zip t)+    => t a -> (forall b . [Selector t b])  -> [Selector t b]+filterDuplicates tr ss = let+    ss' = zip [1..] ss+    tr' = fmap (const []) tr+    tr'' = map head . filter ((==  1) . length) .  toList $ foldr (\(i,s) tr -> fst (s tr) $ (i:) ) tr' ss'++    in  map snd . filter (flip elem tr'' . fst) $ ss'+
+ Gloss.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ViewPatterns #-}+module Gloss (gloss_run, gloss_implementazione) where++import Data.Monoid (mconcat)++import Graphics.Gloss.Interface.Game +	(Picture(..), translate, rotate, color+	, yellow, white, Event (..), gameInWindow+	, scale, blue, makeColor, Key (..), MouseButton (..), SpecialKey (..), KeyState (..))++import View (RenderHelp, Colore, Render)+import Model  (Punto(Punto), Pezzo(Pezzo))+import Controller (Evento (..), Lasso (..), Verso (..))+import Run (Run, Grafici(Gr), Geometrici (Ge), Implementazione (Implementazione))++glCatch :: Event -> Evento++glCatch (EventMotion (Punto -> p)) = Puntatore p+glCatch (EventKey (Char 'r') Down _ (Punto -> p)) = Rotazione p Inizio +glCatch (EventKey (Char 'r') Up _ (Punto -> p)) = Rotazione p Fine +glCatch (EventKey (Char 't') Down _ (Punto -> p)) = Traslazione p Inizio +glCatch (EventKey (Char 't') Up _ (Punto -> p)) = Traslazione p Fine +glCatch (EventKey (Char 'x') Down _ (Punto -> p)) = SpostamentoCentro p Inizio +glCatch (EventKey (Char 'x') Up _ (Punto -> p)) = SpostamentoCentro p Fine +glCatch (EventKey (Char 'd') Down _ _ ) = Cancella+glCatch (EventKey (Char 'c') Down _ _ ) = Clona+glCatch (EventKey (MouseButton WheelUp) Up _ _) = Fuoco Destra+glCatch (EventKey (MouseButton WheelDown) Up _ _) = Fuoco Sinistra+glCatch (EventKey (Char 'g') Down _ (Punto -> p)) = Ricentra p+glCatch (EventKey (Char 's') Down _ (Punto -> p)) = Seleziona p+glCatch (EventKey (SpecialKey KeySpace) Down _ _) = Deseleziona+glCatch _ = Silent+++colore :: Colore Picture +colore (r,g,b) = Color (makeColor r g b 1) ++renderHelp :: RenderHelp Picture+renderHelp help = mconcat [Color blue . translate (-250) (250-16*i) . scale 0.09 0.14 $ Text h | (i,h) <- zip [0..] help]++elemento :: Grafici -> Picture+elemento (Gr l u) = Scale (1/u) 1 $  Circle l++renderPezzo :: Grafici -> Render Picture+renderPezzo (elemento -> pc) (Pezzo (Punto (cx,cy)) (Punto (ox,oy)) alpha ) = Pictures+    [   translate ox oy . rotate (-alpha * 180 / pi) $ pc+    ,   translate cx cy . color yellow $ Circle 3+    ]++gloss_implementazione :: Implementazione Picture Event+gloss_implementazione = Implementazione renderPezzo colore renderHelp glCatch++gloss_run :: String -> (Int,Int) -> (Int,Int) -> Run Picture Event+gloss_run s c l w rew ce = gameInWindow s c l white 0 w rew ce (const id)
+ IFigura.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ImpredicativeTypes #-}++module IFigura where++import Data.Tree (Tree)+import Data.Tree.Missing (routingDumb, forward, backward,modifyTop, Routing)+import Data.Zip (Selector, moveSelector, filterDuplicates, labella)+import Model (Figura, ruotaScelto, vicino, Punto (..), Pezzo (..), assolutizza, relativizza,rotazioneInOrigine, routingPezzi)++data IFigura = IFigura+        {   ifigura :: Figura+        ,   iselectors :: forall b. [Selector Tree b]+        ,   iforward :: forall b . Routing b+        ,   ibackward :: forall b . Routing b+        }+++ricentra :: Punto -> IFigura -> IFigura+ricentra l (IFigura ifig isels _ ibackw ) = let+            ifig' = rotazioneInOrigine . routingPezzi undefined ibackw $ assolutizza ifig+            isels' = map (moveSelector ifig $ routingDumb ibackw) isels+            ir = vicino l ifig'+            lifig = labella [0..] ifig'+            c = head $ snd (ir lifig)+            iforw =  forward c lifig+            ibackw' =  backward c lifig+            ifig'' = relativizza . rotazioneInOrigine . routingPezzi undefined iforw $ ifig'+            isels'' = map (moveSelector ifig' $ routingDumb iforw) isels'+            in  IFigura ifig'' isels'' iforw ibackw'++type Movimento a = Punto -> Punto -> a -> a+++traslazione :: Movimento IFigura+traslazione  l l' (IFigura ifig ir iforw ibackw) = let+            ifig' = modifyTop g ifig+            g (Pezzo p o alpha) = Pezzo (p + l' - l) o alpha+            in IFigura ifig' ir iforw ibackw++rotazione :: Movimento IFigura+rotazione l l' (IFigura ifig ir iforw ibackw) = let+            ifig' = foldr (uncurry ruotaScelto) ifig (zip ir $ map iralpha ir)+            iralpha ir = let+                Pezzo q _ _ = head . snd $ ir (assolutizza ifig)+                alpha = atan2 y' x' - atan2 y x+                Punto (x,y) = l - q+                Punto (x',y') = l' - q+                in alpha+            in IFigura ifig' ir iforw ibackw++movimentoCentroTop :: Movimento IFigura+movimentoCentroTop l l' (IFigura ifig ir iforw ibackw) = IFigura ifig' ir iforw ibackw +	where ifig' = relativizza . modifyTop (\(Pezzo _ o alpha) -> Pezzo l o alpha) . assolutizza $ ifig+++modificaSelettori l (IFigura ifig ir iforw ibackw) = IFigura ifig (filterDuplicates ifig (ir':ir)) iforw ibackw where+		ir' = vicino l . assolutizza $ ifig++++++++
+ LICENSE view
@@ -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.
+ Model.hs view
@@ -0,0 +1,121 @@++{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Model where -- (Punto (..), Semiretta (..), Angolo , TreePath, Tree, Accelerazione, configura, film) where++import Prelude hiding (zipWith)+import Data.Tree (Tree(..))+import Data.Tree.Missing ( recurseTreeAccum, Routing, modifyTop)+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)++-- | un angolo+type Angolo = Float++-- campo dei Punto+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 x = error $ "abs :" ++ show x ++  " Punto Num method undefined used"+	signum = error "signum : Punto Num method undefined used"+	fromInteger x = error $ "fromInteger " ++ show x ++ ": Punto Num method undefined used"+++type Ruota = Punto -> Punto++-- rotazione intorno all'origine+ruota :: Angolo -> Ruota+ruota alpha (Punto (x,y))= Punto (cos alpha * x - sin alpha * y, sin alpha * x + cos alpha * y)+++-- modulo di un vettore+modulus :: Punto -> Float+modulus (Punto (x,y)) = sqrt (x ^ 2 + y ^ 2)++data Relativo+data Assoluto++data Pezzo a = Pezzo+    {    fulcroPezzo :: Punto+    ,    originePezzo ::  Punto+    ,    rotazionePezzo :: Angolo+    } deriving (Show,Read,Eq)++++++assolutizza :: Tree (Pezzo Relativo) -> Tree (Pezzo Assoluto)+assolutizza = recurseTreeAccum (Punto (0,0)) f    where+    f q (Pezzo c o alpha) = (qc, Pezzo qc (o + qc) alpha ) where qc = q + c+++relativizza :: Tree (Pezzo Assoluto) -> Tree (Pezzo Relativo)+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) -> 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 :: 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+aggiorna :: Tree (Angolo, Pezzo Relativo) -> Tree (Pezzo Relativo)+aggiorna = recurseTreeAccum id ruotaPezzo++ruotaPezzo :: Ruota -> (Angolo, Pezzo Relativo) -> (Ruota, Pezzo Relativo)+ruotaPezzo r (alpha, Pezzo c o beta) = let r' = ruota alpha in (r', Pezzo (r c) (r' o) $ alpha + beta)++newtype Tempo a = Tempo {tempo :: Float} deriving (Eq, Show, Read)++data Normalizzato++tf :: (Float -> Float -> Float) -> Tempo a -> Tempo b -> Tempo c+tf g (Tempo x) (Tempo y) = Tempo (x `g` y)++(.+.) :: Tempo Assoluto -> Tempo Relativo -> Tempo Assoluto+(.+.) = tf (+)+(./.) :: Tempo Relativo -> Tempo Relativo -> Tempo Normalizzato+(./.) = tf (/)+(.-.) :: Tempo Assoluto -> Tempo Assoluto -> Tempo Relativo+(.-.) = tf (-)++interpolazione      :: Tree (Pezzo Relativo)+                    -> Tree (Pezzo Relativo)+                    -> Tempo Normalizzato+                    -> Tree (Pezzo Relativo)+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)+++routingPezzi :: Punto -> Routing (Pezzo Assoluto) -> Tree (Pezzo Assoluto) -> Tree (Pezzo Assoluto)+routingPezzi p r = snd . r (Pezzo p undefined undefined) (\(Pezzo c _ _) (Pezzo _ o alpha) -> Pezzo c o alpha)++rotazioneInOrigine :: Tree (Pezzo Assoluto) -> Tree (Pezzo Assoluto)+rotazioneInOrigine = modifyTop $ \(Pezzo _ o alpha) ->  Pezzo o o alpha+++++++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ View.hs view
@@ -0,0 +1,53 @@+module View (RenderHelp, Render, Colore, renderWorld) where++import Prelude hiding (zipWith)+import Data.Tree (Tree) +import Data.Foldable (toList)+import Data.Monoid (mconcat,Monoid)+++import Data.Zip (zipWith)+import Data.Tree.Missing (modifyTop, routingDumb)+import Data.List.Zipper (Zipper, elementi, valore)+import Model (assolutizza , Pezzo , Assoluto, Figura)+import IFigura (IFigura(IFigura))+++type Render b = Pezzo Assoluto -> b++renderFigura :: Monoid b => Tree (Render b) -> Figura -> b+renderFigura r x =  mconcat . toList . zipWith ($) r . assolutizza $ x++type Colore b = (Float,Float,Float) -> b -> b++-- colori vari+selezionato = (0,1,1)+top = (0,0,1)+text = (0,1,0)++renderIFigura :: Monoid b => Colore b -> Tree (Render b) -> IFigura -> b+renderIFigura co re (IFigura ifig isels iforw _ ) = renderFigura re'' ifig+    where+    re' = foldr (\ir re -> fst (ir re) $ (co selezionato .)) (routingDumb iforw re) isels+    re'' = modifyTop (co top .) re'++type RenderHelp b = [String] -> b++renderWorld :: Monoid b => Colore b -> RenderHelp b -> Tree (Render b) -> Zipper IFigura -> b+renderWorld co he re ca  = let+    ps =  mconcat . map (renderIFigura co re) $ elementi ca+    actual = renderIFigura co re . valore $ ca+    in mconcat [co text $ he help, co (0.5,0.5,0.5) ps, co (0.1,0.1,0.1) actual]++help =  [   "S: select/deselect nearest to pointer piece for rotation"+        ,   "Space: deselect all pieces"+        ,   "R: rotate selected pieces while moving the mouse"+        ,   "X: move top piece rotation while moving the mouse"+        ,   "G: change top piece as the nearest to pointer"+        ,   "T: translate marionetta while moving the mouse"+        ,   "C: clone marionetta"+        ,   "Mouse wheel: select a marionetta to edit"+        ,   "D: eliminate marionetta"+        ]++
+ gloss.patch view
@@ -0,0 +1,13 @@+--- Graphics/Gloss/Internals/Interface/Backend/GLUT.hs	2011-11-16 09:58:40.359886120 +0100++++ Graphics/Gloss/Internals/Interface/Backend/GLUT.patched.hs	2011-11-16 09:58:57.951886166 +0100+@@ -239,7 +239,9 @@+         -> IO ()+ + installMotionCallbackGLUT ref callbacks+-        = GLUT.motionCallback $= Just (callbackMotion ref callbacks)++        = do GLUT.motionCallback $= Just (callbackMotion ref callbacks)++             GLUT.passiveMotionCallback $= Just (callbackMotion ref callbacks)+++ + callbackMotion+         :: IORef GLUTState -> [Callback]
+ marionetta.cabal view
@@ -0,0 +1,61 @@+-- marionetta.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name:                marionetta++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version:             0.1++-- A short (one-line) description of the package.+Synopsis: A study of marionetta movements.++-- A longer description of the package.+Description: An opengl application to make animations with marionetta-like structures. Actually only marionetta placement is implemented. Mouse movements are now intended with at least a button pressed. Future versions of gloss may resolve the issue. A patch is distributed to change this issue in gloss package.++-- URL for the project homepage or repository.+Homepage: https://github.com/paolino/marionetta                    ++-- The license under which the package is released.+License:             BSD3++-- The file containing the license text.+License-file:        LICENSE++-- The package author(s).+Author:              Paolo Veronelli++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer:          paolo.veronelli@gmail.com++-- A copyright notice.+-- Copyright:           ++Category:            Game++Build-type:          Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files:  gloss.patch++-- Constraint on the version of Cabal needed to build this package.+Cabal-version:       >=1.2+++Executable marionetta+  -- .hs or .lhs file containing the Main module.+  Main-is: marionetta.hs             +  +  -- Packages needed in order to build this package.+  Build-depends: base >=4 && <5, mtl -any, containers -any , gloss -any+  +  -- Modules not exported by this package.+  Other-modules:  Controller Data.List.Zipper Data.Tree.Missing Data.Zip Gloss IFigura Model View+  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         +
+ marionetta.hs view
@@ -0,0 +1,27 @@+++import Data.Tree (Tree (Node))+import Control.Arrow (first)++import Run (Descrizione, run, Grafici(Gr), Geometrici(Ge))+import Gloss (gloss_run, gloss_implementazione)++testa   	= (Ge 0 60 0 80 0, 		Gr 20 1.5)+corpo   	= (Ge 0 0 0 20 0, 		Gr 40 2)+bracciodx     	= (Ge 13 50 13 25 0, 		Gr 25 3.5)+avambracciodx   = (Ge 13 0 13 (-20) 0, 		Gr 20 3.5)+cosciadx     	= (Ge 10 (-10) 10 (-40) 0, 	Gr 30 3)+gambadx     	= (Ge 10 (-70) 10 (-97) 0, 	Gr 27 3)++simmetrico (Ge x y xo yo alpha, gr)  =  (Ge (-x) y (-xo) yo (pi - alpha), gr)++marionetta :: Descrizione +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) []]+    ]++main = run (gloss_run "marionetta" (600,600) (0,0)) gloss_implementazione marionetta