diff --git a/gloss-examples.cabal b/gloss-examples.cabal --- a/gloss-examples.cabal +++ b/gloss-examples.cabal @@ -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 diff --git a/picture/Graph/Main.hs b/picture/Graph/Main.hs new file mode 100644 --- /dev/null +++ b/picture/Graph/Main.hs @@ -0,0 +1,222 @@ +-- See , 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 +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) diff --git a/picture/Styrene/Advance.hs b/picture/Styrene/Advance.hs --- a/picture/Styrene/Advance.hs +++ b/picture/Styrene/Advance.hs @@ -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 diff --git a/picture/Styrene/Main.hs b/picture/Styrene/Main.hs --- a/picture/Styrene/Main.hs +++ b/picture/Styrene/Main.hs @@ -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]