Created
November 25, 2023 23:48
-
-
Save axelerator/36a037d4f9418ca24f1207e18e2e53b1 to your computer and use it in GitHub Desktop.
Dynamic Diagrams
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| -- https://blog.axelerator.de/development/en/liquid-diagrams | |
| module Main exposing (main) | |
| import Maybe.Extra | |
| import Vector2d | |
| import Dict | |
| import Axis2d | |
| import Browser | |
| import Browser.Events exposing (onAnimationFrameDelta) | |
| import Html exposing (Html, button, details, div, input, p, text, textarea) | |
| import Html.Attributes exposing (name, rows, style, type_, value) | |
| import Html.Events exposing (onClick, onInput) | |
| import Parser | |
| exposing | |
| ( (|.) | |
| , (|=) | |
| , Parser | |
| , Step(..) | |
| , andThen | |
| , chompUntil | |
| , chompWhile | |
| , deadEndsToString | |
| , getChompedString | |
| , loop | |
| , map | |
| , oneOf | |
| , run | |
| , succeed | |
| , symbol | |
| , token | |
| ) | |
| import Point2d exposing (Point2d) | |
| import Quantity exposing (Unitless) | |
| import String exposing (fromFloat, fromInt, toInt) | |
| import Svg exposing (defs, g, marker, path, rect, svg, textPath, text_) | |
| import Svg.Attributes as SA exposing (from, opacity, to) | |
| import Vector2d | |
| import Html exposing (br) | |
| main : Program String Model Msg | |
| main = | |
| Browser.element | |
| { init = init | |
| , update = update | |
| , subscriptions = subscriptions | |
| , view = view | |
| } | |
| type Msg | |
| = PrevFrame | |
| | NextFrame | |
| | Step Float | |
| | Jump String | |
| | UpdateSrc String | |
| | Compile String | |
| | Edit | |
| type alias Model = | |
| { diagramState : DiagramState | |
| , src : String | |
| , error : String | |
| , edit : Bool | |
| } | |
| init : String -> ( Model, Cmd Msg ) | |
| init src = | |
| let | |
| diagram = | |
| case run instructionParser src of | |
| Ok instructions -> | |
| mkDiagram instructions | |
| Err _ -> | |
| emptyDiagram | |
| in | |
| ( { diagramState = initState diagram | |
| , src = src | |
| , error = "" | |
| , edit = False | |
| } | |
| , Cmd.none | |
| ) | |
| update : Msg -> Model -> ( Model, Cmd msg ) | |
| update msg model = | |
| case msg of | |
| Edit -> | |
| ( { model | edit = True } | |
| , Cmd.none | |
| ) | |
| PrevFrame -> | |
| ( { model | diagramState = prev model.diagramState } | |
| , Cmd.none | |
| ) | |
| NextFrame -> | |
| ( { model | diagramState = next model.diagramState } | |
| , Cmd.none | |
| ) | |
| Jump frame -> | |
| case toInt frame of | |
| Just frameIdx -> | |
| ( { model | diagramState = jump frameIdx model.diagramState } | |
| , Cmd.none | |
| ) | |
| Nothing -> | |
| ( model | |
| , Cmd.none | |
| ) | |
| Step delta -> | |
| ( { model | diagramState = step delta model.diagramState } | |
| , Cmd.none | |
| ) | |
| UpdateSrc newSrc -> | |
| ( { model | |
| | src = newSrc | |
| , error = "" | |
| } | |
| , Cmd.none | |
| ) | |
| Compile trySrc -> | |
| let | |
| ( diagramState, error , edit) = | |
| case run instructionParser trySrc of | |
| Ok instructions -> | |
| let | |
| newState = | |
| initState <| mkDiagram instructions | |
| in | |
| ( jump model.diagramState.currentFrame newState | |
| , "" | |
| , False | |
| ) | |
| Err deadEnds -> | |
| ( model.diagramState | |
| , deadEndsToString deadEnds | |
| , True | |
| ) | |
| in | |
| ( { model | diagramState = diagramState, error = error, edit = edit } | |
| , Cmd.none | |
| ) | |
| view : Model -> Html Msg | |
| view model = | |
| if not model.edit then | |
| div [] | |
| [ viewDiagram model.diagramState | |
| , div [ style "display" "flex" ] | |
| [ button [ onClick PrevFrame ] [ text "⬅" ] | |
| , input | |
| [ type_ "range" | |
| , Html.Attributes.max <| fromInt <| (List.length model.diagramState.diagram.keyframes - 1) | |
| , onInput Jump | |
| , value <| fromInt model.diagramState.currentFrame | |
| ] | |
| [ text "frame" ] | |
| , button [ onClick NextFrame ] [ text "➡" ] | |
| , button [ onClick Edit] [text "✏️"] | |
| ] | |
| ] | |
| else | |
| div [] | |
| [ if model.error == "" then | |
| text "" | |
| else | |
| div [] [ text model.error ] | |
| , textarea [ value model.src, rows 10, onInput UpdateSrc ] [] | |
| , br [] [] | |
| , button [ onClick <| Compile model.src ] [ text "compile" ] | |
| ] | |
| subscriptions : Model -> Sub Msg | |
| subscriptions model = | |
| if isAnimating model.diagramState then | |
| onAnimationFrameDelta Step | |
| else | |
| Sub.none | |
| type alias Keyframe = | |
| { objects : List Object } | |
| type alias Diagram = | |
| { keyframes : List Keyframe | |
| } | |
| type ConnectionId | |
| = ImplicitConnectionId String | |
| | NamedConnection String | |
| type alias ConnectionEnd = | |
| { name: String | |
| , optionalSide : Maybe Side | |
| } | |
| type Object | |
| = Object { name : String, properties : Properties } | |
| | Connection | |
| { from : ConnectionEnd | |
| , to : ConnectionEnd | |
| , visible : Bool | |
| , id : ConnectionId | |
| , label : Maybe String | |
| } | |
| type alias ObjectTransitionDetails = | |
| { name : String | |
| , from : Properties | |
| , to : Properties | |
| } | |
| type Transition | |
| = ObjectTransistion ObjectTransitionDetails | |
| | ConnectionTransition | |
| { origin : ConnectionEnd | |
| , target : ConnectionEnd | |
| , id : ConnectionId | |
| , label : Maybe String | |
| , connectionVisibility : ConnectionVisibility | |
| } | |
| type alias DiagramState = | |
| { diagram : Diagram | |
| , t : Float | |
| , currentFrame : Int | |
| , transitions : List Transition | |
| } | |
| mkTransition : Object -> List Transition -> List Transition | |
| mkTransition object ts = | |
| case object of | |
| Object { name, properties } -> | |
| let | |
| t = | |
| ObjectTransistion | |
| { name = name | |
| , from = properties | |
| , to = properties | |
| } | |
| in | |
| t :: ts | |
| Connection { id, label, from, to, visible } -> | |
| let | |
| trans = | |
| ConnectionTransition | |
| { connectionVisibility = | |
| if visible then | |
| Connected | |
| else | |
| Disconnected | |
| , origin = from | |
| , target = to | |
| , id = id | |
| , label = label | |
| } | |
| in | |
| trans :: ts | |
| initState : Diagram -> DiagramState | |
| initState diagram = | |
| let | |
| transitions = | |
| case List.head diagram.keyframes of | |
| Just { objects } -> | |
| List.foldr mkTransition [] objects | |
| Nothing -> | |
| [] | |
| in | |
| { diagram = diagram | |
| , t = 0.0 | |
| , currentFrame = 0 | |
| , transitions = transitions | |
| } | |
| redirect : ( Transition, Object ) -> Transition | |
| redirect tpl = | |
| case tpl of | |
| ( ObjectTransistion ots, Object targetObj ) -> | |
| ObjectTransistion | |
| { ots | |
| | to = targetObj.properties | |
| , from = ots.to | |
| } | |
| ( ConnectionTransition cts, Connection { visible } ) -> | |
| ConnectionTransition | |
| { origin = cts.origin | |
| , target = cts.target | |
| , id = cts.id | |
| , label = cts.label | |
| , connectionVisibility = | |
| case (cts.connectionVisibility, visible) of | |
| (Disconnected, False) -> Disconnected | |
| (Connecting, False) -> Disconnecting | |
| (Connected, False) -> Disconnecting | |
| (Disconnecting, False) -> Disconnected | |
| (Disconnected, True) -> Connecting | |
| (Connecting, True) -> Connected | |
| (Connected, True) -> Connected | |
| (Disconnecting, True) -> Connecting | |
| } | |
| _ -> | |
| Tuple.first tpl | |
| prev : DiagramState -> DiagramState | |
| prev state = | |
| if state.currentFrame > 0 then | |
| let | |
| nextFrameIdx = | |
| state.currentFrame - 1 | |
| transitions = | |
| case List.head <| List.drop nextFrameIdx <| state.diagram.keyframes of | |
| Just keyframe -> | |
| List.map redirect <| List.map2 Tuple.pair state.transitions keyframe.objects | |
| Nothing -> | |
| state.transitions | |
| in | |
| { state | |
| | t = 1.0 | |
| , currentFrame = nextFrameIdx | |
| , transitions = transitions | |
| } | |
| else | |
| state | |
| jump : Int -> DiagramState -> DiagramState | |
| jump frame state = | |
| if frame >= 0 && frame < List.length state.diagram.keyframes then | |
| let | |
| transitions = | |
| case List.head <| List.drop frame <| state.diagram.keyframes of | |
| Just { objects } -> | |
| List.map redirect <| List.map2 Tuple.pair state.transitions objects | |
| Nothing -> | |
| state.transitions | |
| in | |
| { state | |
| | t = 1.0 | |
| , currentFrame = frame | |
| , transitions = transitions | |
| } | |
| else | |
| state | |
| next : DiagramState -> DiagramState | |
| next state = | |
| if (state.currentFrame + 1) < List.length state.diagram.keyframes then | |
| let | |
| nextFrameIdx = | |
| state.currentFrame + 1 | |
| transitions = | |
| case List.head <| List.drop nextFrameIdx <| state.diagram.keyframes of | |
| Just { objects } -> | |
| List.map redirect <| List.map2 Tuple.pair state.transitions objects | |
| Nothing -> | |
| state.transitions | |
| in | |
| { state | |
| | t = 1.0 | |
| , currentFrame = nextFrameIdx | |
| , transitions = transitions | |
| } | |
| else | |
| state | |
| step : Float -> DiagramState -> DiagramState | |
| step millis state = | |
| { state | t = max 0 (state.t - (millis * 0.003)) } | |
| isAnimating : DiagramState -> Bool | |
| isAnimating { t } = | |
| t > 0 | |
| type alias Properties = | |
| { pos : Position | |
| , size : Size | |
| , opacity : Float | |
| } | |
| mkDiagram : List Instruction -> Diagram | |
| mkDiagram is = | |
| let | |
| f i d = | |
| case i of | |
| Add name props -> | |
| addObject name props d | |
| Update name props -> | |
| updateObject name (props) d | |
| MilestoneI -> | |
| newKeyframe d | |
| Connect mbId from mbFromSide to mbToSide mbLabel -> | |
| newConnection from mbFromSide to mbToSide mbId mbLabel d | |
| withInvertedKeyframes = | |
| List.foldl f emptyDiagram is | |
| in | |
| { withInvertedKeyframes | |
| | keyframes = List.reverse withInvertedKeyframes.keyframes | |
| } | |
| newKeyframe : Diagram -> Diagram | |
| newKeyframe diagram = | |
| { diagram | keyframes = List.take 1 diagram.keyframes ++ diagram.keyframes } | |
| newConnection : String -> Maybe Side -> String -> Maybe Side -> Maybe String -> Maybe String -> Diagram -> Diagram | |
| newConnection from mbFromSide to mbToSide mbId mbLabel ({ keyframes } as diagram) = | |
| let | |
| head = | |
| List.take 1 keyframes | |
| tail = | |
| List.drop 1 keyframes | |
| id = | |
| case mbId of | |
| Just name -> | |
| NamedConnection name | |
| Nothing -> | |
| let | |
| sameEndpoints obj = | |
| case obj of | |
| Connection otherConn -> | |
| otherConn.from.name == from && otherConn.to.name == to | |
| _ -> | |
| False | |
| existingConnections = | |
| case head of | |
| [ kf ] -> | |
| List.filter sameEndpoints kf.objects | |
| _ -> | |
| [] | |
| idCounter = | |
| fromInt <| List.length existingConnections | |
| in | |
| ImplicitConnectionId <| from ++ "-" ++ to ++ idCounter | |
| connected = | |
| Connection | |
| { from = { name = from, optionalSide = mbFromSide } | |
| , to = { name = to, optionalSide = mbToSide } | |
| , visible = True | |
| , id = id | |
| , label = mbLabel | |
| } | |
| disconnected = | |
| Connection | |
| { from = { name = from, optionalSide = mbFromSide } | |
| , to = { name = to, optionalSide = mbToSide } | |
| , visible = False | |
| , id = id | |
| , label = mbLabel | |
| } | |
| head_ = | |
| List.map (\frame -> { frame | objects = connected :: frame.objects }) head | |
| tail_ = | |
| List.map (\frame -> { frame | objects = disconnected :: frame.objects }) tail | |
| in | |
| { diagram | keyframes = head_ ++ tail_ } | |
| emptyDiagram : Diagram | |
| emptyDiagram = | |
| let | |
| startFrame = | |
| { objects = [] } | |
| in | |
| { keyframes = [ startFrame ] | |
| } | |
| addObject : String -> List Prop -> Diagram -> Diagram | |
| addObject name props ({ keyframes } as diagram) = | |
| let | |
| head = | |
| List.take 1 keyframes | |
| tail = | |
| List.drop 1 keyframes | |
| object = | |
| newObject name props | |
| hidden = | |
| override [ Opacity 0 ] object | |
| head_ = | |
| List.map (\frame -> { frame | objects = object :: frame.objects }) head | |
| tail_ = | |
| List.map (\frame -> { frame | objects = hidden :: frame.objects }) tail | |
| in | |
| { diagram | keyframes = head_ ++ tail_ } | |
| updateObject : String -> List Prop -> Diagram -> Diagram | |
| updateObject name props ({ keyframes } as diagram) = | |
| let | |
| head = | |
| List.take 1 keyframes | |
| tail = | |
| List.drop 1 keyframes | |
| updateObjects : Object -> Object | |
| updateObjects object = | |
| case object of | |
| (Object o_) as o -> | |
| if o_.name == name then | |
| override props o | |
| else | |
| o | |
| _ -> | |
| object | |
| head_ = | |
| List.map (\frame -> { frame | objects = List.map updateObjects frame.objects }) head | |
| in | |
| { diagram | keyframes = head_ ++ tail } | |
| type WorldCoords | |
| = WorldCoords | |
| type alias Position = | |
| Point2d.Point2d Unitless WorldCoords | |
| type alias Size = | |
| Vector2d.Vector2d Unitless WorldCoords | |
| ofSize : Float -> Float -> Size | |
| ofSize = | |
| Vector2d.unitless | |
| newObject : String -> List Prop -> Object | |
| newObject name props = | |
| let | |
| defaults = | |
| Object | |
| { name = name | |
| , properties = | |
| { pos = at 0 0 | |
| , size = ofSize 1 1 | |
| , opacity = 1.0 | |
| } | |
| } | |
| in | |
| override props defaults | |
| at : Float -> Float -> Position | |
| at = | |
| Point2d.unitless | |
| override : List Prop -> Object -> Object | |
| override props obj = | |
| case obj of | |
| Object object -> | |
| let | |
| f p o = | |
| let | |
| properties = | |
| o.properties | |
| in | |
| case p of | |
| Pos x y -> | |
| { o | properties = { properties | pos = at x y } } | |
| Size w h -> | |
| { o | properties = { properties | size = ofSize w h } } | |
| Opacity op -> | |
| { o | properties = { properties | opacity = op } } | |
| in | |
| Object <| List.foldr f object props | |
| _ -> | |
| obj | |
| viewDiagram : DiagramState -> Html Msg | |
| viewDiagram { t, transitions } = | |
| let | |
| t_ = 1.0 - t | |
| definitions = | |
| defs [] | |
| [ marker | |
| [ SA.id "arrow-head" | |
| , SA.viewBox "0 0 10 10" | |
| , SA.refX "1" | |
| , SA.refY "5" | |
| , SA.markerUnits "strokeWidth" | |
| , SA.markerWidth "3" | |
| , SA.markerHeight "3" | |
| , SA.orient "auto-start-reverse" | |
| ] | |
| [ path [ SA.d "M 0 0 L 10 5 L 0 10 z", SA.fill "white" ] [] ] | |
| ] | |
| objects = Maybe.Extra.values <| List.map (objectInTransition t_) transitions | |
| unorderedConnections_ = Maybe.Extra.values <| List.map (unorderedConnections objects) transitions | |
| orderedConnections = orderConnections unorderedConnections_ | |
| in | |
| svg [ SA.viewBox "-50 -50 100 100" ] | |
| <| | |
| (definitions :: (List.map viewObject objects) ++ (List.map (viewConnection objects t_) orderedConnections)) | |
| viewConnection : List ObjectInTransition -> Float -> OrderedConnection -> Html Msg | |
| viewConnection objects t {origin, originSide, target, targetSide, id, label, quadrant, connectionVisibility} = | |
| let | |
| objectByName_ objectName = | |
| List.head <| List.filter (\o -> o.name == objectName) objects | |
| originObject = | |
| objectByName_ origin | |
| targetObject = | |
| objectByName_ target | |
| in | |
| case ( originObject, targetObject ) of | |
| ( Just originObject_, Just targetObject_ ) -> | |
| let | |
| progress = | |
| case connectionVisibility of | |
| Disconnected -> 0 | |
| Disconnecting -> linear t 1 0 | |
| Connecting -> linear t 0 1 | |
| Connected -> 1 | |
| textOpacity = | |
| fromFloat progress | |
| lineStart_ = | |
| sideN_ False originObject_ originSide | |
| lineEnd_ = | |
| sideN_ True targetObject_ targetSide | |
| between = | |
| Vector2d.from lineStart_ lineEnd_ | |
| c1 = | |
| lineStart_ | |
| |> Point2d.translateBy | |
| (case originSide.side of | |
| Top -> | |
| Vector2d.projectOnto Axis2d.y between | |
| Bottom -> | |
| Vector2d.projectOnto Axis2d.y between | |
| Left -> | |
| Vector2d.projectOnto Axis2d.x between | |
| Right -> | |
| Vector2d.projectOnto Axis2d.x between | |
| ) | |
| between_ = | |
| Vector2d.reverse between | |
| c2 = | |
| lineEnd_ | |
| |> Point2d.translateBy | |
| (case targetSide.side of | |
| Top -> | |
| Vector2d.projectOnto Axis2d.y between_ | |
| Bottom -> | |
| Vector2d.projectOnto Axis2d.y between_ | |
| Left -> | |
| Vector2d.projectOnto Axis2d.x between_ | |
| Right -> | |
| Vector2d.projectOnto Axis2d.x between_ | |
| ) | |
| ps p = | |
| let | |
| { x, y } = | |
| Point2d.unwrap p | |
| in | |
| fromFloat x ++ " " ++ fromFloat y | |
| pps s p = | |
| s ++ " " ++ ps p | |
| ( spline, marker, ( dasharray, dashoffset ) ) = | |
| ( String.join " " | |
| [ pps "M" lineStart_ | |
| , pps "C" c1 | |
| , pps "," c2 | |
| , pps "," lineEnd_ | |
| ] | |
| , SA.markerEnd "url(#arrow-head)" | |
| , ( fromFloat progress ++ " 1" | |
| , "0" | |
| ) | |
| ) | |
| textSide = | |
| case quadrant of | |
| TopLeft -> "right" | |
| TopRight -> "left" | |
| BottomLeft -> "right" | |
| BottomRight -> "left" | |
| connectionId = | |
| case id of | |
| NamedConnection s -> | |
| s | |
| ImplicitConnectionId s -> | |
| "connection-" ++ s | |
| in | |
| g [ SA.id connectionId ] | |
| [ path | |
| [ SA.stroke "white" | |
| , SA.strokeWidth "1" | |
| , SA.d spline | |
| , SA.fill "transparent" | |
| , SA.strokeDasharray dasharray | |
| , SA.strokeDashoffset dashoffset | |
| , SA.id <| "path-" ++ connectionId | |
| , SA.pathLength "1" | |
| , marker | |
| ] | |
| [] | |
| , case label of | |
| Just labelText -> | |
| text_ [ SA.opacity textOpacity, SA.dy "-3" ] | |
| [ textPath | |
| [ SA.xlinkHref <| "#path-" ++ connectionId | |
| , SA.alignmentBaseline "hanging" | |
| , Html.Attributes.attribute "startOffset" "50%" | |
| , Html.Attributes.attribute "side" textSide | |
| , SA.textAnchor "middle" | |
| ] | |
| [ text labelText ] | |
| ] | |
| Nothing -> | |
| text "" | |
| ] | |
| _ -> | |
| text "missing object" | |
| viewObject : ObjectInTransition -> Html Msg | |
| viewObject {props, name} = | |
| let | |
| ( width, height ) = | |
| Vector2d.toTuple Quantity.toFloat props.size | |
| ( x, y ) = | |
| Point2d.toTuple Quantity.toFloat props.pos | |
| in | |
| g | |
| [ SA.opacity <| fromFloat props.opacity | |
| , SA.transform <| "translate(" ++ fromFloat x ++ "," ++ fromFloat y ++ ")" | |
| ] | |
| [ rect | |
| [ SA.width <| fromFloat width | |
| , SA.height <| fromFloat height | |
| ] | |
| [] | |
| , text_ | |
| [ SA.x <| fromFloat <| width * 0.5 | |
| , SA.y <| fromFloat <| height * 0.5 | |
| , SA.textAnchor "middle" | |
| ] | |
| [ text name ] | |
| ] | |
| linear : Float -> Float -> Float -> Float | |
| linear t v0 v1 = | |
| (1.0 - t) * v0 + t * v1 | |
| type alias Point = | |
| Point2d Unitless WorldCoords | |
| linear2d_ : Float -> Point -> Point -> Point | |
| linear2d_ t from to = | |
| let | |
| between = | |
| Vector2d.from from to | |
| scaledBetween = | |
| Vector2d.scaleBy t between | |
| in | |
| Point2d.translateBy scaledBetween from | |
| interpolateSize : Float -> Size -> Size -> Size | |
| interpolateSize t from to = | |
| let | |
| between = | |
| Vector2d.minus from to | |
| in | |
| if from == to then | |
| from | |
| else | |
| Vector2d.plus (Vector2d.scaleBy t between) from | |
| objectByName : List Transition -> String -> Maybe ObjectTransitionDetails | |
| objectByName transitions target = | |
| let | |
| withName t = | |
| case t of | |
| ObjectTransistion { name } -> | |
| name == target | |
| _ -> | |
| False | |
| matchingTransition = | |
| List.head <| List.filter withName transitions | |
| in | |
| case matchingTransition of | |
| Just (ObjectTransistion details) -> | |
| Just details | |
| _ -> | |
| Nothing | |
| type alias ObjectInTransition = | |
| { name: String | |
| , props: Properties | |
| } | |
| objectInTransition : Float -> Transition -> Maybe ObjectInTransition | |
| objectInTransition t transition = | |
| case transition of | |
| ObjectTransistion { name, from, to } -> | |
| let | |
| pos = | |
| linear2d_ t from.pos to.pos | |
| size = | |
| interpolateSize t from.size to.size | |
| opacity = | |
| linear t from.opacity to.opacity | |
| in | |
| Just { name = name | |
| , props = | |
| { pos = pos | |
| , size = size | |
| , opacity = opacity | |
| } | |
| } | |
| _ -> Nothing | |
| type alias UnorderedConnection = | |
| { origin: String | |
| , target: String | |
| , originSide: Side | |
| , targetSide: Side | |
| , label: Maybe String | |
| , quadrant: Quadrant | |
| , connectionVisibility: ConnectionVisibility | |
| } | |
| unorderedConnections : List ObjectInTransition -> Transition -> Maybe UnorderedConnection | |
| unorderedConnections objects transition = | |
| case transition of | |
| ConnectionTransition { id, origin, target, label, connectionVisibility } -> | |
| let | |
| objectByName_ objectName = | |
| List.head <| List.filter (\o -> o.name == objectName) objects | |
| originObject = | |
| objectByName_ origin.name | |
| targetObject = | |
| objectByName_ target.name | |
| visibleAtAll = | |
| case connectionVisibility of | |
| Disconnected -> False | |
| _ -> True | |
| in | |
| case (visibleAtAll, originObject, targetObject) of | |
| (True, Just origin_, Just target_) -> | |
| let | |
| quadrant = | |
| relativeQuadrant origin_.props.pos target_.props.pos | |
| originSize = origin_.props.size | |
| targetSize = target_.props.size | |
| ( originSide, targetSide ) = | |
| case quadrant of | |
| TopRight -> | |
| ( if orientationOf originSize == Portrait then | |
| Right | |
| else | |
| Top | |
| , if orientationOf targetSize == Portrait then | |
| Left | |
| else | |
| Bottom | |
| ) | |
| TopLeft -> | |
| ( if orientationOf originSize == Portrait then | |
| Left | |
| else | |
| Top | |
| , if orientationOf targetSize == Portrait then | |
| Right | |
| else | |
| Bottom | |
| ) | |
| BottomLeft -> | |
| ( if orientationOf originSize == Portrait then | |
| Left | |
| else | |
| Bottom | |
| , if orientationOf targetSize == Portrait then | |
| Right | |
| else | |
| Top | |
| ) | |
| BottomRight -> | |
| ( if orientationOf originSize == Portrait then | |
| Right | |
| else | |
| Bottom | |
| , if orientationOf targetSize == Portrait then | |
| Left | |
| else | |
| Top | |
| ) | |
| originSide_ = | |
| case origin.optionalSide of | |
| Just side -> side | |
| Nothing -> originSide | |
| targetSide_ = | |
| case target.optionalSide of | |
| Just side -> side | |
| Nothing -> targetSide | |
| in | |
| Just | |
| { origin = origin.name | |
| , target = target.name | |
| , originSide = originSide_ | |
| , targetSide = targetSide_ | |
| , label = label | |
| , quadrant = quadrant | |
| , connectionVisibility = connectionVisibility | |
| } | |
| _ -> | |
| Nothing | |
| _ -> | |
| Nothing | |
| type alias SideConnection = | |
| { side: Side | |
| , index: Int | |
| , total: Int | |
| } | |
| type ConnectionVisibility = | |
| Connecting | Connected | Disconnecting | Disconnected | |
| type alias OrderedConnection = | |
| { id: ConnectionId | |
| , label : Maybe String | |
| , origin: String | |
| , target: String | |
| , quadrant: Quadrant | |
| , originSide: SideConnection | |
| , targetSide: SideConnection | |
| , connectionVisibility: ConnectionVisibility | |
| } | |
| type alias ObjectName = String | |
| type alias ConnectionStore = | |
| Dict.Dict String (List UnorderedConnection) | |
| sideToStr side = | |
| case side of | |
| Top -> "Top" | |
| Left -> "Left" | |
| Right -> "Right" | |
| Bottom -> "Bottom" | |
| toSideKey : ObjectName -> Side -> String | |
| toSideKey objectName side = | |
| objectName ++ "!!!" ++ (sideToStr side) | |
| storeConnection : ObjectName -> Side -> UnorderedConnection -> ConnectionStore -> ConnectionStore | |
| storeConnection obj side conn store = | |
| let | |
| key = toSideKey obj side | |
| in | |
| case Dict.get key store of | |
| Just cs -> | |
| Dict.insert key (conn::cs) store | |
| Nothing -> | |
| Dict.insert key [conn] store | |
| orderConnections : List UnorderedConnection -> List OrderedConnection | |
| orderConnections transitions = | |
| let | |
| g ({origin, target, originSide, targetSide} as conn) store = | |
| storeConnection target targetSide conn | |
| <| storeConnection origin originSide conn store | |
| connectionStore = | |
| List.foldr g Dict.empty transitions | |
| alreadFrom obj side {origin, originSide, target, targetSide} = | |
| (origin == obj && originSide.side == side) || | |
| (target == obj && targetSide.side == side) | |
| f : UnorderedConnection -> List OrderedConnection -> List OrderedConnection | |
| f {origin, target, originSide, targetSide, label, quadrant, connectionVisibility} sum = | |
| let | |
| totalToOrigin = List.length <| Maybe.withDefault [] <| Dict.get (toSideKey origin originSide) connectionStore | |
| totalToTarget = List.length <| Maybe.withDefault [] <| Dict.get (toSideKey target targetSide) connectionStore | |
| alreadFromOrigin = List.length <| List.filter (alreadFrom origin originSide) sum | |
| alreadyToTarget = List.length <| List.filter (alreadFrom target targetSide) sum | |
| id = String.join "-" | |
| [origin | |
| , target | |
| , sideToStr originSide | |
| , sideToStr targetSide | |
| , fromInt alreadFromOrigin | |
| , fromInt alreadyToTarget | |
| ] | |
| connection : OrderedConnection | |
| connection = | |
| { id = ImplicitConnectionId id | |
| , label = label | |
| , origin = origin | |
| , target = target | |
| , quadrant = quadrant | |
| , originSide = | |
| { side = originSide | |
| , index = alreadFromOrigin | |
| , total = totalToOrigin | |
| } | |
| , targetSide = | |
| { side = targetSide | |
| , index = alreadyToTarget | |
| , total = totalToTarget | |
| } | |
| , connectionVisibility = connectionVisibility | |
| } | |
| in | |
| connection :: sum | |
| in | |
| List.foldr f [] transitions | |
| type Quadrant | |
| = TopLeft | |
| | BottomLeft | |
| | BottomRight | |
| | TopRight | |
| type Side | |
| = Top | |
| | Left | |
| | Bottom | |
| | Right | |
| type Orientation | |
| = Portrait | |
| | Landscape | |
| orientationOf : Size -> Orientation | |
| orientationOf size = | |
| let | |
| { x, y } = | |
| Vector2d.unwrap size | |
| in | |
| if x > y then | |
| Landscape | |
| else | |
| Portrait | |
| sideN_ : Bool -> ObjectInTransition -> SideConnection -> Position | |
| sideN_ isEnd obj sideConn = | |
| let | |
| pos = obj.props.pos | |
| size = obj.props.size | |
| (n,t) = (sideConn.index + 1, sideConn.total) | |
| side = sideConn.side | |
| padding = | |
| if isEnd then 3 else 0 | |
| { x, y } = | |
| Vector2d.unwrap size | |
| relativeDistance = | |
| toFloat n / (toFloat t + 1) | |
| ( from, by ) = | |
| case side of | |
| Top -> | |
| ( Vector2d.unitless 0 -padding | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless x 0 | |
| ) | |
| Right -> | |
| ( Vector2d.unitless (x + padding) 0 | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless 0 y | |
| ) | |
| Bottom -> | |
| ( Vector2d.unitless 0 (y + padding) | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless x 0 | |
| ) | |
| Left -> | |
| ( Vector2d.unitless -padding 0 | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless 0 y | |
| ) | |
| in | |
| Point2d.translateBy by <| Point2d.translateBy from pos | |
| {- | |
| Calculates the Nth of T points on the given side. | |
| Points are equidistant from each other and the edges. | |
| -} | |
| sideN : Bool -> ( Int, Int ) -> Position -> Size -> Side -> Position | |
| sideN isEnd ( n, t ) pos size side = | |
| let | |
| padding = | |
| if isEnd then 3 else 0 | |
| { x, y } = | |
| Vector2d.unwrap size | |
| relativeDistance = | |
| toFloat n / (toFloat t + 1) | |
| ( from, by ) = | |
| case side of | |
| Top -> | |
| ( Vector2d.unitless -padding -padding | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless x 0 | |
| ) | |
| Right -> | |
| ( Vector2d.unitless (x + padding) -padding | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless 0 y | |
| ) | |
| Bottom -> | |
| ( Vector2d.unitless -padding (y + padding) | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless x 0 | |
| ) | |
| Left -> | |
| ( Vector2d.unitless -padding -padding | |
| , Vector2d.multiplyBy relativeDistance <| Vector2d.unitless 0 y | |
| ) | |
| in | |
| Point2d.translateBy by <| Point2d.translateBy from pos | |
| relativeQuadrant : Position -> Position -> Quadrant | |
| relativeQuadrant from to = | |
| let | |
| { x, y } = | |
| Vector2d.unwrap <| Vector2d.from from to | |
| in | |
| if x > 0 then | |
| if y > 0 then | |
| BottomRight | |
| else | |
| TopRight | |
| else if y > 0 then | |
| BottomLeft | |
| else | |
| TopLeft | |
| type Instruction | |
| = Add String (List Prop) | |
| | Update String (List Prop) | |
| | MilestoneI | |
| | Connect (Maybe String) String (Maybe Side) String (Maybe Side) (Maybe String) | |
| type Prop | |
| = Pos Float Float | |
| | Opacity Float | |
| | Size Float Float | |
| milestoneParser : Parser Instruction | |
| milestoneParser = | |
| succeed MilestoneI | |
| |. token "|-" | |
| |. justSpaces | |
| |. chompUntil "-|" | |
| |. token "-|\n" | |
| instructionParser : Parser (List Instruction) | |
| instructionParser = | |
| loop [] instructionParserHelp | |
| instructionParserHelp : List Instruction -> Parser (Step (List Instruction) (List Instruction)) | |
| instructionParserHelp instructions = | |
| oneOf | |
| [ succeed (\_ -> Loop instructions) | |
| |= emptyLine | |
| , succeed (\i -> Loop (i :: instructions)) | |
| |= milestoneParser | |
| , succeed (\i -> Loop (i :: instructions)) | |
| |= addParser | |
| , succeed (\i -> Loop (i :: instructions)) | |
| |= updateParser | |
| , succeed (\i -> Loop (i :: instructions)) | |
| |= connectParser | |
| , succeed () | |
| |> map (\_ -> Done (List.reverse instructions)) | |
| ] | |
| addParser : Parser Instruction | |
| addParser = | |
| succeed Add | |
| |. symbol "add" | |
| |. justSpaces | |
| |= string | |
| |. symbol "\n" | |
| |= parseIndented | |
| updateParser : Parser Instruction | |
| updateParser = | |
| succeed Update | |
| |. symbol "update" | |
| |. justSpaces | |
| |= string | |
| |. symbol "\n" | |
| |= parseIndented | |
| connectParser : Parser Instruction | |
| connectParser = | |
| succeed Connect | |
| |. symbol "connect" | |
| |. justSpaces | |
| |= oneOf | |
| [ connectionIdParser | |
| , succeed Nothing | |
| ] | |
| |= string | |
| |= maybeSideParser | |
| |. justSpaces | |
| |= string | |
| |= maybeSideParser | |
| |= oneOf | |
| [ succeed (\s -> Just s) |. justSpaces |= string | |
| , succeed Nothing | |
| ] | |
| connectionIdParser : Parser (Maybe String) | |
| connectionIdParser = | |
| succeed (\s -> Just s) | |
| |. symbol "#" | |
| |= getChompedString (chompWhile (\c -> Char.isAlphaNum c || c == '-' || c == '_')) | |
| |. justSpaces | |
| maybeSideParser : Parser (Maybe Side) | |
| maybeSideParser = | |
| let | |
| justSide = | |
| succeed (\s -> Just s) | |
| |. symbol "@" | |
| |= parseSide | |
| in | |
| oneOf | |
| [ justSide | |
| , succeed Nothing | |
| ] | |
| parseSide : Parser Side | |
| parseSide = | |
| let | |
| parseLeft = succeed Left |. token "-|" | |
| parseRight = succeed Right |. token "|-" | |
| parseTop = succeed Top |. token "T" | |
| parseBottom = succeed Top |. token "_" | |
| in | |
| oneOf | |
| [ parseLeft | |
| , parseTop | |
| , parseBottom | |
| , parseRight | |
| ] | |
| parseIndented : Parser (List Prop) | |
| parseIndented = | |
| getChompedString (chompWhile (\c -> c == ' ')) | |
| |> andThen startParsingProps | |
| startParsingProps : String -> Parser (List Prop) | |
| startParsingProps indent = | |
| if indent == "" then | |
| succeed [] | |
| else | |
| succeed (\first other -> first :: other) | |
| |= propParser | |
| |= loop [] (statementsHelp indent) | |
| emptyLine : Parser () | |
| emptyLine = | |
| succeed () | |
| |. justSpaces | |
| |. token "\n" | |
| justSpaces = | |
| chompWhile (\c -> c == ' ') | |
| indentedProp : Parser a -> String -> Parser a | |
| indentedProp p indent = | |
| succeed (\x -> x) | |
| |. symbol ("\n" ++ indent) | |
| |= p | |
| statementsHelp : String -> List Prop -> Parser (Step (List Prop) (List Prop)) | |
| statementsHelp indent revStmts = | |
| oneOf | |
| [ succeed (\stmt -> Loop (stmt :: revStmts)) | |
| |= indentedProp propParser indent | |
| , succeed () | |
| |> map (\_ -> Done (List.reverse revStmts)) | |
| ] | |
| propParser : Parser Prop | |
| propParser = | |
| oneOf [ posParser, sizeParser, opacityParser ] | |
| float : Parser Float | |
| float = | |
| oneOf | |
| [ succeed negate | |
| |. symbol "-" | |
| |= Parser.float | |
| , Parser.float | |
| ] | |
| posParser : Parser Prop | |
| posParser = | |
| succeed Pos | |
| |. symbol "pos" | |
| |. justSpaces | |
| |= float | |
| |. justSpaces | |
| |= float | |
| sizeParser : Parser Prop | |
| sizeParser = | |
| succeed Size | |
| |. symbol "size" | |
| |. justSpaces | |
| |= float | |
| |. justSpaces | |
| |= float | |
| opacityParser : Parser Prop | |
| opacityParser = | |
| succeed Opacity | |
| |. symbol "opacity" | |
| |. justSpaces | |
| |= float | |
| string : Parser String | |
| string = | |
| succeed identity | |
| |. token "\"" | |
| |= loop [] stringHelp | |
| stringHelp : List String -> Parser (Step (List String) String) | |
| stringHelp revChunks = | |
| oneOf | |
| [ succeed (\chunk -> Loop (chunk :: revChunks)) | |
| |. token "\\" | |
| |= oneOf | |
| [ map (\_ -> "\n") (token "n") | |
| , map (\_ -> "\t") (token "t") | |
| , map (\_ -> "\u{000D}") (token "r") | |
| ] | |
| , token "\"" | |
| |> map (\_ -> Done (String.join "" (List.reverse revChunks))) | |
| , chompWhile isUninteresting | |
| |> getChompedString | |
| |> map (\chunk -> Loop (chunk :: revChunks)) | |
| ] | |
| isUninteresting : Char -> Bool | |
| isUninteresting char = | |
| char /= '\\' && char /= '"' | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment