diff --git a/Algorithms/ConvexHull.hs b/Algorithms/ConvexHull.hs index 3a36703..45e699e 100644 --- a/Algorithms/ConvexHull.hs +++ b/Algorithms/ConvexHull.hs @@ -64,3 +64,20 @@ grahamGetCH vs = f . grahamSort $ vs | ccw x y z = x : f (y:z:xs) | otherwise = f (x:z:xs) f xs = xs + + +-- |Only compute steps of the graham scan algorithm to allow +-- visualizing it. +grahamGetCHSteps :: [PT] -> [[PT]] +grahamGetCHSteps vs = reverse . g $ (length . grahamGetCH $ vs) + where + vs' = grahamSort vs + g c + | c >= 0 = f 0 vs' : g (c - 1) + | otherwise = [] + where + f c' (x:y:z:xs) + | c' >= c = [x,y] + | ccw x y z = x : f (c' + 1) (y:z:xs) + | otherwise = f (c' + 1) (x:z:xs) + f _ xs = xs diff --git a/CG2.cabal b/CG2.cabal index 0e43c09..9d0095f 100644 --- a/CG2.cabal +++ b/CG2.cabal @@ -60,7 +60,7 @@ executable CG2 -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.6 && <4.8, diagrams-lib >=1.2 && <1.3, diagrams-cairo >=1.2 && <1.3, transformers >=0.4 && <0.5, glade >=0.12 && <0.13, gtk >=0.12 && <0.13, directory >=1.2 && <1.3 + build-depends: base >=4.6 && <4.8, diagrams-lib >=1.2 && <1.3, diagrams-cairo >=1.2 && <1.3, transformers >=0.4 && <0.5, glade >=0.12 && <0.13, gtk >=0.12 && <0.13, directory >=1.2 && <1.3, JuicyPixels >= 3.1.7.1 -- Directories containing source files. -- hs-source-dirs: diff --git a/Diagram.hs b/Diagram.hs index c94363b..8e02d72 100644 --- a/Diagram.hs +++ b/Diagram.hs @@ -7,12 +7,15 @@ module Diagram (t, defaultProp, diag, diagS, + gifDiag, + gifDiagS, whiteRect) where import Algorithms.ConvexHull +import Codec.Picture.Gif import Class.Defaults -import Diagrams.Prelude import Diagrams.Backend.Cairo +import Diagrams.Prelude import LinearAlgebra.Vector import Parser.Meshparser @@ -104,6 +107,8 @@ showConvexHullPoints = Diag f vtch = grahamGetCH vt +-- |Create a diagram which shows the lines along the convex hull +-- points. showConvexHullLines :: Diag showConvexHullLines = Diag f where @@ -116,6 +121,19 @@ showConvexHullLines = Diag f ) # moveTo (head $ grahamGetCH vt) # lc red +-- |Same as showConvexHullLines, except that it returns an array +-- of diagrams with each step of the algorithm. +showConvexHullLinesInterval :: DiagProp -> [PT] -> [Diagram Cairo R2] +showConvexHullLinesInterval _ xs = + fmap g (grahamGetCHSteps xs) + where + g vt + = (strokeTrail . + fromVertices $ + vt + ) # moveTo (head vt) # lc red + + -- |Creates a Diagram that shows an XAxis which is bound -- by the dimensions given in xD from DiagProp. showXAxis :: Diag @@ -150,8 +168,9 @@ diag p = case alg p of (mconcat [showCoordinates, showXAxis, showYAxis, showWhiteRectB]) p 1 -> mkDiag - (mconcat [showConvexHullPoints, showConvexHullLines, - showCoordinates, showXAxis, showYAxis, showWhiteRectB]) + (mconcat $ + [showConvexHullPoints, showConvexHullLines, showCoordinates, + showXAxis, showYAxis, showWhiteRectB]) p _ -> mempty @@ -165,6 +184,30 @@ diagS p mesh mesh) # bg white +-- |Return a list of tuples used by 'gifMain' to generate an animated gif. +gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)] +gifDiag p xs = fmap (\x -> (x, 100)) . + fmap (\x -> x <> g) . + flip (++) + [mkDiag (showConvexHullLines `mappend` + showConvexHullPoints) p xs] $ + (showConvexHullLinesInterval p xs) + where + g = mconcat . + fmap (\x -> mkDiag x p xs) $ + [showCoordinates, + showXAxis, + showYAxis, + showWhiteRectB] + + +-- |Same as gifDiag, except that it takes a string containing the +-- mesh file content instead of the the points. +gifDiagS :: DiagProp -> String -> [(Diagram Cairo R2, GifDelay)] +gifDiagS p = gifDiag p . + meshToArr + + -- |Create a white rectangle with the given width and height. whiteRect :: Double -> Double -> Diagram Cairo R2 whiteRect x y = rect x y # lwG 0.00 # bg white diff --git a/Gtk.hs b/Gtk.hs index 51c45a3..6593d86 100644 --- a/Gtk.hs +++ b/Gtk.hs @@ -1,12 +1,13 @@ {-# OPTIONS_HADDOCK ignore-exports #-} -module Gtk (makeGUI) where +module Gtk (makeGUI, gifCLI) where import Control.Monad.IO.Class import Class.Defaults import Diagram import Diagrams.Prelude import Diagrams.Backend.Cairo +import Diagrams.Backend.Cairo.CmdLine import Diagrams.Backend.Cairo.Internal import Graphics.UI.Gtk import Graphics.UI.Gtk.Glade @@ -76,6 +77,12 @@ makeMyGladeGUI = do return $ MkMyGUI win' dB' sB' qB' fB' da' hs' xl' xu' yl' yu' aD' cB' +gifCLI :: FilePath -> IO () +gifCLI startFile = do + mesh <- readFile "UB1_sonderfaelle.obj" + gifMain (gifDiagS def mesh) + + -- |Main entry point for the GTK GUI routines. makeGUI :: FilePath -> IO () makeGUI startFile = do