Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
F#+WPF solution to the Draggable Rectangles challenge by Panicz Godek
open System.Windows
let goldenRatio = (1.0 + sqrt 5.0) / 2.0
let newBrush =
let mutable hue = 0.0
fun () ->
hue <- hue + System.Math.PI / goldenRatio
let s x = byte(255.0 * x)
let c x = 0.5 * (cos x + 1.0)
let r = c hue / 1.5
let g = c(hue + 4.0 / 3.0 * System.Math.PI) / 2.0
let b = c(hue + 8.0 / 3.0 * System.Math.PI)
let color = Media.Color.FromRgb(s r, s g, s b)
Media.SolidColorBrush(Color=color)
let mutable nextBrush = newBrush()
type Rectangle =
{ Brush: Media.Brush
Corner: Vector
Size: float }
type Scene = Rectangle of Rectangle * Scene list
let mutable scene : Scene list = []
let mutable drag : Vector option = None
/// Is x0 <= x <= x1?
let between x0 x x1 = x0 <= x && x <= x1
/// Is the given point inside the given rectangle?
let isPointInRectangle (point: Vector) rect =
between rect.Corner.X point.X (rect.Corner.X + rect.Size) &&
between rect.Corner.Y point.Y (rect.Corner.Y + rect.Size)
/// Try to remove the rectangle at the given point, returning the rectangle and remaining scene.
let rec tryRemove point scene =
match scene with
| [] -> None
| Rectangle(rect, children)::scene ->
if isPointInRectangle point rect then
match tryRemove point children with
| None -> Some(Rectangle(rect, children), scene)
| Some(child, children) -> Some(child, Rectangle(rect, children)::scene)
else
match tryRemove point scene with
| None -> None
| Some(child, scene) -> Some(child, Rectangle(rect, children)::scene)
/// Insert the given child rectangle at the given point.
let rec add point child scene =
match scene with
| [] -> [child]
| Rectangle(rect, children)::scene ->
if isPointInRectangle point rect then
Rectangle(rect, add point child children)::scene
else Rectangle(rect, children)::add point child scene
/// Apply the given function "f" to this rectangle and all of its children recursively.
let rec map f (Rectangle(rect, children)) =
Rectangle(f rect, List.map (map f) children)
/// Scale a rectangle and all of its children.
let scale factor = map (fun r -> { r with Size = r.Size * factor })
/// Scale the rectangle at the given point.
let rec scaleAt s point scene =
let f r = { r with Size = s * r.Size }
match scene with
| [] -> None
| Rectangle(rect, children)::scene ->
if isPointInRectangle point rect then
let rect =
match scaleAt s point children with
| None -> Rectangle(f rect, children)
| Some children -> Rectangle(rect, children)
Some(rect::scene)
else
scaleAt s point scene
|> Option.map (fun scene -> Rectangle(rect, children)::scene)
/// Translate a rectangle and all of its children.
let translate vector = map (fun r -> { r with Corner = r.Corner + vector })
/// Remove the rectangle (if any) from the given point and insert it at the new point.
let move oldPoint newPoint scene =
match tryRemove oldPoint scene with
| None -> Rectangle({Brush=nextBrush; Corner=newPoint; Size=100.0}, [])::scene
| Some(child, scene) ->
add newPoint (translate (newPoint - oldPoint) child) scene
let canvas = Controls.Canvas()
let rec drawScene scene =
for Rectangle(rect, children) in List.rev scene do
let shape = Shapes.Rectangle()
shape.Fill <- rect.Brush
Controls.Canvas.SetLeft(shape, rect.Corner.X)
Controls.Canvas.SetTop(shape, rect.Corner.Y)
shape.Width <- rect.Size
shape.Height <- rect.Size
let _ = canvas.Children.Add shape
drawScene children
let draw scene =
canvas.Children.Clear()
drawScene scene
let startDrag point =
drag <- Some point
let stopDrag oldPoint newPoint =
scene <- move oldPoint newPoint scene
drag <- None
nextBrush <- newBrush()
draw scene
[<System.STAThread; EntryPoint>]
let main _ =
canvas.Background <- Media.Brushes.Black
let vectorOf f : Vector = Point.op_Explicit(f canvas)
canvas.MouseDown.Add(fun e ->
startDrag (vectorOf e.GetPosition))
canvas.MouseMove.Add(fun e ->
let newPoint = vectorOf e.GetPosition
match drag, e.LeftButton = Input.MouseButtonState.Pressed with
| None, false -> ()
| None, true -> startDrag newPoint
| Some oldPoint, false -> stopDrag oldPoint newPoint
| Some oldPoint, true -> draw(move oldPoint newPoint scene))
canvas.MouseUp.Add(fun e ->
match drag with
| None -> ()
| Some oldPoint -> stopDrag oldPoint (vectorOf e.GetPosition))
canvas.MouseWheel.Add(fun e ->
scaleAt (1.0 + float e.Delta / 1000.0) (vectorOf e.GetPosition) scene
|> Option.iter (fun s -> scene <- s)
draw scene)
draw scene
Window(Title="Draggable rectangles", Content=canvas)
|> Application().Run
@jdh30

This comment has been minimized.

Copy link
Owner Author

@jdh30 jdh30 commented Sep 17, 2019

This is a WPF-based GUI app that lets you create rectangles, scale them and nest them inside each other. Click on the black background to create a new rectangle. Use the mouse wheel to scale the rectangle under the pointer. Drag the rectangles around and drop them inside each other to create a tree of nested rectangles.

Some notable points:

  • This is a pragmatic solution designed to be simple and not designed to be a pedagogical example for any paradigm (functional or OOP).
  • I haven't used any objects or (IMO) object orientation beyond the fact that the underlying library (WPF) is OOP but I have used recursive types and functions over them.
  • The tree of rectangles is represented as a classical ML tree via an algebraic data type rather than the dictionary-based representation used by Christer.
  • IMO, this code would be even shorter and simpler if it used a better graphics library than WPF. Would be interesting to port this to the Raspberry Pi using .NET Core and GTK#.

Limitations of this solution:

  • The rectangles are all squares.
  • Nested rectangles are not clipped to their parents so they can overhang.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment