feat: empty space filling alg for arcs on a circle

lunarcast · Apr 12, 2020 · 67e37a6 · 67e37a6
1 parent b0bf340
commit 67e37a6
Show file tree

Hide file tree

Showing 15 changed files with 243 additions and 169 deletions.
diff --git a/.vscode/settings.json b/.vscode/settings.json
@@ -2,7 +2,5 @@
   "editor.formatOnSave": true,
   "purescript.censorWarnings": [
     "ScopeShadowing"
-  ],
-  "discord.workspaceElapsedTime": true,
-  "discord.detailsEditing": "Editing {filename} 🚰"
+  ]
 }
diff --git a/spago.dhall b/spago.dhall
@@ -16,6 +16,7 @@ You can edit this file as you like.
   , "halogen-svg"
   , "halogen-vdom"
   , "lists"
+  , "math"
   , "maybe"
   , "ordered-collections"
   , "profunctor-lenses"

diff --git a/src/Capability/Editor/Node/NodeInput.purs b/src/Capability/Editor/Node/NodeInput.purs
@@ -1,9 +1,22 @@
-module Lunarbox.Capability.Editor.Node.NodeInput (Arc(..), solveOverlaps) where
+module Lunarbox.Capability.Editor.Node.NodeInput
+  ( Arc(..)
+  , solveOverlaps
+  , emptySpaces
+  , length
+  , fillWith
+  ) where
 
 import Prelude
 import Control.MonadZero (guard)
-import Data.List (List(..), nub, (:))
+import Data.Foldable (minimumBy)
+import Data.Int (ceil, toNumber)
+import Data.List (List(..), catMaybes, nub, (..), zip, (:))
+import Data.List as List
+import Data.Maybe (Maybe)
+import Data.Tuple (Tuple(..), fst)
 import Lunarbox.Data.Duplet (Duplet(..))
+import Lunarbox.Data.List (chunk)
+import Math (tau)
 
 data Arc a
   = Arc Number Number a
@@ -15,6 +28,9 @@ derive instance functorArc :: Functor Arc
 instance showArc :: Show a => Show (Arc a) where
   show (Arc s e v) = "Arc(" <> show v <> ", [" <> show s <> ", " <> show e <> "])"
 
+length :: forall a. Arc a -> Number
+length (Arc start end _) = let delta = end - start in if end > start then delta else tau + delta
+
 -- Credit: https://stackoverflow.com/a/11776964/11012369
 intersect :: Number -> Number -> Number -> Boolean
 intersect b as ae = (as > ae && (b >= as || b <= ae)) || (b >= as && b <= ae)
@@ -28,16 +44,16 @@ intersect' (Arc s e _) (Arc s' e' _) =
     || intersect e s' e'
 
 -- Get all overlaps between some arcs
-colleceIntersections :: forall a. Eq a => List (Arc a) -> List (Arc a)
-colleceIntersections arcs =
+collectIntersections :: forall a. Eq a => List (Arc a) -> List (Arc a)
+collectIntersections arcs =
   nub do
     a <- arcs
     a' <- arcs
     guard $ a /= a' && intersect' a a'
     a : a' : Nil
 
 moveIntersections :: forall a. Ord a => List (Arc a) -> Duplet (List (Arc a))
-moveIntersections arcs = case colleceIntersections arcs of
+moveIntersections arcs = case collectIntersections arcs of
   arc : xs -> case moveIntersections xs of
     Duplet o os -> Duplet (arc : o) os
   Nil -> Duplet Nil arcs
@@ -46,3 +62,58 @@ solveOverlaps :: forall a. Ord a => List (Arc a) -> List (List (Arc a))
 solveOverlaps arcs = case moveIntersections arcs of
   Duplet Nil a -> pure a
   Duplet a as -> (solveOverlaps a) <> pure as
