diff --git a/Controller.hs b/Controller.hs new file mode 100644 --- /dev/null +++ b/Controller.hs @@ -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 + + + + + diff --git a/Data/List/Zipper.hs b/Data/List/Zipper.hs new file mode 100644 --- /dev/null +++ b/Data/List/Zipper.hs @@ -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 + + + diff --git a/Data/Tree/Missing.hs b/Data/Tree/Missing.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/Missing.hs @@ -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) + + diff --git a/Data/Zip.hs b/Data/Zip.hs new file mode 100644 --- /dev/null +++ b/Data/Zip.hs @@ -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' + diff --git a/Gloss.hs b/Gloss.hs new file mode 100644 --- /dev/null +++ b/Gloss.hs @@ -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) diff --git a/IFigura.hs b/IFigura.hs new file mode 100644 --- /dev/null +++ b/IFigura.hs @@ -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 + + + + + + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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. diff --git a/Model.hs b/Model.hs new file mode 100644 --- /dev/null +++ b/Model.hs @@ -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 + + + + + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/View.hs b/View.hs new file mode 100644 --- /dev/null +++ b/View.hs @@ -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" + ] + + diff --git a/gloss.patch b/gloss.patch new file mode 100644 --- /dev/null +++ b/gloss.patch @@ -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] diff --git a/marionetta.cabal b/marionetta.cabal new file mode 100644 --- /dev/null +++ b/marionetta.cabal @@ -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: + diff --git a/marionetta.hs b/marionetta.hs new file mode 100644 --- /dev/null +++ b/marionetta.hs @@ -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