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

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