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;
}

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