Merge pull request #24 from Mateiadrielrafael/develop

Release

src/Capability/Editor/Node/NodeInput.purs → src/Capability/Editor/Node/Arc.purs

@@ -1,36 +1,57 @@
-module Lunarbox.Capability.Editor.Node.NodeInput
+module Lunarbox.Capability.Editor.Node.Arc
   ( Arc(..)
   , solveOverlaps
   , emptySpaces
   , length
   , fillWith
+  , normalize
+  , rotate
+  , full
   ) where
 
 import Prelude
 import Control.MonadZero (guard)
 import Data.Foldable (minimumBy)
+import Data.Generic.Rep (class Generic)
+import Data.Generic.Rep.Show (genericShow)
 import Data.Int (ceil, toNumber)
-import Data.List (List(..), catMaybes, nub, (..), zip, (:))
+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.Functor (indexed)
 import Lunarbox.Data.List (chunk)
+import Lunarbox.Data.Math (normalizeAngle)
 import Math (Radians, tau)
 
+-- Data structure representing an arc on a circle
+-- The arc also holds an inner value of any type
 data Arc a
   = Arc Radians Radians a
 
+-- Typeclass instances
 derive instance eqArc :: Eq a => Eq (Arc a)
 
 derive instance functorArc :: Functor Arc
 
+derive instance genericArc :: Generic (Arc a) _
+
 instance showArc :: Show a => Show (Arc a) where
-  show (Arc s e v) = "Arc(" <> show v <> ", [" <> show s <> ", " <> show e <> "])"
+  show = genericShow
 
-length :: forall a. Arc a -> Number
+-- Get the length of an arc in radians
+length :: forall a. Arc a -> Radians
 length (Arc start end _) = let delta = end - start in if end > start then delta else tau + delta
 
+-- Normalize angles bigger than 2 pi
+normalize :: forall a. Arc a -> Arc a
+normalize (Arc start end inner) = Arc (normalizeAngle start) (normalizeAngle end) inner
+
+-- Rotate an arc by a number of radians
+rotate :: forall a. Radians -> Arc a -> Arc a
+rotate amount (Arc start end inner) = normalize $ Arc (start + amount) (end + amount) inner
+
 -- 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)
@@ -43,6 +64,10 @@ intersect' (Arc s e _) (Arc s' e' _) =
     || intersect s s' e'
     || intersect e s' e'
 
+-- Construct a full circle containing an arbitrary value
+full :: forall a. a -> Arc a
+full = Arc 0.0 (tau - 0.00001)
+
 -- Get all overlaps between some arcs
 collectIntersections :: forall a. Eq a => List (Arc a) -> List (Arc a)
 collectIntersections arcs =
