Allow generating gifs vor visualizing steps of the graham algo

TODO: this still requires us to hack on Main.hs, because
it isn't compatible with the GUI.
Also see https://github.com/diagrams/diagrams-cairo/issues/55
This commit is contained in:
hasufell 2014-10-09 03:10:21 +02:00
parent 8949d05b3b
commit 1fd0b9f27f
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
4 changed files with 72 additions and 5 deletions

View File

@ -64,3 +64,20 @@ grahamGetCH vs = f . grahamSort $ vs
| ccw x y z = x : f (y:z:xs) | ccw x y z = x : f (y:z:xs)
| otherwise = f (x:z:xs) | otherwise = f (x:z:xs)
f xs = 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

View File

@ -60,7 +60,7 @@ executable CG2
-- other-extensions: -- other-extensions:
-- Other library packages from which modules are imported. -- 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. -- Directories containing source files.
-- hs-source-dirs: -- hs-source-dirs:

View File

@ -7,12 +7,15 @@ module Diagram (t,
defaultProp, defaultProp,
diag, diag,
diagS, diagS,
gifDiag,
gifDiagS,
whiteRect) where whiteRect) where
import Algorithms.ConvexHull import Algorithms.ConvexHull
import Codec.Picture.Gif
import Class.Defaults import Class.Defaults
import Diagrams.Prelude
import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo
import Diagrams.Prelude
import LinearAlgebra.Vector import LinearAlgebra.Vector
import Parser.Meshparser import Parser.Meshparser
@ -104,6 +107,8 @@ showConvexHullPoints = Diag f
vtch = grahamGetCH vt vtch = grahamGetCH vt
-- |Create a diagram which shows the lines along the convex hull
-- points.
showConvexHullLines :: Diag showConvexHullLines :: Diag
showConvexHullLines = Diag f showConvexHullLines = Diag f
where where
@ -116,6 +121,19 @@ showConvexHullLines = Diag f
) # moveTo (head $ grahamGetCH vt) # lc red ) # 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 -- |Creates a Diagram that shows an XAxis which is bound
-- by the dimensions given in xD from DiagProp. -- by the dimensions given in xD from DiagProp.
showXAxis :: Diag showXAxis :: Diag
@ -150,8 +168,9 @@ diag p = case alg p of
(mconcat [showCoordinates, showXAxis, showYAxis, showWhiteRectB]) (mconcat [showCoordinates, showXAxis, showYAxis, showWhiteRectB])
p p
1 -> mkDiag 1 -> mkDiag
(mconcat [showConvexHullPoints, showConvexHullLines, (mconcat $
showCoordinates, showXAxis, showYAxis, showWhiteRectB]) [showConvexHullPoints, showConvexHullLines, showCoordinates,
showXAxis, showYAxis, showWhiteRectB])
p p
_ -> mempty _ -> mempty
@ -165,6 +184,30 @@ diagS p mesh
mesh) # bg white 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. -- |Create a white rectangle with the given width and height.
whiteRect :: Double -> Double -> Diagram Cairo R2 whiteRect :: Double -> Double -> Diagram Cairo R2
whiteRect x y = rect x y # lwG 0.00 # bg white whiteRect x y = rect x y # lwG 0.00 # bg white

9
Gtk.hs
View File

@ -1,12 +1,13 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module Gtk (makeGUI) where module Gtk (makeGUI, gifCLI) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Class.Defaults import Class.Defaults
import Diagram import Diagram
import Diagrams.Prelude import Diagrams.Prelude
import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.CmdLine
import Diagrams.Backend.Cairo.Internal import Diagrams.Backend.Cairo.Internal
import Graphics.UI.Gtk import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade 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' 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. -- |Main entry point for the GTK GUI routines.
makeGUI :: FilePath -> IO () makeGUI :: FilePath -> IO ()
makeGUI startFile = do makeGUI startFile = do