marionetta-0.1.0.3: Controller.hs

{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}

module Controller (Evento (..), catchEvento, mkWorld, World (..), Lasso (..), Verso (..), updateTime) where


import Data.Maybe (fromMaybe)
import Control.Arrow (first, second) 

import Data.List.Zipper (mkZipper, Zipper , inserisci, elimina, destra, sinistra, modifica)
import Data.Tree.Missing (inspectTop , forward, backward, topSelector)
import Model (Figura,  Punto(..), vicino, assolutizza, Tempo (..), Normalizzato)
import IFigura (IFigura(IFigura), ifigura , traslazione, rotazione, movimentoCentroTop, modificaSelettori, ricentra, iselectors)
import Movie

data MoveEffect = Ruotando Punto | Traslando Punto | SpostandoCentro Punto | SpostandoFulcrum Punto| Niente

data World = World (Tempo Normalizzato) (Zipper (IFigura,Fulcrum)) MoveEffect 
mkWorld :: Figura -> World 
mkWorld fig = World 
	(Tempo 0)
	(mkZipper $ (IFigura fig [] (forward (inspectTop fig) fig) (backward (inspectTop fig) fig),  Fulcrum (topSelector fig) $ Punto (0,0)))
	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
	SpostamentoFulcrum :: Punto -> Lasso -> Evento
	RicentraFulcrum :: Punto -> Evento

modificaIFigura  f = modifica $ first f
modificaFulcrum f = modifica $ second f

catchEvento :: Evento -> World -> World
catchEvento Refresh (World t z _) = World t z Niente
catchEvento (Puntatore p) (World t z Niente) = World t z Niente
catchEvento (Puntatore p) (World t z (Traslando q)) = World t (modificaIFigura  (traslazione q p) z) $ Traslando p 
catchEvento (Puntatore p) (World t z (Ruotando q)) = World t (modificaIFigura  (rotazione q p) z) $ Ruotando p 
catchEvento (Puntatore p) (World t z (SpostandoCentro q)) = World t (modificaIFigura  (movimentoCentroTop q p) z) $ SpostandoCentro p 
catchEvento (Puntatore p) (World t z (SpostandoFulcrum q)) = World t (modificaFulcrum  (\ful -> ful {fulcrum = q}) z) $ SpostandoFulcrum p 
catchEvento (Rotazione p Inizio) (World t z _) = World t z (Ruotando p)
catchEvento (Rotazione p Fine) (World t z (Ruotando _)) = World t z Niente
catchEvento (Rotazione p Fine) w = w
catchEvento (Traslazione p Inizio) (World t z _) = World t z (Traslando p)
catchEvento (Traslazione p Fine) (World t z (Traslando _)) = World t z Niente
catchEvento (Traslazione p Fine) w = w
catchEvento (SpostamentoCentro p Inizio) (World t z _) = World t z (SpostandoCentro p)
catchEvento (SpostamentoCentro p Fine) (World t z (SpostandoCentro _)) = World t z Niente
catchEvento (SpostamentoCentro p Fine) w = w
catchEvento Cancella (World t z m) = World t (fromMaybe z $ elimina z) m
catchEvento Clona (World t z m) = World t (inserisci id z) m
catchEvento (Fuoco Destra) (World t z m) = World t (destra z) m
catchEvento (Fuoco Sinistra) (World t z m) = World t (sinistra z) m
catchEvento (Seleziona p) (World t z m) = World t (modificaIFigura  (modificaSelettori p) z) m
catchEvento Deseleziona (World t z m) = World t (modificaIFigura  f z) m where
	f ifig = ifig {iselectors = []}
catchEvento (Ricentra p) (World t z m)  = World t (modificaIFigura  (ricentra p) z) m
catchEvento Silent w = w
catchEvento (SpostamentoFulcrum p Inizio) (World t z _) = World t  z (SpostandoFulcrum p)
catchEvento (SpostamentoFulcrum p Fine) (World t z (SpostandoFulcrum _)) = World t z Niente
catchEvento (SpostamentoFulcrum p Fine) w = w
catchEvento (RicentraFulcrum p) (World t z m)  = World t (modifica f z) m where
	f (ifi, Fulcrum _ q) = (ifi, Fulcrum (vicino p (assolutizza $ ifigura ifi)) q)

updateTime :: Float -> World -> World
updateTime ((/3) -> t) (World (tempo -> t') z m) = World (Tempo t'') z m where
	t'' = if t + t' > 1 then 0 else t + t'