gloss-examples 1.7.8.2 → 1.8.0.1
raw patch · 4 files changed
+262/−34 lines, 4 filesdep ~glossdep ~gloss-rasternew-component:exe:gloss-graph
Dependency ranges changed: gloss, gloss-raster
Files
- gloss-examples.cabal +39/−29
- picture/Graph/Main.hs +222/−0
- picture/Styrene/Advance.hs +1/−1
- picture/Styrene/Main.hs +0/−4
gloss-examples.cabal view
@@ -1,5 +1,5 @@ Name: gloss-examples-Version: 1.7.8.2+Version: 1.8.0.1 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -21,7 +21,7 @@ Build-depends: base == 4.6.*, bytestring == 0.10.*,- gloss == 1.7.*,+ gloss == 1.8.*, bmp == 1.2.* Main-is: Main.hs hs-source-dirs: picture/Bitmap@@ -31,7 +31,7 @@ Executable gloss-boids Build-depends: base == 4.6.*,- gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs other-modules: KDTree2d Vec2 hs-source-dirs: picture/Boids@@ -41,7 +41,7 @@ Executable gloss-clock Build-depends: base == 4.6.*,- gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Clock ghc-options: -threaded -O2@@ -50,7 +50,7 @@ Executable gloss-conway Build-depends: base == 4.6.*,- gloss == 1.7.*,+ gloss == 1.8.*, vector == 0.10.* Main-is: Main.hs other-modules: Cell World@@ -61,7 +61,7 @@ Executable gloss-draw Build-depends: base == 4.6.*,- gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Draw ghc-options: -threaded -O2@@ -70,7 +70,7 @@ Executable gloss-easy Build-depends: base == 4.6.*,- gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Easy ghc-options: -threaded -O2@@ -79,7 +79,7 @@ Executable gloss-eden Build-depends: base == 4.6.*,- gloss == 1.7.*,+ gloss == 1.8.*, random == 1.0.* Main-is: Main.hs other-modules: Cell Community World@@ -90,7 +90,7 @@ Executable gloss-flake Build-depends: base == 4.6.*,- gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Flake ghc-options: -threaded -O2@@ -99,7 +99,7 @@ Executable gloss-gameevent Build-depends: base == 4.6.*,- gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/GameEvent ghc-options: -threaded -O2@@ -108,7 +108,7 @@ Executable gloss-hello Build-depends: base == 4.6.*, - gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Hello ghc-options: -threaded -O2@@ -117,7 +117,7 @@ Executable gloss-lifespan Build-depends: base == 4.6.*, - gloss == 1.7.*, + gloss == 1.8.*, random == 1.0.* Main-is: Main.hs other-modules: Cell Community World@@ -128,7 +128,7 @@ Executable gloss-machina Build-depends: base == 4.6.*, - gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Machina ghc-options: -threaded -O2@@ -137,7 +137,7 @@ Executable gloss-occlusion Build-depends: base == 4.6.*, - gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs other-modules: Cell World State Data hs-source-dirs: picture/Occlusion@@ -148,7 +148,7 @@ Build-depends: base == 4.6.*, ghc-prim == 0.3.*,- gloss == 1.7.*,+ gloss == 1.8.*, containers == 0.5.* Main-is: Main.hs other-modules: Actor Advance Collide Config Contact QuadTree World@@ -159,7 +159,7 @@ Executable gloss-tree Build-depends: base == 4.6.*, - gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Tree ghc-options: -threaded -O2@@ -169,7 +169,7 @@ Build-depends: base == 4.6.*, vector == 0.10.*,- gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs other-modules: Draw Interface State World Geometry.Randomish Geometry.Segment hs-source-dirs: picture/Visibility @@ -179,7 +179,7 @@ Executable gloss-zen Build-depends: base == 4.6.*, - gloss == 1.7.*+ gloss == 1.8.* Main-is: Main.hs hs-source-dirs: picture/Zen ghc-options: -threaded -O2@@ -188,8 +188,8 @@ Executable gloss-crystal Build-depends: base == 4.6.*,- gloss == 1.7.*,- gloss-raster == 1.7.8.*+ gloss == 1.8.*,+ gloss-raster == 1.8.* Main-is: Main.hs hs-source-dirs: raster/Crystal ghc-options: @@ -206,8 +206,8 @@ Executable gloss-ray Build-depends: base == 4.6.*,- gloss == 1.7.*,- gloss-raster == 1.7.8.*+ gloss == 1.8.*,+ gloss-raster == 1.8.* Main-is: Main.hs other-modules: Light Object Trace Vec3 World hs-source-dirs: raster/Ray@@ -222,8 +222,8 @@ Executable gloss-pulse Build-depends: base == 4.6.*,- gloss == 1.7.*,- gloss-raster == 1.7.8.*+ gloss == 1.8.*,+ gloss-raster == 1.8.* Main-is: Main.hs hs-source-dirs: raster/Pulse ghc-options:@@ -239,8 +239,8 @@ base == 4.6.*, ghc-prim == 0.3.*, vector == 0.10.*,- gloss == 1.7.*,- gloss-raster == 1.7.8.*+ gloss == 1.8.*,+ gloss-raster == 1.8.* Main-is: Main.hs hs-source-dirs: raster/Wave ghc-options:@@ -255,7 +255,7 @@ base == 4.6.*, ghc-prim == 0.3.*, vector == 0.10.*,- gloss == 1.7.*,+ gloss == 1.8.*, repa == 3.2.*, repa-io == 3.2.*, repa-algorithms == 3.2.*@@ -279,7 +279,7 @@ Executable gloss-snow Build-depends base == 4.6.*,- gloss == 1.7.*,+ gloss == 1.8.*, repa == 3.2.*, Main-is: Main.hs hs-source-dirs: raster/Snow@@ -294,7 +294,7 @@ Executable gloss-mandel Build-depends base == 4.6.*,- gloss == 1.7.*,+ gloss == 1.8.*, repa == 3.2.* Main-is: Main.hs other-modules: Solver@@ -308,3 +308,13 @@ extensions: PatternGuards ++Executable gloss-graph+ Build-depends+ base == 4.6.*,+ gloss == 1.8.*,+ containers == 0.5.*+ Main-is: Main.hs+ hs-source-dirs: picture/Graph+ ghc-options:+ -Wall -O2
+ picture/Graph/Main.hs view
@@ -0,0 +1,222 @@+-- See <http://mazzo.li/posts/graph-drawing.html>, at some point I will+-- complete the prose that goes with the code+import Control.Monad (mplus)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Graphics.Gloss+import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Interface.Pure.Game+import Graphics.Gloss.Data.ViewState+import System.Random++type Vertex = Int+type Edge = (Vertex, Vertex)++data Graph = Graph+ { grVertices :: Set Vertex+ , grNeighs :: Map Vertex (Set Vertex)+ }++emptyGraph :: Graph+emptyGraph = Graph{grVertices = Set.empty, grNeighs = Map.empty}++addVertex :: Vertex -> Graph -> Graph+addVertex v gr@Graph{grVertices = vs, grNeighs = neighs} =+ gr{ grVertices = Set.insert v vs+ , grNeighs = case Map.lookup v neighs of+ Nothing -> Map.insert v Set.empty neighs+ Just _ -> neighs+ }++addEdge :: Edge -> Graph -> Graph+addEdge (v1, v2) gr = gr'{grNeighs = neighs}+ where+ gr' = addVertex v1 (addVertex v2 gr)+ neighs = Map.insert v1 (Set.insert v2 (vertexNeighs v1 gr')) $+ Map.insert v2 (Set.insert v1 (vertexNeighs v2 gr')) $+ grNeighs gr'++vertexNeighs :: Vertex -> Graph -> Set Vertex+vertexNeighs v Graph{grNeighs = neighs} = neighs Map.! v++graphEdges :: Graph -> Set Edge+graphEdges = Map.foldrWithKey' foldNeighs Set.empty . grNeighs+ where+ -- For each vertex `v1', insert an edge for each neighbour `v2'.+ foldNeighs v1 ns es =+ Set.foldr' (\v2 -> Set.insert (order (v1, v2))) es ns+ order (v1, v2) = if v1 > v2 then (v1, v2) else (v2, v1)++data Scene = Scene+ { scGraph :: Graph+ , scPoints :: Map Vertex Point+ , scSelected :: Maybe Vertex+ , scViewState :: ViewState+ }++emptyScene :: Scene+emptyScene =+ Scene{ scGraph = emptyGraph+ , scPoints = Map.empty+ , scSelected = Nothing+ , scViewState = viewStateInit }++scAddVertex :: Vertex -> Point -> Scene -> Scene+scAddVertex v pt sc@Scene{scGraph = gr, scPoints = pts} =+ sc{scGraph = addVertex v gr, scPoints = Map.insert v pt pts}++scAddEdge :: Edge -> Scene -> Scene+scAddEdge e@(v1, v2) sc@Scene{scGraph = gr, scPoints = pts} =+ if Map.member v1 pts && Map.member v2 pts+ then sc{scGraph = addEdge e gr}+ else error "non existant point!"++vertexPos :: Vertex -> Scene -> Point+vertexPos v Scene{scPoints = pts} = pts Map.! v++vertexRadius :: Float+vertexRadius = 6++vertexColor :: Color+vertexColor = makeColor 1 0 0 1 -- Red++edgeColor :: Color+edgeColor = makeColor 1 1 1 0.8 -- Whiteish++drawVertex :: Vertex -> Scene -> Picture+drawVertex v sc = Translate x y (ThickCircle (vertexRadius / 2) vertexRadius)+ where (x, y) = vertexPos v sc++drawEdge :: Edge -> Scene -> Picture+drawEdge (v1, v2) sc = Line [vertexPos v1 sc, vertexPos v2 sc]++windowSize :: (Int, Int)+windowSize = (640, 480)++fromEdges :: StdGen -> [Edge] -> Scene+fromEdges gen es =+ foldr scAddEdge (fst (Set.foldr' addv (emptyScene, gen) vs)) es+ where+ vs = Set.fromList (concat [[v1, v2] | (v1, v2) <- es])++ -- `fromIntegral' is needed to convert from `Int' to `Float'.+ halfWidth = fromIntegral (fst windowSize) / 2+ halfHeight = fromIntegral (snd windowSize) / 2+ addv v (sc, gen1) =+ let (x, gen2) = randomR (-halfWidth, halfWidth) gen1+ (y, gen3) = randomR (-halfHeight, halfHeight) gen2+ in (scAddVertex v (x, y) sc, gen3)++drawScene :: Scene -> Picture+drawScene sc@Scene{scGraph = gr, scViewState = ViewState{viewStateViewPort = port}} =+ applyViewPortToPicture port $+ Pictures [Color vertexColor vertices, Color edgeColor edges]+ where+ vertices = Pictures [drawVertex n sc | n <- Set.toList (grVertices gr)]+ edges = Pictures [drawEdge e sc | e <- Set.toList (graphEdges gr)]++fps :: Int+fps = 30++adjust :: Float -> Float -> Float+adjust dt x = x * dt * fromIntegral fps++local :: Point -> Point -> Vector+local (x1, y1) (x2, y2) = (x1 - x2, y1 - y2)++pushVelocity :: Float -> Point -> Point -> Vector+pushVelocity dt v1 v2 =+ if l > 0 -- If we are analysing the same vertex, l = 0+ then (dx * weight / l, dy * weight / l)+ else (0, 0)+ where+ weight = adjust dt 120+ (dx, dy) = local v1 v2+ l = 2 * (dx * dx + dy * dy)++pullVelocity :: Int -> Float -> Point -> Point -> Vector+pullVelocity nedges dt v1 v2 =+ (-(dx / weight), -(dy / weight))+ where+ (dx, dy) = local v1 v2+ weight = adjust dt (fromIntegral (nedges + 1) * 10)++updatePosition :: Float -> Vertex -> Scene -> Point+updatePosition dt v1 sc@Scene{scPoints = pts, scGraph = gr} =+ addVel v1pos (pull (push (0, 0)))+ where+ v1pos = vertexPos v1 sc+ neighs = vertexNeighs v1 gr++ addVel (x, y) (x', y') = (x + x', y + y')++ push vel =+ Map.foldr' (\v2pos -> addVel (pushVelocity dt v1pos v2pos))+ vel pts+ pull vel =+ foldr (addVel . pullVelocity (Set.size neighs) dt v1pos)+ vel [vertexPos v2 sc | v2 <- Set.toList neighs]++updatePositions :: Float -> Scene -> Scene+updatePositions dt sc@Scene{scSelected = sel, scGraph = gr} =+ foldr uppt sc . Set.toList . grVertices $ gr+ where+ uppt n sc' =+ let pt = if Just n == sel then vertexPos n sc+ else updatePosition dt n sc'+ in scAddVertex n pt sc'++inCircle :: Point -> Float -> Point -> Bool+inCircle p sca center = magV (local center p) <= vertexRadius * sca++findVertex :: Point -> Float -> Scene -> Maybe Vertex+findVertex p1 sca Scene{scPoints = pts} =+ Map.foldrWithKey'+ (\v p2 m -> m `mplus` if inCircle p1 sca p2 then Just v else Nothing)+ Nothing pts++handleEvent :: Event -> Scene -> Scene+handleEvent (EventKey (MouseButton MiddleButton) Down _ pos) sc =+ case findVertex (invertViewPort port pos) (viewPortScale port) sc of+ Nothing -> sc+ Just v -> sc{scSelected = Just v}+ where viewState = scViewState sc+ port = viewStateViewPort viewState+handleEvent (EventKey (MouseButton MiddleButton) Up _ _) sc =+ sc{scSelected = Nothing}+handleEvent (EventMotion pos) sc@Scene{scPoints = pts, scSelected = Just v} =+ sc{scPoints = Map.insert v (invertViewPort port pos) pts}+ where port = viewStateViewPort (scViewState sc)+handleEvent ev sc = sc{scViewState = updateViewStateWithEvent ev (scViewState sc)}++-- Taken from <http://www.graphviz.org/Gallery/undirected/transparency.gv.txt>+sampleGraph :: [Edge]+sampleGraph =+ [(1, 30), (1, 40), (8, 46), (8, 16), (10, 25), (10, 19), (10, 33),+ (12, 8), (12, 36), (12, 17), (13, 38), (13, 24), (24, 49), (24, 13),+ (24, 47), (24, 12), (25, 27), (25, 12), (27, 12), (27, 14), (29, 10),+ (29, 8), (30, 24), (30, 44), (38, 29), (38, 35), (2, 42), (2, 35),+ (2, 11), (14, 18), (14, 24), (14, 38), (18, 49), (18, 47), (26, 41),+ (26, 42), (31, 39), (31, 47), (31, 25), (37, 26), (37, 16), (39, 50),+ (39, 14), (39, 18), (39, 47), (41, 31), (41, 8), (42, 44), (42, 29),+ (44, 37), (44, 32), (3, 20), (3, 28), (6, 45), (6, 28), (9, 6), (9, 16),+ (15, 16), (15, 48), (16, 50), (16, 32), (16, 39), (20, 33), (33, 9),+ (33, 46), (33, 48), (45, 15), (4, 17), (4, 15), (4, 12), (17, 21),+ (19, 35), (19, 15), (19, 43), (21, 19), (21, 50), (23, 36), (34, 23),+ (34, 24), (35, 34), (35, 16), (35, 18), (36, 46), (5, 7), (5, 36),+ (7, 32), (7, 11), (7, 14), (11, 40), (11, 50), (22, 46), (28, 43),+ (28, 8), (32, 28), (32, 39), (32, 42), (40, 22), (40, 47), (43, 11),+ (43, 17)+ ]++sceneWindow :: Scene -> IO ()+sceneWindow sc =+ play (InWindow "Graph Drawing - middle mouse button to drag" (640, 480) (10, 10))+ black 30 sc drawScene handleEvent updatePositions++main :: IO ()+main =+ do gen <- getStdGen+ sceneWindow (fromEdges gen sampleGraph)
picture/Styrene/Advance.hs view
@@ -33,7 +33,7 @@ advanceWorld viewport time (World actors tree) = let rot = viewPortRotate viewport- force = rotateV (degToRad $ negate rot) (0, negate gravityCoeff)+ force = rotateV (degToRad rot) (0, negate gravityCoeff) -- move all the actors actors_moved = Map.map (moveActor_free time force) actors
picture/Styrene/Main.hs view
@@ -71,10 +71,6 @@ vel = if showBeadVelocity then Color red $ Line [(0, 0), mulSV 0.1 v] else Blank-{- color- | mode >= beadStuckCount = red- | otherwise = beadColor--} Wall _ p1 p2 -> Color (greyN 0.8) $ Line [p1, p2]