Permalink
Browse files

refactoring

  • Loading branch information...
1 parent 6f73e8d commit 8b1478d6bf7fee96a9f0baf5a37971f0a9bdc699 @paolino committed Nov 16, 2011
Showing with 135 additions and 113 deletions.
  1. +123 −0 Controller.hs
  2. +2 −18 Data/Tree/Missing.hs
  3. +2 −86 Interfaccia.hs
  4. +2 −2 LICENSE
  5. +6 −7 marionetta.cabal
View
@@ -0,0 +1,123 @@
+
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+
+module Controller 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 (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
+
+
+
+
+
+
+
View
@@ -63,23 +63,7 @@ backward y tr x0 f = maybe (error "missing element in ricentratore") id . mov
type Routing b = b -> (b -> b -> b) -> Tree b -> (b , Tree b)
-routing :: forall a b . Eq a => a -> Tree a -> Routing b
-routing xt tr x0 f = second (fmap snd) . either (error "endpoint not found in routing") id . search . zipWith (,) tr where
- search (Node (x,x2) ys)
- | xt == x = Right(x2,Node (x,f x0 x2) ys)
- | null ys = Left (Node (x,x2) ys)
- | otherwise = let
- ys' = map search ys
- in case rights ys' of
- [] -> Left (Node (x,x2) ys)
- [(x0,_)] -> Right (x2,Node (x,f x0 x2) $ map (either id snd) ys')
- _ -> error "multiple endpoints in routing"
+routingDumb :: Routing b -> Tree b -> Tree b
+routingDumb r = snd . r undefined (const id)
-
-
-niceTree = putStrLn . drawTree . fmap show
-{-
-checkFB n s = mapM_ niceTree [s, forward n s s, backward n s (forward n s s)]
--}
-
View
@@ -23,11 +23,8 @@ import Data.Tree (drawTree, Tree)
import Data.List.Zipper
(elimina, destra, sinistra, modifica, inserisci, valore, elementi,
Zipper(..))
-import qualified Data.Char
import Graphics.Gloss.Interface.Game
-import Data.Graph (reachable)
import Data.Tree.Missing
- (Routing, backward, forward, Ricentratore, modifyTop)
import Interface.Register (register, catchRegister, CatchEvent, Movimenti, mkMovimenti)
import Control.Arrow (ArrowChoice(..))
import Control.Exception (assert)
@@ -41,28 +38,6 @@ data IFigura = IFigura
}
-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)
-
-routingDumb :: Routing b -> Tree b -> Tree b
-routingDumb r = snd . r undefined (const id)
-
-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'
----------------------------- rendering ---------------------------------------------
@@ -94,72 +69,13 @@ help = [ "S: select/deselect nearest to pointer piece for rotation"
, "Mouse wheel: select a marionetta to edit"
, "D: eliminate marionetta"
]
------------------------------ input ---------------------------------------------------
-
-type CatchWorld = CatchEvent (Zipper IFigura, Movimenti (Zipper IFigura))
-
-registerModActual :: Data.Char.Char
- -> (Punto -> Punto -> IFigura -> IFigura)
- -> CatchWorld
-registerModActual s f = register (Char s) $ \ l z l' -> modifica (f l l') z
-
-registraT :: CatchWorld
-registraT = registerModActual 't' $ \ 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
-
-registraR :: CatchWorld
-registraR = registerModActual 'r' $ \ l l' (IFigura ifig ir iforw ibackw ) -> let
- ifig' = foldr (\(ir,alpha) -> ruotaScelto ir alpha) 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
-registraX :: CatchWorld
-
-registraX = registerModActual 'x' $ \ l l' (IFigura ifig ir iforw ibackw)
- -> IFigura (relativizza . modifyTop (\(Pezzo _ o alpha) -> Pezzo l o alpha)
- . assolutizza $ ifig) ir iforw ibackw
-
-
-
-
-changeWorld :: CatchEvent (Zipper IFigura, Movimenti (Zipper IFigura))
-
-changeWorld (EventKey (Char 'c') Down _ _ ) (z, mov) = Just (inserisci id z, mov)
-changeWorld (EventKey (Char 'd') Down _ _ ) (z, mov) = Just (maybe z id $ elimina z, mov)
-changeWorld (EventKey (MouseButton WheelUp) Up _ _ ) (z, mov) = Just (destra z, mov)
-changeWorld (EventKey (MouseButton WheelDown) Up _ _ ) (z, mov) = Just (sinistra z, mov)
-
-changeWorld (EventKey (Char 'g') Down _ (Punto -> l)) (z, mov) = Just (modifica (ricentra l) z, mov)
-changeWorld (EventKey (Char 'z') Down _ _) (z, mov) = Just (modifica (\(IFigura ifig _ iforw ibackw) ->
- IFigura ifig [] iforw ibackw) z, mov)
-
-
-changeWorld (EventKey (Char 's') Down _ (Punto -> l')) (z,mov) = Just (modifica f z, mov) where
- f (IFigura ifig ir iforw ibackw) = let
- ir' = vicino l' (assolutizza ifig)
- in IFigura ifig (filterDuplicates ifig (ir':ir)) iforw ibackw
-
-changeWorld e z = catchRegister [registraT, registraR, registraX] e z
-
-
-changeWorldG e w = maybe w id $ changeWorld e w
-
-
-
------------------------------ time -----------------------------------------------------
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
+-- run :: Rendering Picture -> World -> IO ()
+-- run re world = gameInWindow "marionetta" (600,600) (0,0) white 100 (world,mkMovimenti) (renderWorldG re) changeWorldG stepWorld
View
@@ -1,4 +1,4 @@
-Copyright (c)2011, Paolo Veronelli
+Copyright (c)2011, paolo veronelli
All rights reserved.
@@ -13,7 +13,7 @@ modification, are permitted provided that the following conditions are met:
disclaimer in the documentation and/or other materials provided
with the distribution.
- * Neither the name of Paolo Veronelli nor the names of other
+ * 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.
View
@@ -10,13 +10,13 @@ Name: marionetta
Version: 0.1
-- A short (one-line) description of the package.
-Synopsis: 2d marionetta movements
+-- Synopsis:
-- A longer description of the package.
-- Description:
-- URL for the project homepage or repository.
-Homepage: https://github.com/paolino/marionetta
+Homepage:
-- The license under which the package is released.
License: BSD3
@@ -25,7 +25,7 @@ License: BSD3
License-file: LICENSE
-- The package author(s).
-Author: Paolo Veronelli
+Author: paolo veronelli
-- An email address to which users can send suggestions, bug reports,
-- and patches.
@@ -48,14 +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: base -any, mtl -any, containers -any, gloss -any
+ -- Build-depends:
-- Modules not exported by this package.
- Other-modules: Data.List.Zipper Data.Tree.Missing Data.Zip
- Interfaccia Model
+ Other-modules: Control.hs
-- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
-- Build-tools:

0 comments on commit 8b1478d

Please sign in to comment.