Movable, hierarchical boxes with MVU architecture using Elmish (triggered by this comment thread: http://bit.ly/2O9eAnu)

App.fs

module Elmish.Boxes

open System
open Fable.React.Helpers
open Fable.React.Props
open Fable.React.Standard


[<AutoOpen>]
module Domain =


  [<NoComparison>]
  type Point =
    { x: float
      y: float }
    static member (+) (p1, p2) = { x = p1.x + p2.x; y = p1.y + p2.y }
    static member (+) (p, scalar) = { x = p.x + scalar; y = p.y + scalar }
    static member (-) (p1, p2) = { x = p1.x - p2.x; y = p1.y - p2.y }
    static member (-) (p, scalar) = { x = p.x - scalar; y = p.y - scalar }
    static member (*) (p, scalar) = { x = p.x * scalar; y = p.y * scalar }
    static member (*) (p1, p2) = { x = p1.x * p2.x; y = p1.y * p2.y }
    static member (/) (p1, p2) = { x = p1.x / p2.x; y = p1.y / p2.y }
    static member (/) (p, scalar) = { x = p.x / scalar; y = p.y / scalar }

  type BoxId = Guid

  /// Anchor relative to box upper left
  type BoxRelativeAnchor = Point


  type Box =
    { id: BoxId
      upperLeft: Point
      size: float
      color: string }


  module Box =

    let create (center: Point) size color =
      { id = Guid.NewGuid()
        upperLeft = center - (size / 2.)
        size = size
        color = color }

    let moveBy dPos box =
      { box with upperLeft = box.upperLeft + dPos }

    let resizeBy factor (anchor: Point) box =
      let relAnchor = (anchor - box.upperLeft) / box.size
      let resizedBox = { box with size = box.size * factor }
      let relAnchorResized = (anchor - box.upperLeft) / resizedBox.size
      let dPos = (relAnchorResized - relAnchor) * resizedBox.size
      { resizedBox with upperLeft = box.upperLeft + dPos }


  type BoxHierarchy =
    { boxes: Map<BoxId, Box>
      childToParent: Map<BoxId, BoxId>  }


  module BoxHierarchy =

    let childIdsOf parentId hierarchy =
      hierarchy.childToParent
      |> Map.filter (fun _ pid -> pid = parentId)
      |> Map.toList
      |> List.map fst

    let childrenOf parentId hierarchy =
      hierarchy
      |> childIdsOf parentId
      |> List.choose hierarchy.boxes.TryFind

    let rec withDescendantIds hierarchy parentId =
      parentId
      :: ( hierarchy
           |> childIdsOf parentId
           |> List.collect (withDescendantIds hierarchy) )

    let topLevelBoxes hierarchy =
      hierarchy.boxes
      |> Map.filter (fun boxId _ -> not <| hierarchy.childToParent.ContainsKey boxId)
      |> Map.toList
      |> List.map snd

    let addBox box hierarchy =
      { hierarchy with boxes = hierarchy.boxes.Add(box.id, box) }

    let removeWithDescendants boxId hierarchy =
      let toRemove = boxId |> withDescendantIds hierarchy |> Set.ofList
      { hierarchy with
          boxes =
            hierarchy.boxes
            |> Map.filter (fun bid _ -> not <| toRemove.Contains bid)
          childToParent =
            hierarchy.childToParent
            |> Map.filter (fun childId parentId ->
                not <| toRemove.Contains childId
                && not <| toRemove.Contains parentId
            )
      }

    let setTopLevel boxId hierarchy =
      { hierarchy with childToParent = hierarchy.childToParent |> Map.remove boxId }

    let move boxId newPos relativeAnchor hierarchy =
      match hierarchy.boxes.TryFind boxId with
      | None -> hierarchy
      | Some box ->
          let idsToMove = box.id |> withDescendantIds hierarchy |> Set.ofList
          let dPos = newPos - box.upperLeft - relativeAnchor
          let updatedBoxes =
            hierarchy.boxes
            |> Map.map (fun _ box ->
                if idsToMove.Contains box.id then
                  box |> Box.moveBy dPos
                else box
            )
          { hierarchy  with boxes = updatedBoxes }

    let setRelationship childId parentId hierarchy =
      { hierarchy with childToParent = hierarchy.childToParent.Add(childId, parentId) }

    let resize boxId factor absoluteAnchor hierarchy =
      let idsToResize = boxId |> withDescendantIds hierarchy |> Set.ofList
      { hierarchy with
          boxes =
            hierarchy.boxes
            |> Map.map (fun _ box ->
                if idsToResize.Contains box.id then
                  box |> Box.resizeBy factor absoluteAnchor
                else box
            )
      }


[<AutoOpen>]
module MvuModel =

  type Model =
    { hierarchy: BoxHierarchy
      mousePos: Point
      dragging: (BoxId * BoxRelativeAnchor) option
      undo: Model list
      redo: Model list }

  let init () =
    let id1 = Guid.NewGuid()
    let id2 = Guid.NewGuid()
    let id3 = Guid.NewGuid()
    let id4 = Guid.NewGuid()
    { hierarchy =
        { boxes =
            [
              {id = id1; upperLeft = { x = 20.; y = 20. }; size = 200.; color = "red"}
              {id = id2; upperLeft = { x = 100.; y = 100. }; size = 50.; color = "green"}
              {id = id3; upperLeft = { x = 400.; y = 400. }; size = 200.; color = "blue"}
              {id = id4; upperLeft = { x = 500.; y = 500. }; size = 80.; color = "yellow"}
            ]
            |> List.map (fun b -> b.id, b)
            |> Map.ofList
          childToParent = Map.empty.Add(id2, id1).Add(id4, id3) }
      mousePos = { x = 0.; y = 0. }
      dragging = None
      undo = []
      redo = [] }

  let isDragging boxId model =
    model.dragging
    |> Option.map (fun (bid, _) -> bid = boxId)
    |> Option.defaultValue false

  let drop childId parentId model =
    { model with
        dragging = None
        hierarchy = model.hierarchy |> BoxHierarchy.setRelationship childId parentId }

  let rand = Random()

  let addRandomBox center model =
    let size = rand.Next(40, 200) |> float
    let color = String.Format("#{0:X6}", rand.Next(0x1000000))
    let box = Box.create center size color
    { model with hierarchy = model.hierarchy |> BoxHierarchy.addBox box }


[<AutoOpen>]
module MvuUpdate =

  type Msg =
    | PickUp of BoxId * BoxRelativeAnchor
    | DropOnBox of BoxId
    | DropOnEmpty
    | CreateNew of Point
    | Delete of BoxId
    | Grow of BoxId
    | Shrink of BoxId
    | MouseMove of Point
    | Undo
    | Redo


  let update msg model =
    match msg with

    | PickUp (boxId, relativeAnchor) ->
        { model with
            dragging = Some (boxId, relativeAnchor)
            hierarchy = model.hierarchy |> BoxHierarchy.setTopLevel boxId
            undo = model :: model.undo
            redo = [] }

    | DropOnBox parentId ->
        model.dragging
        |> Option.map (fun (childId, _) -> drop childId parentId model)
        |> Option.defaultValue model

    | DropOnEmpty -> { model with dragging = None }

    | CreateNew center ->
        { model with
            undo = model :: model.undo
            redo = [] }
        |> addRandomBox center

    | Delete boxId ->
        { model with
            hierarchy = model.hierarchy |> BoxHierarchy.removeWithDescendants boxId
            undo = model :: model.undo
            redo = [] }

    | Grow boxId ->
        { model with
            hierarchy = model.hierarchy |> BoxHierarchy.resize boxId 1.1 model.mousePos
            undo = model :: model.undo
            redo = [] }

    | Shrink boxId ->
        { model with
            hierarchy = model.hierarchy |> BoxHierarchy.resize boxId (1./1.1) model.mousePos
            undo = model :: model.undo
            redo = [] }

    | MouseMove newPos ->
        { model with
            mousePos = newPos
            hierarchy =
              match model.dragging with
              | None -> model.hierarchy
              | Some (boxId, anchor) -> model.hierarchy |> BoxHierarchy.move boxId newPos anchor
        }

    | Undo ->
        match model.undo with
        | [] -> model
        | head :: tail -> { head with undo = tail; redo = model :: model.redo }

    | Redo ->
        match model.redo with
        | [] -> model
        | head :: tail -> { head with redo = tail; undo = model :: model.undo }


[<AutoOpen>]
module MvuView =

  let rec boxWithChildren model dispatch origin box =
    let dragging = isDragging box.id model
    div [
      Key (string box.id)
      Class "box"
      OnMouseDown (fun ev ->
        ev.preventDefault()
        ev.stopPropagation()
        match ev.button with
        | 0. -> (box.id, model.mousePos - box.upperLeft) |> PickUp |> dispatch
        | 1. -> Delete box.id |> dispatch
        | _ -> ())
      OnMouseUp (fun ev ->
        ev.preventDefault()
        ev.stopPropagation()
        DropOnBox box.id |> dispatch)
      OnWheel (fun ev ->
        ev.preventDefault()
        ev.stopPropagation()
        if ev.deltaY < 0. then Grow box.id |> dispatch
        elif ev.deltaY > 0. then Shrink box.id |> dispatch)
      Style [
        Width box.size
        Height box.size
        Top (box.upperLeft.y - origin.y)
        Left (box.upperLeft.x - origin.x)
        BackgroundColor box.color
        ZIndex (if dragging then 2 else 1)
        Opacity (if dragging then 0.7 else 1.)
        // Never trigger pointer event (e.g. drop) on currently dragging box;
        // let next layer trigger the event
        PointerEvents (if dragging then "none" else "auto")
      ]
    ] [
      model.hierarchy
      |> BoxHierarchy.childrenOf box.id
      |> List.map (boxWithChildren model dispatch box.upperLeft)
      |> ofList
    ]

  let view model dispatch =
    div [
      Class "main-container"
      OnMouseDown (fun ev ->
        ev.preventDefault()
        match ev.button with
        | 0. -> CreateNew { x = ev.pageX; y = ev.pageY } |> dispatch
        | _ -> ())
      OnMouseUp (fun ev -> ev.preventDefault(); dispatch DropOnEmpty)
      OnMouseMove (fun ev ->
        MouseMove { x = ev.pageX; y = ev.pageY } |> dispatch)
    ] [
      div [
        Class "instructions"
        OnMouseMove (fun ev -> ev.stopPropagation())
        OnMouseDown (fun ev -> ev.stopPropagation())
        OnMouseUp (fun ev -> ev.stopPropagation())
      ] [
        p [] [ str "Drag box to move" ]
        p [] [ str "Drag box inside other box to set as child" ]
        p [] [ str "Left-click empty area to create new box" ]
        p [] [ str "Middle-click box to remove" ]
        p [] [ str "Scroll box to resize" ]
        button [
          OnClick (fun _ -> dispatch Undo)
          Disabled model.undo.IsEmpty
        ] [ str "Undo ("; ofInt model.undo.Length; str ")" ]
        button [
          OnClick (fun _ -> dispatch Redo)
          Disabled model.redo.IsEmpty
        ] [ str "Redo ("; ofInt model.redo.Length; str ")" ]
      ]
      model.hierarchy
      |> BoxHierarchy.topLevelBoxes
      |> List.map (boxWithChildren model dispatch { x=0.; y=0. })
      |> ofList
    ]


open Elmish
open Elmish.React

Program.mkSimple init update view
|> Program.withReactSynchronous "app"
|> Program.run

index.html

<html>

<head>
    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>
    <script src="__HOST__/libs/react.production.min.js"></script>
    <script src="__HOST__/libs/react-dom.production.min.js"></script>
</head>

<body class="app-container">
    <div id="app" class="app"></div>
</body>

</html>

styles.css

html, body {
  height: 100%;
  margin: 0;
  overflow: hidden;
}

#app {
  height: 100%;
}

