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
You can’t perform that action at this time.