Skip to content
Browse files

refactoring over

  • Loading branch information...
1 parent 8b1478d commit 0a0da4b46431012d21554b819657d7555bebba95 @paolino committed
Showing with 282 additions and 414 deletions.
  1. +59 −104 Controller.hs
  2. +58 −0 Gloss.hs
  3. +78 −0 IFigura.hs
  4. +0 −82 Interfaccia.hs
  5. +0 −58 Interface/Register.hs
  6. +0 −76 Linguaggio.hs
  7. +0 −63 Marionetta.hs
  8. +5 −6 Model.hs
  9. +0 −22 Render/Gloss.hs
  10. +52 −0 View.hs
  11. +3 −3 marionetta.cabal
  12. +27 −0 marionetta.hs
View
163 Controller.hs
@@ -1,8 +1,6 @@
-
-{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GADTs #-}
module Controller where
@@ -14,108 +12,65 @@ import Data.Map (Map, empty,elems,insert,delete )
import Data.Maybe (fromMaybe)
import Data.Tree (Tree)
-import Graphics.Gloss.Interface.Game (Event (..), MouseButton (..), Key (..), KeyState (..))
-import Data.List.Zipper (Zipper , inserisci, elimina, destra, sinistra, modifica)
-import Data.Tree.Missing (routingDumb, forward, backward,modifyTop, Routing)
+import Data.List.Zipper (mkZipper, Zipper , inserisci, elimina, destra, sinistra, modifica)
+import Data.Tree.Missing (inspectTop , routingDumb, forward, backward,modifyTop, Routing)
import Data.Zip (Selector, moveSelector, filterDuplicates, labella)
-import Model (ruotaScelto, vicino, Punto (..), Assoluto (..), Pezzo (..), assolutizza, relativizza)
-import Interfaccia (IFigura (..))
-
-data Movimenti a = Movimenti
- { lastPunto :: Maybe Punto
- , movimenti :: Map Char (Movimento a)
- }
-
-mkMovimenti = Movimenti Nothing empty
-
-type Movimento a = Punto -> a -> Punto -> a
-
-type CatchEvent a = Event -> a -> Maybe a
-
-catchMevs :: CatchEvent (a, Movimenti a)
-catchMevs (EventKey (MouseButton _) _ _ _) (x,Movimenti _ movs) = Just (x,Movimenti Nothing movs)
-catchMevs (EventMotion (Punto -> p)) (x,Movimenti q movs) =
- Just (foldr (\f x -> f (fromMaybe p q) x p) x . elems $ movs, Movimenti (Just p) movs)
-
-catchMevs _ _ = Nothing
-
-register :: Key -> Movimento a -> CatchEvent (a,Movimenti a)
-register c@(Char z) m (EventKey e Down _ (Punto -> p)) (x,Movimenti q movs)
- | c == e = Just (m (fromMaybe p q) x p, Movimenti (Just p) $ insert z m movs)
- | otherwise = Nothing
-register c@(Char z) m (EventKey e Up _ _) (x,Movimenti p movs)
- | c == e = Just (x,Movimenti Nothing $ delete z movs)
- | otherwise = Nothing
-
-catchRegister :: [CatchEvent (a,Movimenti a)] -> CatchEvent (a, Movimenti a)
-catchRegister regs ev (w,movs) = catchMevs' <|> catchRegs where
- catchMevs' = catchMevs ev (w,movs)
- catchRegs = msum . map (\r -> r ev (w,movs)) $ regs
-
-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
-
-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 World = (Zipper IFigura, Movimenti (Zipper IFigura))
-
-catchMovimento :: [(Key,Movimento IFigura)] -> CatchEvent World
-catchMovimento xs = catchRegister [register e (\p x q -> modifica (\i -> f p i q) x) | (e,f) <- xs]
-
-traslazione :: Movimento IFigura
-traslazione l (IFigura ifig ir iforw ibackw) l' = 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 (IFigura ifig ir iforw ibackw) l' = 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 (IFigura ifig ir iforw ibackw) l' = IFigura ifig' ir iforw ibackw
- where ifig' = relativizza . modifyTop (\(Pezzo _ o alpha) -> Pezzo l o alpha) . assolutizza $ ifig
-
-
-catchEvents :: CatchEvent World
-catchEvents (EventKey (Char 'c') Down _ _ ) = Just . first (inserisci id)
-catchEvents (EventKey (Char 'd') Down _ _ ) = Just . first (\z -> fromMaybe z $ elimina z)
-catchEvents (EventKey (MouseButton WheelUp) Up _ _ ) = Just . first destra
-catchEvents (EventKey (MouseButton WheelDown) Up _ _ ) = Just . first sinistra
-catchEvents (EventKey (Char 'g') Down _ (Punto -> l)) = Just . first (modifica $ ricentra l)
-catchEvents (EventKey (Char 'z') Down _ _) = Just . first (modifica f) where
- f (IFigura ifig _ iforw ibackw) = IFigura ifig [] iforw ibackw
-catchEvents (EventKey (Char 's') Down _ (Punto -> l)) = Just . first (modifica f) where
- f (IFigura ifig ir iforw ibackw) = IFigura ifig (filterDuplicates ifig (ir':ir)) iforw ibackw where
- ir' = vicino l . assolutizza $ ifig
-catchEvents e = catchMovimento [(Char 't', traslazione), (Char 'r' , rotazione), (Char 'x', movimentoCentroTop)] e
-
-controller :: Event -> World -> World
-controller e w = fromMaybe w $ catchEvents e w
-
-
+import Model (Figura, ruotaScelto, vicino, Punto (..), Assoluto (..), Pezzo (..), assolutizza, relativizza)
+import IFigura
+
+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
+
+type Change = World -> World
+
+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
+
+catch :: Evento -> Change
+catch Refresh (World z _) = World z Niente
+catch (Puntatore p) (World z Niente) = World z Niente
+catch (Puntatore p) (World z (Traslando q)) = World (modifica (traslazione q p) z) $ Traslando p
+catch (Puntatore p) (World z (Ruotando q)) = World (modifica (rotazione q p) z) $ Ruotando p
+catch (Puntatore p) (World z (SpostandoCentro q)) = World (modifica (movimentoCentroTop q p) z) $ SpostandoCentro p
+catch (Rotazione p Inizio) (World z _) = World z (Ruotando p)
+catch (Rotazione p Fine) (World z (Ruotando _)) = World z Niente
+catch (Rotazione p Fine) w = w
+catch (Traslazione p Inizio) (World z _) = World z (Traslando p)
+catch (Traslazione p Fine) (World z (Traslando _)) = World z Niente
+catch (Traslazione p Fine) w = w
+catch (SpostamentoCentro p Inizio) (World z _) = World z (SpostandoCentro p)
+catch (SpostamentoCentro p Fine) (World z (SpostandoCentro _)) = World z Niente
+catch (SpostamentoCentro p Fine) w = w
+catch Cancella (World z m) = World (fromMaybe z $ elimina z) m
+catch Clona (World z m) = World (inserisci id z) m
+catch (Fuoco Destra) (World z m) = World (destra z) m
+catch (Fuoco Sinistra) (World z m) = World (sinistra z) m
+catch (Seleziona p) (World z m) = World (modifica (modificaSelettori p) z) m
+catch Deseleziona (World z m) = World (modifica f z) m where
+ f ifig = ifig {iselectors = []}
+catch (Ricentra p) (World z m) = World (modifica (ricentra p) z) m
+catch Silent w = w
View
58 Gloss.hs
@@ -0,0 +1,58 @@
+
+{-# LANGUAGE ViewPatterns #-}
+module Gloss where
+
+
+import Prelude hiding (catch)
+import Data.Monoid (mconcat)
+
+import Graphics.Gloss
+import Graphics.Gloss.Interface.Game
+
+import View
+import Model
+import Controller
+import Run
+import Debug.Trace
+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 :: Picture -> Render Picture
+renderPezzo 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
+ ]
+
+render :: Grafici -> Render Picture
+render = renderPezzo . elemento
+
+gloss_implementazione :: Implementazione Picture Event
+gloss_implementazione = Implementazione render 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)
View
78 IFigura.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+
+module IFigura where
+
+
+import Control.Monad (msum)
+import Control.Arrow (first)
+import Control.Applicative ((<|>))
+import Data.Map (Map, empty,elems,insert,delete )
+import Data.Maybe (fromMaybe)
+import Data.Tree (Tree)
+
+import Graphics.Gloss.Interface.Game (Event (..), MouseButton (..), Key (..), KeyState (..))
+
+import Data.List.Zipper (Zipper , inserisci, elimina, destra, sinistra, modifica)
+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
+
+
+
+
+
+
+
+
View
82 Interfaccia.hs
@@ -1,82 +0,0 @@
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ImpredicativeTypes #-}
-
-module Interfaccia where
-
-
--- import Linguaggio
- -- ( Passo(..), deserializza, Sequenza(..) , Serializzazione(..))
-import Graphics.Gloss
- (greyN, color, green, line, displayInWindow, Picture, white,
- gameInWindow)
-import Model
- (Assoluto, relativizza, assolutizza, vicino, Angolo, ruotaScelto,
- Punto(..), Relativo, Pezzo(..), Figura, renderFigura, Rendering)
-
-import Graphics.Gloss.Data.Picture (Picture(..))
-import Debug.Trace
-import Data.Zip (Selector, moveSelector, filterDuplicates, labella)
-import Data.Tree (drawTree, Tree)
-import Data.List.Zipper
- (elimina, destra, sinistra, modifica, inserisci, valore, elementi,
- Zipper(..))
-import Graphics.Gloss.Interface.Game
-import Data.Tree.Missing
-import Interface.Register (register, catchRegister, CatchEvent, Movimenti, mkMovimenti)
-import Control.Arrow (ArrowChoice(..))
-import Control.Exception (assert)
-
-
-data IFigura = IFigura
- { ifigura :: Figura
- , iselectors :: forall b. [Selector Tree b]
- , iforward :: forall b . Routing b
- , ibackward :: forall b . Routing b
-
- }
-
-
-
------------------------------ rendering ---------------------------------------------
-renderIFigura re (IFigura ifig isels iforw _ ) = Pictures . renderFigura re'' $ ifig
- where
- re' = foldr (\ir re -> fst (ir re) $ (Color yellow .)) (routingDumb iforw re) isels
- re'' = modifyTop (Color blue .) re'
-
-
-croce = Color green $ Pictures [line [(-200,0),(200,0)], line [(0,200),(0,-200)]]
-
-renderWorld :: Rendering Picture -> Zipper IFigura -> Picture
-
-renderWorld re ca = let
- ps = Pictures . map (renderIFigura re) $ elementi ca
- actual = (renderIFigura re) $ valore ca
- in Pictures $[Color blue . translate (-250) (250-16*i) . scale 0.09 0.14 $ Text h | (i,h) <- zip [0..] help] ++
- [ croce,color (greyN 0.5) ps, color (greyN 0.1) actual]
-
-renderWorldG re = renderWorld re . fst
-
-help = [ "S: select/deselect nearest to pointer piece for rotation"
- , "Z: 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"
- ]
-stepWorld :: Float -> a -> a
-stepWorld = const id
-
-type World = Zipper IFigura
-
--- run :: Rendering Picture -> World -> IO ()
--- run re world = gameInWindow "marionetta" (600,600) (0,0) white 100 (world,mkMovimenti) (renderWorldG re) changeWorldG stepWorld
-
-
-
-
View
58 Interface/Register.hs
@@ -1,58 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Interface.Register
--- Copyright :
--- License : BSD3
---
--- Maintainer : paolo.veronelli@gmail.com
--- Stability :
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-{-# LANGUAGE ViewPatterns #-}
-
-module Interface.Register where
-
-
-import Graphics.Gloss.Interface.Game (Event(..), KeyState (..), Key (..) )
-import Data.Maybe (Maybe)
-import Graphics.Gloss.Interface.Game (Key, Modifiers)
-import Data.Map (delete, insert, Map, empty)
-import Model (Punto(..))
-import Data.Foldable (msum, toList)
-import Control.Applicative (Alternative ((<|>)))
-import Debug.Trace (trace)
-
-
-data Movimenti a = Movimenti
- { lastPunto :: Maybe Punto
- , movimenti :: Map Char (Movimento a)
- }
-
-mkMovimenti = Movimenti Nothing empty
-
-type Movimento a = Punto -> a -> Punto -> a
-
-type CatchEvent a = Event -> a -> Maybe a
-
-catchMevs :: CatchEvent (a, Movimenti a)
-catchMevs (EventKey (MouseButton _) _ _ _) (x,Movimenti _ movs) = Just (x,Movimenti Nothing movs)
-catchMevs (EventMotion (Punto -> p)) (x,Movimenti q movs) =
- Just (foldr (\f x -> f (maybe p id q) x p) x . toList $ movs, Movimenti (Just p) movs)
-
-catchMevs _ _ = Nothing
-
-register :: Key -> Movimento a -> CatchEvent (a,Movimenti a)
-register c@(Char z) m (EventKey e Down _ (Punto -> p)) (x,Movimenti q movs)
- | c == e = Just (m (maybe p id q) x p, Movimenti (Just p) $ insert z m movs)
- | otherwise = Nothing
-register c@(Char z) m (EventKey e Up _ _) (x,Movimenti p movs)
- | c == e = Just (x,Movimenti Nothing $ delete z movs)
- | otherwise = Nothing
-
-catchRegister :: [CatchEvent (a,Movimenti a)] -> CatchEvent (a, Movimenti a)
-catchRegister regs ev (w,movs) = catchMevs' <|> catchRegs where
- catchMevs' = catchMevs ev (w,movs)
- catchRegs = msum . map (\r -> r ev (w,movs)) $ regs
View
76 Linguaggio.hs
@@ -1,76 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Linguaggio
--- Copyright :
--- License : BSD3
---
--- Maintainer : paolo.veronelli@gmail.com
--- Stability :
--- Portability :
---
--- |
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Linguaggio where
-
-import Prelude hiding (zipWith)
-import Data.Tree (Tree)
-import Model
- (Angolo, assolutizza, relativizza, interpolazione, Assoluto,
- Punto(..), Pezzo(..), Pezzo, Relativo, Tempo(..), (.-.), (.+.),
- (./.), 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
- ( ricentratore, Ricentratore, labella)
-import Data.Foldable (toList)
-import Data.Zip
-import Debug.Trace
-
-
-
-
-
-type Nome = Int
-
-data Passo = Passo
- { nuovaFigura :: Figura
- , durataPasso :: Tempo Relativo
- , fulcroPasso :: Nome
- , centroFulcro :: Punto
- } deriving (Show,Read)
-
-data Serializzazione = Serializzazione
- { figuraIniziale :: Figura
- , passi :: [Passo]
- } deriving (Show, Read)
-
-
-data Sequenza b = Sequenza
- { partenza :: Figura
- , finale :: Figura
- , centratore :: Tree b -> Tree b
- , durataSequenza :: Tempo Relativo
- }
-
-deserializza :: Serializzazione -> [Sequenza b]
-deserializza s@(Serializzazione f0 ps) = ss where
- ss = zipWith f (f0 : map nuovaFigura ps) ps where
- rif = labella [0..] f0
- f f0 (Passo f1 t n c) = Sequenza (r' f0) (r' f1) (r undefined (const id)) t
- where r = ricentratore n rif :: Ricentratore b c
- 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
-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
63 Marionetta.hs
@@ -1,63 +0,0 @@
-
-import Debug.Trace
-import Graphics.Gloss
-import Data.Tree (Tree (Node))
-
-import Model (Figura, Rendering, Renderer,renderFigura, Punto (..), Pezzo (..), assolutizza, relativizza, Assoluto, vicino )
-import Interfaccia
-import Data.Tree.Missing
-import Control.Arrow
--- import Linguaggio (Serializzazione(..) , Passo (..))
-import Data.List.Zipper
-
-
--------------------------- esempio --------------------------------
-
-elemento :: Float -> Float -> Picture
-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
-
-renderer :: Picture -> Renderer Picture
-renderer 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
- ]
-
-
-testa = pezzo 0 60 0 80 0 20 1.5
-corpo = pezzo 0 0 0 20 0 40 2
-bracciodx = pezzo 13 50 13 25 0 25 3.5
-
-avambracciodx = pezzo 13 0 13 (-20) 0 20 3.5
-
-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 (first simmetrico bracciodx) [Node (first simmetrico avambracciodx) []]
- , Node cosciadx [Node gambadx []]
- , Node (first simmetrico cosciadx) [Node (first simmetrico gambadx) []]
- ]
-
-rendering :: Rendering Picture
-rendering = fmap (renderer . snd) $ marionetta
-
-figura :: Figura
-figura = relativizza $ fmap fst marionetta
-
-world :: World
-world = mkZipper $ IFigura figura [] (forward (inspectTop figura) figura) (backward (inspectTop figura) figura)
-
-main = run rendering world
-
-
View
11 Model.hs
@@ -7,7 +7,7 @@ module Model where -- (Punto (..), Semiretta (..), Angolo , TreePath, Tree, Acce
import Prelude hiding (zipWith)
import Data.Tree (Tree(..))
-import Data.Tree.Missing ( recurseTreeAccum)
+import Data.Tree.Missing ( recurseTreeAccum, Routing, modifyTop)
import Control.Applicative ((<$>))
import Control.Monad (ap)
import Data.Foldable (minimumBy, toList)
@@ -105,14 +105,13 @@ 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
+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
View
22 Render/Gloss.hs
@@ -1,22 +0,0 @@
-module Render.Gloss where
-
-import Graphics.Gloss
-import Data.Tree (Tree (Node))
-import Data.Tree.Missing (zipTreeWith)
-import Data.Foldable (toList)
-import Model
-
-
-
-
-renderSemiretta :: Tree (Semiretta -> Picture) -> Tree Semiretta -> Picture
-renderSemiretta tsp ts = Pictures . toList $ zipTreeWith ($) tsp (assolutizza ts)
-
-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
52 View.hs
@@ -0,0 +1,52 @@
+module View 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, Routing)
+import Data.List.Zipper (Zipper, elementi, valore)
+import Model (assolutizza , Pezzo (..), Punto (..), Assoluto, Figura)
+import 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
+
+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"
+ ]
+
+
View
6 marionetta.cabal
@@ -48,13 +48,13 @@ Cabal-version: >=1.2
Executable marionetta
-- .hs or .lhs file containing the Main module.
- Main-is: Marionetta.hs
+ Main-is: marionetta.hs
-- Packages needed in order to build this package.
- -- Build-depends:
+ Build-depends: base -any, mtl -any, containers -any , gloss -any
-- Modules not exported by this package.
- Other-modules: Control.hs
+ 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:
View
27 marionetta.hs
@@ -0,0 +1,27 @@
+
+import Prelude hiding (catch)
+import Data.Tree (Tree (Node))
+import Control.Arrow (first)
+
+import Run (Descrizione, run, Grafici(..), Geometrici(..))
+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

0 comments on commit 0a0da4b

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