+
+-- Find the closest arc to the end of a given arc
+closestArcStart :: forall a. Ord a => List (Arc a) -> Arc a -> Maybe (Arc a)
+closestArcStart arcs target@(Arc targetStart _ _) = fst <$> minimumBy (\(Tuple _ delta) (Tuple _ delta') -> compare delta delta') deltas
+  where
+  withoutTarget = List.delete target arcs
+
+  deltas =
+    ( \arc@(Arc start _ _) ->
+        Tuple arc
+          $ let
+              delta = start - targetStart
+            in
+              if start > targetStart then delta else tau + delta
+    )
+      <$> withoutTarget
+
+-- Given a list of arcs returns the empty space on the circle
+-- This function assumes the arcs do not overlap
+emptySpaces :: forall a. Ord a => List (Arc a) -> List (Arc Unit)
+emptySpaces Nil = pure $ Arc 0.0 tau unit
+
+emptySpaces arcs =
+  catMaybes
+    $ ( \arc@(Arc _ end _) ->
+          (\(Arc start _ _) -> Arc end start unit) <$> closestArcStart arcs arc
+      )
+    <$> arcs
+
+-- Given a list of arcs get the empty spaces and fill them with arcs generated from another list of arcs
+fillWith :: forall a. Ord a => List a -> List (Arc a) -> List (Arc a)
+fillWith arcs toFill =
+  let
+    spaces = emptySpaces toFill
+
+    chunkSize = ceil $ (toNumber $ List.length arcs) / (toNumber $ List.length spaces)
+
+    range = 0 .. (chunkSize - 1)
+
+    filled =
+      (zip spaces $ chunk chunkSize arcs)
+        >>= ( \(Tuple arc keys) ->
+              let
+                arcLength = length arc / (toNumber $ List.length keys)
+              in
+                zip range keys
+                  <#> \(Tuple index key) ->
+                      let
+                        start = toNumber index * arcLength
+                      in
+                        Arc start (start + arcLength) key
+          )
+  in
+    filled
+      <> toFill
diff --git a/src/Component/Editor.purs b/src/Component/Editor.purs
@@ -5,6 +5,7 @@ import Control.Monad.Reader (class MonadReader)
 import Control.Monad.State (get, gets, modify_)
 import Control.MonadZero (guard)
 import Data.Array as Array
+import Data.Default (def)
 import Data.Either (Either(..))
 import Data.Foldable (for_, sequence_, traverse_)
 import Data.Lens (Lens', Traversal', over, preview, set, view)
@@ -196,7 +197,7 @@ component =
               modify_
                 $ set (_stateAtProjectNode currentFunction id)
                 $ Just
-                $ Tuple node mempty
+                $ Tuple node def
       handleAction Compile
     ChangeTab newTab -> do
       oldTab <- gets $ view _currentTab
@@ -209,7 +210,7 @@ component =
       void $ query (SProxy :: _ "scene") unit $ tell Scene.BeforeFunctionChanging
     CreateFunction name -> do
       id <- createId
-      modify_ $ over _project $ createFunction mempty mempty name id
+      modify_ $ over _project $ createFunction def def name id
     StartFunctionCreation -> do
       void $ query (SProxy :: _ "tree") unit $ tell TreeC.StartCreation
     SelectFunction name -> do

diff --git a/src/Component/Editor/Add.purs b/src/Component/Editor/Add.purs
@@ -9,14 +9,12 @@ module Lunarbox.Component.Editor.Add
 import Prelude
 import Control.Monad.Reader (class MonadAsk)
 import Control.MonadZero (guard)
-import Data.Int (toNumber)
-import Data.Lens (Lens', view)
+import Data.Default (def)
+import Data.Lens (Lens')
 import Data.Lens.Record (prop)
 import Data.Maybe (Maybe(..))
 import Data.Symbol (SProxy(..))
 import Data.Tuple (Tuple(..))
-import Data.Typelevel.Num (d0, d1)
-import Data.Vec ((!!))
 import Effect.Class (class MonadEffect)
 import Halogen (ClassName(..), Component, HalogenM, Slot, defaultEval, mkComponent, mkEval, put, raise)
 import Halogen.HTML (slot)
@@ -27,7 +25,8 @@ import Lunarbox.Component.Editor.Node as NodeC
 import Lunarbox.Component.Icon (icon)
 import Lunarbox.Component.Utils (className, container)
 import Lunarbox.Config (Config)
-import Lunarbox.Data.Editor.FunctionData (FunctionData, _FunctionDataScale)
+import Lunarbox.Data.Editor.Constants (nodeRadius)
+import Lunarbox.Data.Editor.FunctionData (FunctionData)
 import Lunarbox.Data.Editor.FunctionName (FunctionName)
 import Lunarbox.Data.Editor.Node (Node(..))
 import Lunarbox.Data.Editor.Node.NodeData (NodeData)
@@ -68,10 +67,11 @@ type Input
 nodeInput :: FunctionName -> FunctionData -> NodeC.Input
 nodeInput name functionData =
   { selectable: false
-  , nodeData: mempty
+  , nodeData: def
   , node: ComplexNode { inputs: mempty, function: name }
   , functionData
   , labels: mempty
+  , hasOutput: false
   }
 
 component :: forall m. MonadEffect m => MonadAsk Config m => Component HH.HTML Query Input Output m
@@ -94,45 +94,40 @@ component =
     SetState state -> put state
 
   makeNode (Tuple { functionData, name } { isUsable, isEditable }) =
-    let
-      scale = view _FunctionDataScale functionData
-
-      side = toNumber $ max (scale !! d0) (scale !! d1)
-    in
-      HH.div [ className "node" ]
-        [ SE.svg
-            [ SA.width 75.0
-            , SA.height 75.0
-            , SA.viewBox 0.0 0.0 side side
-            ]
-            [ slot
-                (SProxy :: _ "node")
-                name
-                NodeC.component
-                (nodeInput name functionData)
-                $ const Nothing
-            ]
-        , container "node-data"
-            [ container "node-text"
-                [ container "node-name"
-                    [ HH.text $ show name
-                    ]
-                ]
-            , container "node-buttons"
-                [ HH.div
-                    [ HP.classes $ ClassName <$> ("active" <$ guard isUsable)
-                    , onClick $ const $ guard isUsable $> AddNode name
-                    ]
-                    [ icon "add" ]
-                , HH.div
-                    [ HP.classes $ ClassName <$> ("active" <$ guard isEditable)
-                    , onClick $ const $ guard isEditable $> SelectFunction name
-                    ]
-                    [ icon "edit"
-                    ]
-                ]
-            ]
-        ]
+    HH.div [ className "node" ]
+      [ SE.svg
+          [ SA.width 75.0
+          , SA.height 75.0
+          , SA.viewBox (-nodeRadius) (-nodeRadius) (nodeRadius * 2.0) (nodeRadius * 2.0)
+          ]
+          [ slot
+              (SProxy :: _ "node")
+              name
+              NodeC.component
+              (nodeInput name functionData)
+              $ const Nothing
+          ]
+      , container "node-data"
+          [ container "node-text"
+              [ container "node-name"
+                  [ HH.text $ show name
+                  ]
+              ]
+          , container "node-buttons"
+              [ HH.div
+                  [ HP.classes $ ClassName <$> ("active" <$ guard isUsable)
+                  , onClick $ const $ guard isUsable $> AddNode name
+                  ]
+                  [ icon "add" ]
+              , HH.div
+                  [ HP.classes $ ClassName <$> ("active" <$ guard isEditable)
+                  , onClick $ const $ guard isEditable $> SelectFunction name
+                  ]
+                  [ icon "edit"
+                  ]
+              ]
+          ]
+      ]
 
   render { project, currentFunction } =
     container "nodes"

diff --git a/src/Component/Editor/Node.purs b/src/Component/Editor/Node.purs
@@ -20,7 +20,8 @@ import Halogen (Component, HalogenM, defaultEval, gets, mkComponent, mkEval, mod
 import Halogen.HTML (HTML)
 import Halogen.HTML as HH
 import Halogen.HTML.Events (onMouseDown)
-import Lunarbox.Data.Editor.FunctionData (FunctionData(..))
+import Lunarbox.Data.Editor.Constants (nodeRadius)
+import Lunarbox.Data.Editor.FunctionData (FunctionData)
 import Lunarbox.Data.Editor.Node (Node)
 import Lunarbox.Data.Editor.Node.NodeData (NodeData(..), _NodeDataPosition, _NodeDataSelected, _NodeDataZPosition)
 import Lunarbox.Data.Vector (Vec2)
@@ -35,6 +36,7 @@ type State
     , selectable :: Boolean
     , functionData :: FunctionData
     , labels :: Array (Maybe String)
+    , hasOutput :: Boolean
     }
 
 -- Lenses
@@ -75,6 +77,15 @@ data Output
 type Input
   = State
 
+output :: forall r. Boolean -> HTML r Action
+output false = HH.text ""
+
+output true =
+  SE.circle
+    [ SA.r 10.0
+    , SA.fill $ Just $ SA.RGB 118 255 0
+    ]
+
 component :: forall m. MonadEffect m => Component HH.HTML Query Input Output m
 component =
   mkComponent
@@ -121,40 +132,38 @@ component =
           ( \index elem ->
               SE.g
                 [ SA.transform
-                    [ SA.Translate 0.0 $ toNumber $ (index + 1) * -20
+                    [ SA.Translate 0.0 $ -nodeRadius + (toNumber $ (index + 1) * -20)
                     ]
                 ]
                 [ elem ]
           )
       <<< catMaybes
 
-  label scale text =
+  label text =
     SE.text
       [ SA.text_anchor AnchorMiddle
-      , SA.x $ toNumber $ scale !! d0 / 2
       , SA.fill $ Just $ SA.RGB 63 196 255
       ]
       [ HH.text text ]
 
   render { selectable
-  , functionData: FunctionData { image, scale }
   , nodeData: NodeData { position, selected }
   , labels
+  , hasOutput
   } =
     SE.g
       [ SA.transform
           [ SA.Translate (position !! d0) (position !! d1) ]
       , onMouseDown $ const $ if selectable then Just $ SetSelection true else Nothing
       ]
       [ SE.circle
-          [ SA.r $ toNumber $ scale !! d0 / 2 - 5
-          , SA.cx $ toNumber $ scale !! d0 / 2
-          , SA.cy $ toNumber $ scale !! d0 / 2
+          [ SA.r nodeRadius
           , SA.fill $ Just $ SA.RGBA 0 0 0 0.0
           , SA.stroke $ Just $ if (selected && selectable) then SA.RGB 118 255 2 else SA.RGB 63 196 255
           , strokeWidth 5.0
           ]
       , overlays
-          $ (label scale <$> _)
+          $ (label <$> _)
           <$> labels
+      , output hasOutput
       ]