@@ -82,7 +107,9 @@ closestArcStart arcs target@(Arc targetStart _ _) = fst <$> minimumBy (\(Tuple _
 -- 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 Nil = pure $ full unit
+
+emptySpaces ((Arc start end _) : Nil) = pure $ Arc end start unit
 
 emptySpaces arcs =
   catMaybes
@@ -93,27 +120,22 @@ emptySpaces 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
+fillWith arcs toFill = filled <> toFill
+  where
+  spaces = normalize <$> emptySpaces toFill
+
+  chunkSize = ceil $ (toNumber $ List.length arcs) / (toNumber $ List.length spaces)
+
+  filled =
+    (zip spaces $ chunk chunkSize arcs)
+      >>= ( \(Tuple arc@(Arc spaceStart _ _) keys) ->
+            let
+              arcLength = length arc / (toNumber $ List.length keys)
+            in
+              indexed keys
+                <#> \(Tuple index key) ->
+                    let
+                      start = spaceStart + toNumber index * arcLength
+                    in
+                      Arc start (start + arcLength) key
+        )

src/Capability/Editor/Type.purs

@@ -73,14 +73,15 @@ pinLocations :: FunctionData -> Node -> List.List Pin
 pinLocations functionData node = (OutputPin <$ guard (hasOutput node)) <> inputPins functionData
 
 -- Create a location-color pair from a node and data related to it
-generateColorPair :: Pin -> Type -> Either ColoringError (Tuple Pin Color)
-generateColorPair currentLocation pinType = do
+generateColor :: Pin -> Type -> Either ColoringError Color
+generateColor currentLocation pinType = do
   color <- case pinType of
     TVarariable name' -> Right $ RGB shade shade shade
       where
       shade = seededInt (show name') 100 255
+    TArrow from to -> combineColors <$> generateColor currentLocation from <*> generateColor currentLocation to
     other -> note (UnableToColor other) $ typeToColor other
-  pure $ Tuple currentLocation color
+  pure color
 
 -- Createa a typeMap from a node and data about it
 generateTypeMap :: (Pin -> Maybe Type) -> FunctionData -> Node -> Either ColoringError (Map.Map Pin Color)
@@ -89,7 +90,7 @@ generateTypeMap getType functionData node = Map.fromFoldable <$> pairs
   pairs =
     ( sequence
         $ List.catMaybes
-        $ (\pin -> generateColorPair pin <$> getType pin)
+        $ (\pin -> (map $ Tuple pin) <$> generateColor pin <$> getType pin)
         <$> pinLocations functionData node
     )
 

src/Component/Editor.purs

@@ -27,8 +27,7 @@ import Lunarbox.Component.Editor.Tree as TreeC
 import Lunarbox.Component.Icon (icon)
 import Lunarbox.Component.Utils (container)
 import Lunarbox.Config (Config)
-import Lunarbox.Control.Monad.Dataflow.Solve.SolveExpression (printTypeMap)
-import Lunarbox.Control.Monad.Effect (print, printString)
+import Lunarbox.Control.Monad.Effect (printString)
 import Lunarbox.Data.Dataflow.Class.Expressible (nullExpr)
 import Lunarbox.Data.Dataflow.Expression (printSource)
 import Lunarbox.Data.Dataflow.Native.Prelude (loadPrelude)
@@ -41,7 +40,7 @@ import Lunarbox.Data.Editor.Node.NodeDescriptor (onlyEditable)
 import Lunarbox.Data.Editor.Node.NodeId (NodeId(..))
 import Lunarbox.Data.Editor.Node.PinLocation (Pin(..))
 import Lunarbox.Data.Editor.Project (_projectNodeGroup, createFunction, emptyProject)
-import Lunarbox.Data.Editor.State (State, Tab(..), _atColorMap, _atCurrentNode, _atNode, _atNodeData, _currentFunction, _currentTab, _expression, _function, _functions, _isSelected, _lastMousePosition, _nextId, _nodeData, _panelIsOpen, _partialFrom, _partialTo, _project, _typeMap, compile, tabIcon, tryConnecting)
+import Lunarbox.Data.Editor.State (State, Tab(..), _atColorMap, _atNode, _atNodeData, _currentFunction, _currentTab, _expression, _function, _functions, _isSelected, _lastMousePosition, _nextId, _nodeData, _panelIsOpen, _partialFrom, _partialTo, _project, _typeMap, compile, tabIcon, tryConnecting)
 import Lunarbox.Data.Graph as G
 import Lunarbox.Data.Vector (Vec2)
 import Lunarbox.Page.Editor.EmptyEditor (emptyEditor)
@@ -106,7 +105,6 @@ component =
     LoadNodes -> do
       modify_ $ compile <<< loadPrelude
     CreateNode name -> do
-      print "here:)"
       Tuple id setId <- createId
       typeMap <- gets $ view _typeMap
       maybeCurrentFunction <- gets $ view _currentFunction
@@ -193,21 +191,15 @@ component =
       for_ maybeCurrentFunction \currentFunction -> do
         modify_ $ set (_isSelected currentFunction id) true
     SelectInput id index -> do
-      s <- gets $ view _partialTo
       let
         setTo = set _partialTo $ Just $ Tuple id index
-      print s
       modify_ $ tryConnecting <<< setTo
     SelectOutput id -> do
       let
         setFrom = set _partialFrom $ Just id
       modify_ $ tryConnecting <<< setFrom
-      s <- gets $ view _typeMap
       e <- gets $ view _expression
-      s' <- gets $ preview $ _atCurrentNode $ NodeId "firstOutput"
-      printString $ printTypeMap s
       printString $ printSource e
-      print s'
 
   handleTreeOutput :: TreeC.Output -> Maybe Action
   handleTreeOutput = case _ of

src/Component/Editor/Add.purs

@@ -10,18 +10,19 @@ import Data.List ((!!))
 import Data.Map as Map
 import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Tuple (Tuple(..))
+import Data.Unfoldable (replicate)
 import Halogen (ClassName(..))
 import Halogen.HTML (HTML)
 import Halogen.HTML as HH
 import Halogen.HTML.Events (onClick)
 import Halogen.HTML.Properties as HP
 import Lunarbox.Capability.Editor.Type (generateTypeMap, prettify)
 import Lunarbox.Component.Editor.HighlightedType (highlightTypeToHTML)
-import Lunarbox.Component.Editor.Node (node)
+import Lunarbox.Component.Editor.Node (renderNode)
 import Lunarbox.Component.Editor.Node as NodeC
 import Lunarbox.Component.Icon (icon)
 import Lunarbox.Component.Utils (className, container)
-import Lunarbox.Data.Dataflow.Type (Type, inputs, output)
+import Lunarbox.Data.Dataflow.Type (Type, inputs, numberOfInputs, output)
 import Lunarbox.Data.Editor.Constants (arcWidth, nodeRadius)
 import Lunarbox.Data.Editor.ExtendedLocation (ExtendedLocation(..))
 import Lunarbox.Data.Editor.FunctionData (FunctionData)
@@ -59,6 +60,7 @@ nodeInput typeMap name functionData =
   , functionData
   , labels: mempty
   , hasOutput: hasOutput node
+  , nodeDataMap: mempty
   , colorMap:
     either (const mempty) identity
       $ generateTypeMap
@@ -67,7 +69,13 @@ nodeInput typeMap name functionData =
           node
   }
   where
-  node = ComplexNode { inputs: mempty, function: name }
+  inputCount = fromMaybe 0 $ numberOfInputs <$> Map.lookup (Location name) typeMap
+
+  node =
+    ComplexNode
+      { inputs: replicate inputCount Nothing
+      , function: name
+      }
 
 makeNode :: forall h a. Actions a -> NodeDescriptor -> FunctionName -> Map.Map Location Type -> FunctionData -> HTML h a
 makeNode { edit, addNode } { isUsable, isEditable } name typeMap functionData =
@@ -77,7 +85,7 @@ makeNode { edit, addNode } { isUsable, isEditable } name typeMap functionData =
         , SA.height 75.0
         , let size = arcWidth + nodeRadius in SA.viewBox (-size) (-size) (2.0 * size) (2.0 * size)
         ]
-        [ node
+        [ renderNode
             (nodeInput typeMap name functionData)
             { select: Nothing
             , selectOutput: Nothing

src/Component/Editor/Edge.purs

@@ -0,0 +1,34 @@
+module Lunarbox.Component.Editor.Edge
+  ( renderEdge
+  , Input
+  ) where
+
+import Prelude
+import Data.Maybe (Maybe(..))
+import Data.Typelevel.Num (d0, d1)
+import Data.Vec ((!!))
+import Halogen.HTML (HTML)
+import Lunarbox.Data.Editor.Constants (connectionsWidth)
+import Lunarbox.Data.Vector (Vec2)
+import Lunarbox.Svg.Attributes (strokeWidth)
+import Svg.Attributes (Color)
+import Svg.Attributes as SA
+import Svg.Elements as SE
+
+type Input
+  = { from :: Vec2 Number
+    , to :: Vec2 Number
+    , color :: Color
+    }
+
+-- Used to render the connections between nodes
+renderEdge :: forall h a. Input -> HTML h a
+renderEdge { from, to, color } =
+  SE.line
+    [ SA.x1 $ from !! d0
+    , SA.y1 $ from !! d1
+    , SA.x2 $ to !! d0
+    , SA.y2 $ to !! d1
+    , SA.stroke $ Just color
+    , strokeWidth connectionsWidth
+    ]

src/Component/Editor/HighlightedType.purs

@@ -20,10 +20,16 @@ highlightedType :: forall h a. (Array (HH.HTML h a) -> HH.HTML h a) -> (Color ->
 highlightedType container highlight defaultColor = case _ of
   TArrow from to ->
     container
-      [ highlightedType container highlight defaultColor from
+      [ if isArrow then container [ HH.text "(", result, HH.text ")" ] else result
       , HH.text " -> "
       , highlightedType container highlight defaultColor to
       ]
+    where
+    isArrow = case from of
+      TArrow _ _ -> true
+      _ -> false
+
+    result = highlightedType container highlight defaultColor from
   TVarariable name' -> highlight (RGB shade shade shade) $ HH.text $ show name'
     where
     shade = seededInt (show name') 100 255