4 people like it.

Peter Henderson's picture language from SICP

An implementation of (part of) Peter Henderson's picture language from the SICP book.

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
(*
    Types
*)
type Vector = { X:single; Y:single } with
    static member ( + ) ({X=x;Y=y}, {X=x';Y=y'}) = {X=x+x';Y=y+y'}
    static member ( - ) ({X=x;Y=y}, {X=x';Y=y'}) = {X=x-x';Y=y-y'}
    static member ( * ) ({X=x;Y=y}, s)           = {X=s*x;Y=s*y}
    static member ( * ) (s, {X=x;Y=y})           = {X=s*x;Y=s*y}
type Frame = { Origin:Vector; First:Vector; Second:Vector }
type Pict = Frame -> unit

let coordMap f = fun v -> f.Origin + (v.X * f.First + v.Y * f.Second)

(*
    Picture transformations and combinators
*)
let transform o c1 c2 (p:Pict) : Pict =
    let p' f =
        let map = coordMap f
        let o' = map o
        p { Origin=o'; First=(map c1) - o'; Second=(map c2) - o' }
    p'

let flipVert p = transform {X=0.f;Y=1.f} {X=1.f;Y=1.f} {X=0.f;Y=0.f} p
let flipHoriz p = transform {X=1.f;Y=0.f} {X=0.f;Y=0.f} {X=1.f;Y=1.f} p

let shrink p percent =
    let d = (single percent)/200.f
    transform {X=d;Y=d} {X=1.f-d;Y=d} {X=d;Y=1.f-d} p

let beside p1 p2 : Pict =
    let left = transform {X=0.f;Y=0.f} {X=0.5f;Y=0.f} {X=0.f;Y=1.f} p1
    let right = transform {X=0.5f;Y=0.f} {X=1.f;Y=0.f} {X=0.5f;Y=1.f} p2
    fun f -> left f; right f

let above p1 p2 : Pict =
    let low = transform {X=0.f;Y=0.f} {X=1.f;Y=0.f} {X=0.f;Y=0.5f} p1
    let high = transform {X=0.f;Y=0.5f} {X=1.f;Y=0.5f} {X=0.f;Y=1.f} p2
    fun f -> low f; high f

let rec rightSplit p n =
    if n = 0 then p
    else
        let smaller = rightSplit p (n-1)
        beside p (above smaller smaller)

let rec upSplit p n =
    if n = 0 then p
    else
        let smaller = upSplit p (n-1)
        above p (beside smaller smaller)

let rec cornerSplit p n =
    if n = 0 then p
    else
        let up = upSplit p (n-1)
        let right = rightSplit p (n-1)
        let topLeft = beside up up
        let bottomRight = above right right
        let corner = cornerSplit p (n-1)
        beside (above p topLeft) (above bottomRight corner)

let four p = let top = (beside (flipHoriz p) p) in above (flipVert top) top

let escher p n = four (cornerSplit p n)

(*
   Output
*)
open System.Windows.Forms
open System.Drawing

let mutable form:Form = null

let drawLine (v1,v2) =
    form.CreateGraphics().DrawLine(Pens.Red, v1.X, v1.Y, v2.X, v2.Y)

let paint p =
    form.Refresh()
    (flipVert p) { Origin={X=0.f;Y=0.f}; First={X=500.f;Y=0.f}; Second={X=0.f;Y=500.f} }

let setup() =
    form <- new Form(Size=Size(517,539))
    form.Show()

(*
    Primitive figures
*)
let makePict segs : Pict =
    fun f ->
        let map = coordMap f
        let transform (x1,y1,x2,y2) = map {X=x1;Y=y1}, map {X=x2;Y=y2}
        List.iter (drawLine << transform) segs
let xFig = [
    (0.f, 0.f, 1.f, 1.f)
    (1.f, 0.f, 0.f, 1.f)]
let yFig = [
    (0.5f, 0.f, 0.5f, 0.5f)
    (0.5f, 0.5f, 1.f, 1.f)
    (0.5f, 0.5f, 0.f, 1.f)]
let zFig = [
    (0.f, 1.f, 1.f, 1.f)
    (1.f, 1.f, 0.f, 0.f)
    (0.f, 0.f, 1.f, 0.f)]

(*
    Some test pictures
*)
let xPict = makePict xFig
let yPict = makePict yFig
let zPict = makePict zFig

(*  Usage:

> setup();;
> paint (four (shrink zPict 10));;
> let tile = (above (flipVert yPict) yPict);;
> paint (escher tile 4);;
etc.
*)
Vector.X: single
Multiple items
val single : value:'T -> single (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.single

--------------------
type single = System.Single

Full name: Microsoft.FSharp.Core.single
Vector.Y: single
val x : single
val y : single
val x' : single
val y' : single
val s : single
type Frame =
  {Origin: Vector;
   First: Vector;
   Second: Vector;}

Full name: Script.Frame
Frame.Origin: Vector
type Vector =
  {X: single;
   Y: single;}
  static member ( + ) : Vector * Vector -> Vector
  static member ( * ) : Vector * s:single -> Vector
  static member ( * ) : s:single * Vector -> Vector
  static member ( - ) : Vector * Vector -> Vector

Full name: Script.Vector
Frame.First: Vector
Frame.Second: Vector
type Pict = Frame -> unit

Full name: Script.Pict
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val coordMap : f:Frame -> v:Vector -> Vector

Full name: Script.coordMap
val f : Frame
val v : Vector
val transform : o:Vector -> c1:Vector -> c2:Vector -> p:Pict -> Pict

Full name: Script.transform
val o : Vector
val c1 : Vector
val c2 : Vector
val p : Pict
val p' : (Frame -> unit)
val map : (Vector -> Vector)
val o' : Vector
val flipVert : p:Pict -> Pict

Full name: Script.flipVert
val flipHoriz : p:Pict -> Pict

Full name: Script.flipHoriz
val shrink : p:Pict -> percent:int -> Pict

Full name: Script.shrink
val percent : int
val d : single
val beside : p1:Pict -> p2:Pict -> Pict

Full name: Script.beside
val p1 : Pict
val p2 : Pict
val left : Pict
val right : Pict
val above : p1:Pict -> p2:Pict -> Pict

Full name: Script.above
val low : Pict
val high : Pict
val rightSplit : p:Pict -> n:int -> Pict

Full name: Script.rightSplit
val n : int
val smaller : Pict
val upSplit : p:Pict -> n:int -> Pict

Full name: Script.upSplit
val cornerSplit : p:Pict -> n:int -> Pict

Full name: Script.cornerSplit
val up : Pict
val topLeft : Pict
val bottomRight : Pict
val corner : Pict
val four : p:Pict -> Pict

Full name: Script.four
val top : Pict
val escher : p:Pict -> n:int -> Pict

Full name: Script.escher
namespace System
namespace System.Windows
namespace System.Windows.Forms
namespace System.Drawing
val mutable form : Form

Full name: Script.form
Multiple items
type Form =
  inherit ContainerControl
  new : unit -> Form
  member AcceptButton : IButtonControl with get, set
  member Activate : unit -> unit
  member ActiveMdiChild : Form
  member AddOwnedForm : ownedForm:Form -> unit
  member AllowTransparency : bool with get, set
  member AutoScale : bool with get, set
  member AutoScaleBaseSize : Size with get, set
  member AutoScroll : bool with get, set
  member AutoSize : bool with get, set
  ...
  nested type ControlCollection

Full name: System.Windows.Forms.Form

--------------------
Form() : unit
val drawLine : v1:Vector * v2:Vector -> unit

Full name: Script.drawLine
val v1 : Vector
val v2 : Vector
Control.CreateGraphics() : Graphics
type Pens =
  static member AliceBlue : Pen
  static member AntiqueWhite : Pen
  static member Aqua : Pen
  static member Aquamarine : Pen
  static member Azure : Pen
  static member Beige : Pen
  static member Bisque : Pen
  static member Black : Pen
  static member BlanchedAlmond : Pen
  static member Blue : Pen
  ...

Full name: System.Drawing.Pens
property Pens.Red: Pen
val paint : p:Pict -> unit

Full name: Script.paint
Control.Refresh() : unit
val setup : unit -> unit

Full name: Script.setup
Multiple items
type Size =
  struct
    new : pt:Point -> Size + 1 overload
    member Equals : obj:obj -> bool
    member GetHashCode : unit -> int
    member Height : int with get, set
    member IsEmpty : bool
    member ToString : unit -> string
    member Width : int with get, set
    static val Empty : Size
    static member Add : sz1:Size * sz2:Size -> Size
    static member Ceiling : value:SizeF -> Size
    ...
  end

Full name: System.Drawing.Size

--------------------
Size()
Size(pt: Point) : unit
Size(width: int, height: int) : unit
Control.Show() : unit
Form.Show(owner: IWin32Window) : unit
val makePict : segs:(single * single * single * single) list -> f:Frame -> unit

Full name: Script.makePict
val segs : (single * single * single * single) list
val transform : (single * single * single * single -> Vector * Vector)
val x1 : single
val y1 : single
val x2 : single
val y2 : single
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val iter : action:('T -> unit) -> list:'T list -> unit

Full name: Microsoft.FSharp.Collections.List.iter
val xFig : (float32 * float32 * float32 * float32) list

Full name: Script.xFig
val yFig : (float32 * float32 * float32 * float32) list

Full name: Script.yFig
val zFig : (float32 * float32 * float32 * float32) list

Full name: Script.zFig
val xPict : Pict

Full name: Script.xPict
val yPict : Pict

Full name: Script.yPict
val zPict : Pict

Full name: Script.zPict
Raw view Test code New version

More information

Link:http://fssnip.net/aj
Posted:12 years ago
Author:Jonas Avelin
Tags: graphics