.main-container {
  height: 100%;
  background-color: black;
}

.box {
  position: absolute;
  overflow: hidden;
}

.box:hover {
  outline: 1px white solid;
}

.instructions {
  position: fixed;
  top: 0;
  right: 0;
  background-color: white;
  width: 200px;
  font-size: 12px;
  font-family: sans-serif;
  padding: 5px;
}

.instructions button:first-of-type {
  margin-right: 10px;
}

Sure. I'm not sure if I get everything right, but it seems that you chose to represent the hierarchy by storing a map from item to its parent, so that in order to get the children of a particular box, you need to search linearly through all boxes that are present in the system.
If you do this for each box, the complexity gets quadratic.

Yes, you're right, so let me just get two things out here:

• I have made absolutely no performance optimizations here. This demo is intended to show how the challenge could be solved functionally, and any optimizations would complicate matters, and would also be premature in this context. For the performance impact to become noticeable, I'd guess you need much deeper hierarchies and much more boxes than you are likely to get when playing around with this. Feel free to test and see if you can provoke poor performance; I'd be interested to know.

• Aside from restructuring the map from childId -> parentId to parentId -> childId list (which would make some other lookups leess effective), or duplicating the hierarchy information by using one map for each direction, or finding another structure entirely. there are very simple - almost trivial - ways to optimize such code. Since the solution is immutable in nature, it lends itself very well to memoization using reference equality checks for lightning fast comparison. For example, you could memoize BoxHierarchy.childIdsOf which AFAIK does the actual "quadratic" lookup.

