Dynamic Diagrams

Main.elm

-- 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 /= '"'