As I mentioned in the Quora comment, I also experimented with having each box contain a list of child boxes, but updating a recursive, immutable hierarchy is a pain compared to a flat list with some kind of association structure. The updates become more computationally complex, and anything that requires you to traverse the other direction (e.g. upwards from child to parent) is also more complex. Also, you can easily end up with duplicated data if the relational data is more complex than a simple parent-child relationship. If you're interested, this talk gives more information about immutable relational data from the perspective of an Elm architecture (as is used here).

I don't think memoization would work here right, as the thing to memoize would still need quadratic time to compute the thing to be memoized.
I'm exploring the boundary between FP and OOP, and it seems to be around here.
The clear advantage of your solution is the easiness of implementing the undo mechanism.
But it doesn't satisfy the fundamental prerequisite of the development direction that I'm taking, namely - extensibility (I pasted you the link to a demo of the editor that I've been working on, and extensibility is one of its key properties. I don't see a way in which your program could be extended modularly, but if you have an idea how to do that, it would be interesting to see)

In short, what kind of extensibility and modular extension are you talking about?

The video is here:
https://www.youtube.com/watch?v=oxeB-8k-DBA
The sources are here:
https://github.com/panicz/sracket/blob/master/5.rkt

You need to install Racket if you want to play with it.

In particular, I'd like to turn your attention to the definition of Graph on line 856, which is used just below, in line 883, which uses a "define-interaction" form.

"define-interaction" is a mechanism (very simple) defined in line 797, which allows to give an arbitrary interaction to a particular box. What I mean by interaction is:

• how the thing is displayed
• how the thing reacts to user input (and possibly other sources)

If you have any ideas how to design such a thing in a purely functional manner, I'd love to learn them.

Who should define how the thing is displayed and how it reacts to input? Is that intended to be supplied by code you don't control?

And would it be possible for you to phrase a simple example question/requirement in terms of the boxes? I tried reading the code you linked to, but the language is so unfamiliar I couldn't really understand much.

Yes, the idea is that the user should be able to write snippets of code that are meant to be interpreted by the editor.
So for example, user defines that every box which has the form
(digraph . neighbour-list)
can be interpreted using the Graph interaction.

An "interaction" is an object which:

• is able to handle signals like mouse-down, mouse-move, key-down and so on
• to the "as-image" message responds with an image

Thanks. I am trying to think of a parallel in terms of the simple movable boxes challenge, but I can't come up with anything, likely because I don't really understand. If you want to phrase a simple example question/requirement as an extension (part 4?) of the movable boxes challenge, that would help a lot!

I'll write something on my blog and then let you know (but I guess that reimplementing the capabilities shown on the video would be "about it")

Sure, but the video doesn't really explain the modularity/extensibility in a way I can understand and translate to the box example. Hoping the blog post will. :)

I just wrote it here: https://eidolon-language.quora.com/Principles-of-visual-programming
Let me know whether it's sufficiently clear or if you have any questions, and if so, then I'll try to address them.

Thanks! But sorry, I still don't understand.

Again, if you feel like presenting a "moving boxes challenge part 4", where it's reduced to be as simple/abstract as possible, I might have a go at it (no promises though). Otherwise I think I'll leave this as it is. :)

I recently wrote this Quora answer: https://www.quora.com/Can-you-create-a-better-syntax-of-Lisp/answer/Panicz-Godek
Perhaps it may help clarify some things. But the problem is that I don't know how to phrase it as a "challenge", because it's still subject to active exploration.

Thanks. I see what you're trying to do at a high level, but not at a level I can understand sufficiently to experiment with in the context of moving boxes. So I think I'll drop the ball here. :) Was fun making the movable boxes, though!

This is slightly out of date now due a reorganization of the fable react bindings, to fix this change the opens to

open Fable.React.Helpers
open Fable.React.Props
open Fable.React.Standard

The remaining code works as-written.

I've never heard about Fable.React.Standard, is that brand new? I tried in the REPL a few days ago and it wasn't needed.

Yup, it's an artifact of the reorganization they did to the React bindings. All the html generation is now in that module: https://github.com/fable-compiler/fable-react/blob/master/src/Fable.React.Standard.fs

Updated. Thanks! 👍

This is the most exciting thing I've seen on the internet in years!

Christer: The way I can execute and tinker with your code in Fable from a link blows my mind. I'm going to have a serious play with your code. Is there no "Point" type or 2D vector in React or some other library you could reference? My first thought was that a classic ML tree seemed preferable (e.g. more typeful) vs a graph as a dictionary so I am intrigued by your response. I wrote a vaguely similar typesetting editor in OCaml once that used trees and lists of ints to index into them and I thought it worked well.

Panicz: I think the best way to settle the evolution of your challenge (algorithmic complexity and extensibility) is to crank it up into a complete Lisp IDE, e.g. with infinite zoom. I'm with Christer in that this solution is so simple I'd extend it without abstraction. Can you run your Racket code in the browser or use something that does? Also, when you say things like "An interaction is an object which...is able to handle signals" I think you're falling foul of the XY problem because you're describing an OOP solution instead of describing the problem you want to solve (which is, I think, to write a Lisp IDE).

I've been toying with the idea of a minimal graphical ML where let bindings and pattern matches are all displayed graphically but all other expressions are ML syntax. This would be a great way to implement that.

Is there no "Point" type or 2D vector in React or some other library you could reference?

Not that I know of.

Unfortunately I don't know of any way of running Racket code in the browser (I've just asked on their mailing list and am waiting for the response).
Regarding your claim about the XY problem, you may be right. I'm still looking for the right means of expression, and my solution has been gravitating towards OOP, even though I did experiment with FP approach (I agree that I am probably biased by education). On the other hand, Fructure is implemented in purely functional Racket (using immutable hash tables to represent objects) and it seems to work, so there may have been something wrong with my approach.

Of course, if I manage to come up with a complete Lisp IDE, I will let you know ;]

Here's an updated link from Igor McBell on Quora

Regarding running Racket in the browser, I was pointed to the following:
https://www.wescheme.org/
https://github.com/racket/racket/wiki/RacketScript
https://github.com/soegaard/urlang

But I suppose I'd need to customize my app to make it happen