22/08: f# wraper for Rx framework
according to jafar husain the people now have access to the awesome rx framework library.
this is great except you can not use it easily from f#
with this library wrapper you can access all the observable methods from the module OSeq and build observable collections using the oseq monad builder.
following is the interesting bits of an example that shows both, it encapsulates a triple-click:
("win" is a System.Windows.Window)
open Microsoft.FSharp.Collections
let mousedown = OSeq.from_event win.MouseDown
let mouseup = OSeq.from_event win.MouseUp
let rec trippleclick = oseq {
for x in mousedown |> OSeq.waitUntil mouseup |> OSeq.take 1 do
let mili = DateTime.Now.Ticks
for y in mousedown |> OSeq.waitUntil mouseup |> OSeq.take 1 do
for z in mousedown |> OSeq.waitUntil mouseup |> OSeq.take 1 do
if DateTime.Now.Ticks - mili < (int64 5000000) then
yield "click"
return! trippleclick
else
return! trippleclick
}
the following library does not presently wrap every observable function but is already quite useful.
module Microsoft.FSharp.Collections
open System
open System.Linq
open System.Collections.Generic
open System.Linq.Expressions
module OSeq =
type ObservableBuilder() =
member this.Bind(a, f) = Observable.SelectMany(a, Func<'a, 'b IObservable>(f))
member this.Return x = Observable.Return x
member this.Delay f = Observable.Defer(Func<'a IObservable>(f))
member this.Yield x = Observable.Return x
member this.For(a, f) = Observable.SelectMany(a, Func<'a, 'b IObservable>(f))
//member this.While : (unit -> bool) * M<'a> -> M<'a>
member this.Combine(left, right) = Observable.Concat(left, right)
member this.TryFinally(a : 'a IObservable, f) = //Observable.Finally(a, b) ??
{new 'a IObservable with
member this.Subscribe(o) =
a.Subscribe(
{new 'a IObserver with
member this.OnNext x = o.OnNext x
member this.OnError e = f(); o.OnError e
member this.OnCompleted () = f(); o.OnCompleted()
}
)
}
member this.TryWith(a : 'a IObservable, f : Exception -> 'a IObservable) = Observable.Catch(a, Func<Exception, 'a IObservable>(f))
member this.Using(a : #IDisposable, f : #IDisposable -> 'a IObservable) = this.TryFinally(f a, fun () -> a.Dispose() )
member this.Zero () = Observable.Never()
let oseq = ObservableBuilder()
let listen f (o : 'a IObservable) =
o.Subscribe
{new IObserver<'a> with
member this.OnNext a = f a
member this.OnCompleted () = ()
member this.OnError e = raise e
}
let zip a b = oseq {
for a' in a do
for b' in b do
return a', b'
}
/// .NET events are wrapped in a generic IEvent object with two type arguments:
/// the first is the delegate type and the second is the type of the event arguments.
/// Use this overload to convert these events into IObservable.
let from_event (ev : IEvent<'a, 'b>) =
{new 'b Event IObservable with
member this.Subscribe o =
let next = Action<obj, 'b>(fun source a -> o.OnNext(new 'b Event(source, a)))
let senderParameter = Expression.Parameter(typeof<obj>, "sender")
let argumentsParameter = Expression.Parameter(typeof<'b>, "arguments")
let parameterArray = [| (senderParameter :> Expression); (argumentsParameter :> Expression) |]
let handlerExpression = Expression.Lambda<'a>(Expression.Call(Expression.Constant(next.Target), next.Method, parameterArray), [| senderParameter; argumentsParameter |])
let handler = handlerExpression.Compile()
ev.AddHandler(handler)
{new IDisposable with member this.Dispose() = ev.RemoveHandler(handler) }
}
/// Native F# events are of type IEvent but with only one type argument: the type of the event arguments.
/// This method converts native F# events to IObservable.
let from_ievent<'a, 'T> (event : 'a IEvent) =
{new IObservable<'a> with
member this.Subscribe o =
//event |> Event.listen (fun e -> o.OnNext e)
let handler = Handler(fun _ e -> o.OnNext e)
event.AddHandler handler
{new IDisposable with member this.Dispose() = event.RemoveHandler handler }
}
let merge left right = Observable.Merge(left, right)
let skip n o = Observable.Skip(o, n)
let pairwise o = zip o (skip 1 o)
let map f o = Observable.Select(o, Func<'a, 'b>(f))
let filter f o = Observable.Where(o, Func<'a, bool>(f))
let until a b = Observable.Until(b, a)
let waitUntil a b = Observable.WaitUntil(b, a)
let take n o = Observable.Take(o, n)
let takeWhile f o = Observable.TakeWhile(o, Func<'a, bool>(f))
let selectMany f o = Observable.SelectMany(o, Func<'a, 'b IObservable>(f))
let holdUntilChanged o = Observable.HoldUntilChanged o
let concat a b = Observable.Concat(b, a)
let fold f s o = Observable.Aggregate(o, s, Func<'a, 'b, 'a>(f))
let reduce f o = Observable.Aggregate(o, Func<'a, 'a, 'a>(f))
let first = Observable.First
let last = Observable.Last
let scan f s o = Observable.Scan(o, s, Func<'a, 'a, 'a>(f))
let skipWhile f o = Observable.SkipWhile(o, Func<'a, bool>(f))
let flatten = Observable.Flatten
let cons a o = Observable.Cons(a, o)
let range s c = Observable.Range(s, c)
let interval i = Observable.Interval(i)
let repeat () = Observable.Repeat()
let Let f o = Observable.Let(o, Func<'a IObservable, 'b IObservable>(f))
let start f = Observable.Start(Func<'a>(f))
let post context o = Observable.Post(o, context)
let cast<'a, 'b> (e : 'a IObservable) = e |> map (fun evt -> (evt :> obj) :?> 'b)
let of_type<'a, 'b> e = e |> cast<'a, obj> |> filter (function :? 'a -> true | _ -> false) |> cast<obj, 'b>
let to_seq o = Observable.ToEnumerable o
/// returns a new observer that fires when its state is true.
/// the returned observer's state is managed by the 'start' and 'stop' argument observer's that, when fired, set the state to true and false respectivly.
let state start stop ob =
let set = ref false
let regstart = start |> listen (fun e -> set := true)
let regstop = stop |> listen (fun e -> set := false)
{new 'a IObservable with
member this.Subscribe o =
let regob = ob |> listen (fun x -> if !set then o.OnNext x)
{new IDisposable with member this.Dispose () = regstart.Dispose(); regstop.Dispose(); regob.Dispose() }
}
let to_async (x : 'a IObservable) =
Async.Primitive(
fun (answer, exn, exccancel) ->
let answers = List()
x.Subscribe
{new 'a IObserver with
member this.OnNext x = answers.Add x
member this.OnCompleted () = answer answers
member this.OnError ex = exn ex
} |> ignore )
let from_async asynchronous =
{new 'a IObservable with
member this.Subscribe(observer) =
let update = ref true
async {
try
let! value = asynchronous
if !update then
observer.OnNext value
observer.OnCompleted()
with | e -> observer.OnError e
} |> Async.Start
{new IDisposable with
member this.Dispose() =
update := false
}
}
//________________________________________________________________________________________________________
module Seq =
let to_oseq (x : 'a seq) = x.ToObservable()
let oseq = OSeq.oseq
this is great except you can not use it easily from f#
with this library wrapper you can access all the observable methods from the module OSeq and build observable collections using the oseq monad builder.
following is the interesting bits of an example that shows both, it encapsulates a triple-click:
("win" is a System.Windows.Window)
open Microsoft.FSharp.Collections
let mousedown = OSeq.from_event win.MouseDown
let mouseup = OSeq.from_event win.MouseUp
let rec trippleclick = oseq {
for x in mousedown |> OSeq.waitUntil mouseup |> OSeq.take 1 do
let mili = DateTime.Now.Ticks
for y in mousedown |> OSeq.waitUntil mouseup |> OSeq.take 1 do
for z in mousedown |> OSeq.waitUntil mouseup |> OSeq.take 1 do
if DateTime.Now.Ticks - mili < (int64 5000000) then
yield "click"
return! trippleclick
else
return! trippleclick
}
the following library does not presently wrap every observable function but is already quite useful.
module Microsoft.FSharp.Collections
open System
open System.Linq
open System.Collections.Generic
open System.Linq.Expressions
module OSeq =
type ObservableBuilder() =
member this.Bind(a, f) = Observable.SelectMany(a, Func<'a, 'b IObservable>(f))
member this.Return x = Observable.Return x
member this.Delay f = Observable.Defer(Func<'a IObservable>(f))
member this.Yield x = Observable.Return x
member this.For(a, f) = Observable.SelectMany(a, Func<'a, 'b IObservable>(f))
//member this.While : (unit -> bool) * M<'a> -> M<'a>
member this.Combine(left, right) = Observable.Concat(left, right)
member this.TryFinally(a : 'a IObservable, f) = //Observable.Finally(a, b) ??
{new 'a IObservable with
member this.Subscribe(o) =
a.Subscribe(
{new 'a IObserver with
member this.OnNext x = o.OnNext x
member this.OnError e = f(); o.OnError e
member this.OnCompleted () = f(); o.OnCompleted()
}
)
}
member this.TryWith(a : 'a IObservable, f : Exception -> 'a IObservable) = Observable.Catch(a, Func<Exception, 'a IObservable>(f))
member this.Using(a : #IDisposable, f : #IDisposable -> 'a IObservable) = this.TryFinally(f a, fun () -> a.Dispose() )
member this.Zero () = Observable.Never()
let oseq = ObservableBuilder()
let listen f (o : 'a IObservable) =
o.Subscribe
{new IObserver<'a> with
member this.OnNext a = f a
member this.OnCompleted () = ()
member this.OnError e = raise e
}
let zip a b = oseq {
for a' in a do
for b' in b do
return a', b'
}
/// .NET events are wrapped in a generic IEvent object with two type arguments:
/// the first is the delegate type and the second is the type of the event arguments.
/// Use this overload to convert these events into IObservable.
let from_event (ev : IEvent<'a, 'b>) =
{new 'b Event IObservable with
member this.Subscribe o =
let next = Action<obj, 'b>(fun source a -> o.OnNext(new 'b Event(source, a)))
let senderParameter = Expression.Parameter(typeof<obj>, "sender")
let argumentsParameter = Expression.Parameter(typeof<'b>, "arguments")
let parameterArray = [| (senderParameter :> Expression); (argumentsParameter :> Expression) |]
let handlerExpression = Expression.Lambda<'a>(Expression.Call(Expression.Constant(next.Target), next.Method, parameterArray), [| senderParameter; argumentsParameter |])
let handler = handlerExpression.Compile()
ev.AddHandler(handler)
{new IDisposable with member this.Dispose() = ev.RemoveHandler(handler) }
}
/// Native F# events are of type IEvent but with only one type argument: the type of the event arguments.
/// This method converts native F# events to IObservable.
let from_ievent<'a, 'T> (event : 'a IEvent) =
{new IObservable<'a> with
member this.Subscribe o =
//event |> Event.listen (fun e -> o.OnNext e)
let handler = Handler(fun _ e -> o.OnNext e)
event.AddHandler handler
{new IDisposable with member this.Dispose() = event.RemoveHandler handler }
}
let merge left right = Observable.Merge(left, right)
let skip n o = Observable.Skip(o, n)
let pairwise o = zip o (skip 1 o)
let map f o = Observable.Select(o, Func<'a, 'b>(f))
let filter f o = Observable.Where(o, Func<'a, bool>(f))
let until a b = Observable.Until(b, a)
let waitUntil a b = Observable.WaitUntil(b, a)
let take n o = Observable.Take(o, n)
let takeWhile f o = Observable.TakeWhile(o, Func<'a, bool>(f))
let selectMany f o = Observable.SelectMany(o, Func<'a, 'b IObservable>(f))
let holdUntilChanged o = Observable.HoldUntilChanged o
let concat a b = Observable.Concat(b, a)
let fold f s o = Observable.Aggregate(o, s, Func<'a, 'b, 'a>(f))
let reduce f o = Observable.Aggregate(o, Func<'a, 'a, 'a>(f))
let first = Observable.First
let last = Observable.Last
let scan f s o = Observable.Scan(o, s, Func<'a, 'a, 'a>(f))
let skipWhile f o = Observable.SkipWhile(o, Func<'a, bool>(f))
let flatten = Observable.Flatten
let cons a o = Observable.Cons(a, o)
let range s c = Observable.Range(s, c)
let interval i = Observable.Interval(i)
let repeat () = Observable.Repeat()
let Let f o = Observable.Let(o, Func<'a IObservable, 'b IObservable>(f))
let start f = Observable.Start(Func<'a>(f))
let post context o = Observable.Post(o, context)
let cast<'a, 'b> (e : 'a IObservable) = e |> map (fun evt -> (evt :> obj) :?> 'b)
let of_type<'a, 'b> e = e |> cast<'a, obj> |> filter (function :? 'a -> true | _ -> false) |> cast<obj, 'b>
let to_seq o = Observable.ToEnumerable o
/// returns a new observer that fires when its state is true.
/// the returned observer's state is managed by the 'start' and 'stop' argument observer's that, when fired, set the state to true and false respectivly.
let state start stop ob =
let set = ref false
let regstart = start |> listen (fun e -> set := true)
let regstop = stop |> listen (fun e -> set := false)
{new 'a IObservable with
member this.Subscribe o =
let regob = ob |> listen (fun x -> if !set then o.OnNext x)
{new IDisposable with member this.Dispose () = regstart.Dispose(); regstop.Dispose(); regob.Dispose() }
}
let to_async (x : 'a IObservable) =
Async.Primitive(
fun (answer, exn, exccancel) ->
let answers = List()
x.Subscribe
{new 'a IObserver with
member this.OnNext x = answers.Add x
member this.OnCompleted () = answer answers
member this.OnError ex = exn ex
} |> ignore )
let from_async asynchronous =
{new 'a IObservable with
member this.Subscribe(observer) =
let update = ref true
async {
try
let! value = asynchronous
if !update then
observer.OnNext value
observer.OnCompleted()
with | e -> observer.OnError e
} |> Async.Start
{new IDisposable with
member this.Dispose() =
update := false
}
}
//________________________________________________________________________________________________________
module Seq =
let to_oseq (x : 'a seq) = x.ToObservable()
let oseq = OSeq.oseq
21/06: 3d transfomations
here is the beginnings of a 3D transformation engine.
I thought that it utilized a few impressive features of f# namely: matrix operations, active patterns, and first class events.
the matrix class is defined in FSharp.PowerPack.dll
you can controll the camera and viewer thusley (mouse movements are relative):
hold down 'z' and left mouse button and move mouse to change camera z position.
hold down 'x' and left mouse button and move mouse to change camera x and y position.
use the same commands as above but with the right mouse button to controll viewer position.
hold down 'r' and left mouse button and move mouse to change camera rotation in x/y-axis.
hold down 'r' and right mouse button and move mouse to change camera rotation in z-axis.
for display, it uses the SdlSimple library i wrote and which you can find a link to download here.
#light
//active pattern to catch return values from a matrix transformation:
let (|Matrix|) (m : matrix) =
let getrows column = [0..m.NumCols - 1] |> List.map (fun row -> m.[column, row])
[0..m.NumRows - 1] |> List.map (fun col -> getrows col)
let mutable (viewerx, viewery, viewerz) = (25.0, 25.0, -150.0) //viewer location
let mutable (rotationx, rotationy, rotationz) = (0.0, 0.0, 0.0) //cammera rotation
let mutable (camerax, cameray, cameraz) = (0.0, 0.0, -100.0) //cammera location
//transform a 3d point into 2d space:
let transform (pointx, pointy, pointz) =
let (Matrix [[dx];
[dy];
[dz]])
=
matrix [[1.0;0.0;0.0];
[0.0;cos -rotationx;sin -rotationx];
[0.0;-sin -rotationx;cos -rotationx]]
*
matrix [[cos -rotationy;0.0;-sin -rotationy];
[0.0;1.0;0.0];
[sin -rotationy;0.0;cos -rotationy]]
*
matrix [[cos -rotationz;sin -rotationz;0.0];
[-sin -rotationz;cos -rotationz;0.0];
[0.0;0.0;1.0]]
*
(
matrix [[pointx];
[pointy];
[pointz]]
-
matrix [[camerax];
[cameray];
[cameraz]]
)
let (Matrix [[fx];
[fy];
[fz];
[fw]])
=
matrix [[1.0;0.0;0.0;-viewerx];
[0.0;1.0;0.0;-viewery];
[0.0;0.0;1.0;0.0];
[0.0;0.0;1.0 / viewerz;0.0]]
*
matrix [[dx];
[dy];
[dz];
[1.0]]
(fx / fw |> int, fy / fw |> int)
type shape = { vectors : (float * float * float) list; lines : (int * int) list }
let cube = {
vectors =
[0.0, 0.0, 0.0;
0.0, 50.0, 0.0;
50.0, 50.0, 0.0;
50.0, 0.0, 0.0;
0.0, 0.0, 50.0;
0.0, 50.0, 50.0;
50.0, 50.0, 50.0;
50.0, 0.0, 50.0];
lines = [0,1; 1,2; 2,3; 3,0; 4,5; 5,6; 6,7; 7,4; 0,4; 1,5; 2,6; 3,7]
}
let mutable offsetcube = cube
open System
open Seq
open SdlSimple
SdlSimpleSetup 500 550 16 false
cls "fps"
//debug information:
draw {
writey "viewer:" (400, 400)
writey "x" (400, 410); writey viewerx (420, 410)
writey "y" (400, 420); writey viewery (420, 420)
writey "z" (400, 430); writey viewerz (420, 430)
writey "camera:" (400, 450)
writey "x" (400, 460); writey camerax (420, 460)
writey "y" (400, 470); writey cameray (420, 470)
writey "z" (400, 480); writey cameraz (420, 480)
writey "rotation:" (400, 500)
writey "x" (400, 510); writey rotationx (420, 510)
writey "y" (400, 520); writey rotationy (420, 520)
writey "z" (400, 530); writey rotationz (420, 530)
}
//draw cube:
draw {
let redpixel (x, y) = pixel (colour 255 0 0) (x + 250, y + 275)
let whiteline (x1, y1) (x2, y2) = line (colour 255 255 255) (x1 + 250, y1 + 275) (x2 + 250, y2 + 275)
let points = offsetcube.vectors |> map transform |> Seq.to_array
offsetcube.lines |> Seq.iter (fun (l,r) -> whiteline points.[l] points.[r] |> ignore)
points |> Seq.iter redpixel
}
open EventExtensions
//camera and viewer movements:
Event.mousemove |> Event.pairwise |> Event.state Event.leftdown Event.leftup |> Event.stateofkey 120
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
camerax <- camerax + float(x2 - x1); cameray <- cameray + float(y2 - y1)
)
Event.mousemove |> Event.pairwise |> Event.state Event.leftdown Event.leftup |> Event.stateofkey 122
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
cameraz <- cameraz + float(y2 - y1) / 2.0
)
Event.mousemove |> Event.pairwise |> Event.state Event.rightdown Event.rightup |> Event.stateofkey 120
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
viewerx <- viewerx + float(x2 - x1); viewery <- viewery + float(y2 - y1)
)
Event.mousemove |> Event.pairwise |> Event.state Event.rightdown Event.rightup |> Event.stateofkey 122
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
viewerz <- viewerz - float(y2 - y1) / 2.0
)
Event.mousemove |> Event.pairwise |> Event.state Event.leftdown Event.leftup |> Event.stateofkey 114
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
rotationy <- rotationy - (float(x2 - x1) * 0.01); rotationx <- rotationx + (float(y2 - y1) * 0.01)
)
Event.mousemove |> Event.pairwise |> Event.state Event.rightdown Event.rightup |> Event.stateofkey 114
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
rotationz <- rotationz + (float(y2 - y1) * 0.02)
)
Console.ReadLine() |> ignore
this program uses some extensions to the Event class (EventExtensions.fs) that i have made.
these include refining of SdlSimple events and the 'state' event combinator.
#light
open SdlSimple
open System
module Event =
/// returns a new event that fires when its state is true.
/// the returned event's state is managed by the 'a and 'b argument events that, when fired, set the state to true and false respectivly.
let state (start : IEvent<'a>) (stop : IEvent<'b>) (e : IEvent<'T>) =
let set = ref false
start.Add (fun e -> set := true)
stop.Add (fun e -> set := false)
{new IEvent<'T> with
member this.Add(f) = e.Add (fun x -> if !set then f x)
//this is not a proper implementation for AddHandler and RemoveHandler:
member this.AddHandler(h) = ()
member this.RemoveHandler(h) = ()
}
/// returns an IEvent that fires when the specified key is pressed.
let keypress key = events |> Event.filter ((=) (KeyDown key)) |> Event.map (fun (KeyDown key) -> ())
/// returns an IEvent that fires when the specified key is released.
let keyrelease key = events |> Event.filter ((=) (KeyUp key)) |> Event.map (fun (KeyUp key) -> ())
/// return an Event.state function whos state is altered by the press and release of the argument 'key'.
let stateofkey key = state (keypress key) (keyrelease key)
/// returns an IEvent that fires when the mouse is moved. returns mouse co-ordinates:
let mousemove =
events
|> Event.filter (function MouseMove(x, y) -> true | _ -> false)
|> Event.map (fun (MouseMove(x, y)) -> x, y)
/// fires on a left mouse button down event:
let leftdown = events |> Event.filter ((=) (MouseDown(1)))
/// fires on a left mouse button up event:
let leftup = events |> Event.filter ((=) (MouseUp(1)))
/// fires on a right mouse button down event:
let rightdown = events |> Event.filter ((=) (MouseDown(3)))
/// fires on a right mouse button up event:
let rightup = events |> Event.filter ((=) (MouseUp(3)))
I thought that it utilized a few impressive features of f# namely: matrix operations, active patterns, and first class events.
the matrix class is defined in FSharp.PowerPack.dll
you can controll the camera and viewer thusley (mouse movements are relative):
hold down 'z' and left mouse button and move mouse to change camera z position.
hold down 'x' and left mouse button and move mouse to change camera x and y position.
use the same commands as above but with the right mouse button to controll viewer position.
hold down 'r' and left mouse button and move mouse to change camera rotation in x/y-axis.
hold down 'r' and right mouse button and move mouse to change camera rotation in z-axis.
for display, it uses the SdlSimple library i wrote and which you can find a link to download here.
#light
//active pattern to catch return values from a matrix transformation:
let (|Matrix|) (m : matrix) =
let getrows column = [0..m.NumCols - 1] |> List.map (fun row -> m.[column, row])
[0..m.NumRows - 1] |> List.map (fun col -> getrows col)
let mutable (viewerx, viewery, viewerz) = (25.0, 25.0, -150.0) //viewer location
let mutable (rotationx, rotationy, rotationz) = (0.0, 0.0, 0.0) //cammera rotation
let mutable (camerax, cameray, cameraz) = (0.0, 0.0, -100.0) //cammera location
//transform a 3d point into 2d space:
let transform (pointx, pointy, pointz) =
let (Matrix [[dx];
[dy];
[dz]])
=
matrix [[1.0;0.0;0.0];
[0.0;cos -rotationx;sin -rotationx];
[0.0;-sin -rotationx;cos -rotationx]]
*
matrix [[cos -rotationy;0.0;-sin -rotationy];
[0.0;1.0;0.0];
[sin -rotationy;0.0;cos -rotationy]]
*
matrix [[cos -rotationz;sin -rotationz;0.0];
[-sin -rotationz;cos -rotationz;0.0];
[0.0;0.0;1.0]]
*
(
matrix [[pointx];
[pointy];
[pointz]]
-
matrix [[camerax];
[cameray];
[cameraz]]
)
let (Matrix [[fx];
[fy];
[fz];
[fw]])
=
matrix [[1.0;0.0;0.0;-viewerx];
[0.0;1.0;0.0;-viewery];
[0.0;0.0;1.0;0.0];
[0.0;0.0;1.0 / viewerz;0.0]]
*
matrix [[dx];
[dy];
[dz];
[1.0]]
(fx / fw |> int, fy / fw |> int)
type shape = { vectors : (float * float * float) list; lines : (int * int) list }
let cube = {
vectors =
[0.0, 0.0, 0.0;
0.0, 50.0, 0.0;
50.0, 50.0, 0.0;
50.0, 0.0, 0.0;
0.0, 0.0, 50.0;
0.0, 50.0, 50.0;
50.0, 50.0, 50.0;
50.0, 0.0, 50.0];
lines = [0,1; 1,2; 2,3; 3,0; 4,5; 5,6; 6,7; 7,4; 0,4; 1,5; 2,6; 3,7]
}
let mutable offsetcube = cube
open System
open Seq
open SdlSimple
SdlSimpleSetup 500 550 16 false
cls "fps"
//debug information:
draw {
writey "viewer:" (400, 400)
writey "x" (400, 410); writey viewerx (420, 410)
writey "y" (400, 420); writey viewery (420, 420)
writey "z" (400, 430); writey viewerz (420, 430)
writey "camera:" (400, 450)
writey "x" (400, 460); writey camerax (420, 460)
writey "y" (400, 470); writey cameray (420, 470)
writey "z" (400, 480); writey cameraz (420, 480)
writey "rotation:" (400, 500)
writey "x" (400, 510); writey rotationx (420, 510)
writey "y" (400, 520); writey rotationy (420, 520)
writey "z" (400, 530); writey rotationz (420, 530)
}
//draw cube:
draw {
let redpixel (x, y) = pixel (colour 255 0 0) (x + 250, y + 275)
let whiteline (x1, y1) (x2, y2) = line (colour 255 255 255) (x1 + 250, y1 + 275) (x2 + 250, y2 + 275)
let points = offsetcube.vectors |> map transform |> Seq.to_array
offsetcube.lines |> Seq.iter (fun (l,r) -> whiteline points.[l] points.[r] |> ignore)
points |> Seq.iter redpixel
}
open EventExtensions
//camera and viewer movements:
Event.mousemove |> Event.pairwise |> Event.state Event.leftdown Event.leftup |> Event.stateofkey 120
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
camerax <- camerax + float(x2 - x1); cameray <- cameray + float(y2 - y1)
)
Event.mousemove |> Event.pairwise |> Event.state Event.leftdown Event.leftup |> Event.stateofkey 122
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
cameraz <- cameraz + float(y2 - y1) / 2.0
)
Event.mousemove |> Event.pairwise |> Event.state Event.rightdown Event.rightup |> Event.stateofkey 120
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
viewerx <- viewerx + float(x2 - x1); viewery <- viewery + float(y2 - y1)
)
Event.mousemove |> Event.pairwise |> Event.state Event.rightdown Event.rightup |> Event.stateofkey 122
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
viewerz <- viewerz - float(y2 - y1) / 2.0
)
Event.mousemove |> Event.pairwise |> Event.state Event.leftdown Event.leftup |> Event.stateofkey 114
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
rotationy <- rotationy - (float(x2 - x1) * 0.01); rotationx <- rotationx + (float(y2 - y1) * 0.01)
)
Event.mousemove |> Event.pairwise |> Event.state Event.rightdown Event.rightup |> Event.stateofkey 114
|> Event.listen (fun ((x1, y1), (x2, y2)) ->
rotationz <- rotationz + (float(y2 - y1) * 0.02)
)
Console.ReadLine() |> ignore
EventExtensions.fs
this program uses some extensions to the Event class (EventExtensions.fs) that i have made.
these include refining of SdlSimple events and the 'state' event combinator.
#light
open SdlSimple
open System
module Event =
/// returns a new event that fires when its state is true.
/// the returned event's state is managed by the 'a and 'b argument events that, when fired, set the state to true and false respectivly.
let state (start : IEvent<'a>) (stop : IEvent<'b>) (e : IEvent<'T>) =
let set = ref false
start.Add (fun e -> set := true)
stop.Add (fun e -> set := false)
{new IEvent<'T> with
member this.Add(f) = e.Add (fun x -> if !set then f x)
//this is not a proper implementation for AddHandler and RemoveHandler:
member this.AddHandler(h) = ()
member this.RemoveHandler(h) = ()
}
/// returns an IEvent that fires when the specified key is pressed.
let keypress key = events |> Event.filter ((=) (KeyDown key)) |> Event.map (fun (KeyDown key) -> ())
/// returns an IEvent that fires when the specified key is released.
let keyrelease key = events |> Event.filter ((=) (KeyUp key)) |> Event.map (fun (KeyUp key) -> ())
/// return an Event.state function whos state is altered by the press and release of the argument 'key'.
let stateofkey key = state (keypress key) (keyrelease key)
/// returns an IEvent that fires when the mouse is moved. returns mouse co-ordinates:
let mousemove =
events
|> Event.filter (function MouseMove(x, y) -> true | _ -> false)
|> Event.map (fun (MouseMove(x, y)) -> x, y)
/// fires on a left mouse button down event:
let leftdown = events |> Event.filter ((=) (MouseDown(1)))
/// fires on a left mouse button up event:
let leftup = events |> Event.filter ((=) (MouseUp(1)))
/// fires on a right mouse button down event:
let rightdown = events |> Event.filter ((=) (MouseDown(3)))
/// fires on a right mouse button up event:
let rightup = events |> Event.filter ((=) (MouseUp(3)))
i set out to compare the relative speeds of some slightly different versions of quicksort for lists.
i think the results are worth noting.
let rec qsort_else f lst =
if lst = [] then [] else
let pivot = List.hd lst
let left = List.tl lst |> List.filter (f pivot) |> qsort_else f
let right = List.tl lst |> List.filter (f pivot >> not) |> qsort_else f
left @ [pivot] @ right
let rec qsort_append f = function
| [] -> []
| head :: tail ->
(tail |> List.filter (f head) |> qsort_append f)
@ [head] @
(tail |> List.filter (f head >> not) |> qsort_append f)
let rec qsort_pipe f = function
| [] -> []
| head :: tail ->
tail |> List.partition (f head)
|> (fun (x, y) -> qsort_pipe f x, qsort_pipe f y)
|> (fun (left, right) -> left @ [head] @ right)
let qsort_CPS f lst =
let rec sort l clst r c =
match clst with
| [] -> c (l @ [] @ r)
| a :: [] -> c (l @ [a] @ r)
| _ ->
let pivot = List.hd clst
let left = List.tl clst |> List.filter (f pivot)
let right = List.tl clst |> List.filter (f pivot >> not)
sort l left [pivot] (fun x -> sort x right r c)
sort [] lst [] (fun x -> x)
i also compared these four versions with the default List.sort and the mergesort which i copied out of local.fs from the f# source (search for stable_sort).
i only tested one kind of input data: a large, unsorted list comprised of random integer data in the same range as the length of the list. specifically generated this way:
let _random = System.Random()
let rand() = _random.Next()
let num = 200000
let unsorted = [1..num] |> List.map (fun _ -> rand() % num)
i ran each sorting method on the same unsorted list five times and averaged the result in milliseconds.
these are the results using version 1.9.6.2 of the f# compiler:
List.sort: 500, 457, 525, 468, 468, --> average: 483.600000
merge sort: 510, 482, 463, 542, 467, --> average: 492.800000
qsort_else: 942, 917, 944, 968, 953, --> average: 944.800000
qsort_append: 888, 836, 854, 890, 807, --> average: 855.000000
qsort_pipe: 672, 727, 751, 788, 669, --> average: 721.400000
qsort_CPS:
+the continuation passing style version of quicksort overflows the stack before it returns any meaningful data. if given a much smaller dataset it is still at least 100 times slower than the other sorting methods.
+pattern matching on a list appears to be slightly faster than an if/then/else case that does the same thing.
+the fastest quicksort method pipes the list through List.partition instead of filtering twice.
+an optimized mergesort is faster than any of my quicksort implementations and this is the method that List.sort uses internally i believe.
the most interesting information though, came when i ran the same tests on the most recently released version of f#
these are the results compiled using f# 1.9.6.16:
List.sort: 1507, 1405, 1408, 1450, 1339, --> average: 1421.800000
merge sort: 834, 768, 741, 723, 706, --> average: 754.400000
qsort_else: 1125, 1104, 1051, 1099, 1013, --> average: 1078.400000
qsort_append: 1033, 946, 1000, 1073, 978, --> average: 1006.000000
qsort_pipe: 836, 860, 833, 748, 795, --> average: 814.400000
qsort_CPS:
+it is worth noting that ALL times are slightly slower but what is quite striking is:
+the native List.sort method is now almost twice as slow as my fastest quicksort method and three times slower than in the previous version of the compiler.
+since mergesort is still the fastest method (although about 60% slower than the 1.9.6.2 compiled version) and List.sort is operating so sluggishly it would lead me to believe that List.sort in the newest f# compiler no longer uses the mergesort method in local.fs.
what method does it use?
i think the results are worth noting.
let rec qsort_else f lst =
if lst = [] then [] else
let pivot = List.hd lst
let left = List.tl lst |> List.filter (f pivot) |> qsort_else f
let right = List.tl lst |> List.filter (f pivot >> not) |> qsort_else f
left @ [pivot] @ right
let rec qsort_append f = function
| [] -> []
| head :: tail ->
(tail |> List.filter (f head) |> qsort_append f)
@ [head] @
(tail |> List.filter (f head >> not) |> qsort_append f)
let rec qsort_pipe f = function
| [] -> []
| head :: tail ->
tail |> List.partition (f head)
|> (fun (x, y) -> qsort_pipe f x, qsort_pipe f y)
|> (fun (left, right) -> left @ [head] @ right)
let qsort_CPS f lst =
let rec sort l clst r c =
match clst with
| [] -> c (l @ [] @ r)
| a :: [] -> c (l @ [a] @ r)
| _ ->
let pivot = List.hd clst
let left = List.tl clst |> List.filter (f pivot)
let right = List.tl clst |> List.filter (f pivot >> not)
sort l left [pivot] (fun x -> sort x right r c)
sort [] lst [] (fun x -> x)
i also compared these four versions with the default List.sort and the mergesort which i copied out of local.fs from the f# source (search for stable_sort).
i only tested one kind of input data: a large, unsorted list comprised of random integer data in the same range as the length of the list. specifically generated this way:
let _random = System.Random()
let rand() = _random.Next()
let num = 200000
let unsorted = [1..num] |> List.map (fun _ -> rand() % num)
i ran each sorting method on the same unsorted list five times and averaged the result in milliseconds.
these are the results using version 1.9.6.2 of the f# compiler:
List.sort: 500, 457, 525, 468, 468, --> average: 483.600000
merge sort: 510, 482, 463, 542, 467, --> average: 492.800000
qsort_else: 942, 917, 944, 968, 953, --> average: 944.800000
qsort_append: 888, 836, 854, 890, 807, --> average: 855.000000
qsort_pipe: 672, 727, 751, 788, 669, --> average: 721.400000
qsort_CPS:
conclusions:
+the continuation passing style version of quicksort overflows the stack before it returns any meaningful data. if given a much smaller dataset it is still at least 100 times slower than the other sorting methods.
+pattern matching on a list appears to be slightly faster than an if/then/else case that does the same thing.
+the fastest quicksort method pipes the list through List.partition instead of filtering twice.
+an optimized mergesort is faster than any of my quicksort implementations and this is the method that List.sort uses internally i believe.
the most interesting information though, came when i ran the same tests on the most recently released version of f#
these are the results compiled using f# 1.9.6.16:
List.sort: 1507, 1405, 1408, 1450, 1339, --> average: 1421.800000
merge sort: 834, 768, 741, 723, 706, --> average: 754.400000
qsort_else: 1125, 1104, 1051, 1099, 1013, --> average: 1078.400000
qsort_append: 1033, 946, 1000, 1073, 978, --> average: 1006.000000
qsort_pipe: 836, 860, 833, 748, 795, --> average: 814.400000
qsort_CPS:
+it is worth noting that ALL times are slightly slower but what is quite striking is:
+the native List.sort method is now almost twice as slow as my fastest quicksort method and three times slower than in the previous version of the compiler.
+since mergesort is still the fastest method (although about 60% slower than the 1.9.6.2 compiled version) and List.sort is operating so sluggishly it would lead me to believe that List.sort in the newest f# compiler no longer uses the mergesort method in local.fs.
what method does it use?
the wpf build of the silverlight charting toolkit has recently been released:
Delay's Blog
using jafar husain's excellent tutorial on creating a custom chart series:
Writing Your Own Silverlight Chart Series (Part 1): Making Designers Happy
and
Writing Your Own Silverlight Chart Series (Part 2): Implementing the Series
i was able to create a function series in f#:
#light
namespace Charts
open System
open System.Windows
open System.Windows.Media
open System.Windows.Markup
open System.Windows.Shapes
open System.Windows.Controls
open System.Windows.Controls.DataVisualization
open System.Windows.Controls.DataVisualization.Charting
module Seq =
let of_type<'a> (s : System.Collections.IEnumerable) =
seq {
for item in s do
match item with
| :? 'a as item -> yield item
| _ -> ()
}
let range (s : 'a seq) =
if Seq.isEmpty s then None else
s |> Seq.fold
(fun (min, max) a ->
let max = if a > max then a else max
let min = if a < min then a else min
(min, max)
) (Seq.hd s, Seq.hd s) |> Some
let (|Range|_|) (range : 'a Range) =
if range.HasData then Range (range.Minimum, range.Maximum) |> Some else None
type public FunctionSeries(?fx : float -> float) as this =
inherit Series()
[<DefaultValue>]
static val mutable public PointsProperty : DependencyProperty
static do FunctionSeries.PointsProperty <- DependencyProperty.Register("Points", typeof<PointCollection>, typeof<FunctionSeries>)
let mutable itemSource : System.Collections.IEnumerable = null
let mutable plotArea : Canvas = null
let mutable (xaxis : IAxis), (yaxis : IRangeAxis) = null, null
let mutable range = Range(-1.0, 1.0)
let mutable f = fun x -> x
let calculateItems () =
let detail = 600.0
match range with
| Seq.Range (min, max) ->
[0.0..detail]
|> List.map (fun x -> x * ((max - min) / detail) + min)
|> Seq.map (fun x -> Point(x, f x))
| _ -> Seq.empty
do
match fx with | Some fx -> f <- fx | None -> ()
itemSource <- calculateItems()
do
use stream = (Application.GetResourceStream(Uri("FunctionSeries.xaml", UriKind.RelativeOrAbsolute))).Stream
this.Style <- (XamlReader.Load(stream) :?> Style)
override this.Refresh() =
if xaxis <> null && yaxis <> null then
this.Points <-
itemSource |> Seq.of_type<Point>
|> Seq.map
(fun p ->
let x = xaxis.GetPlotAreaCoordinate(p.X).Value.Value
let y = this.ActualHeight - yaxis.GetPlotAreaCoordinate(p.Y).Value.Value
Point(x, y))
|> Seq.sortBy (fun p -> p.X)
|> (fun s -> PointCollection s)
else ()
override this.OnApplyTemplate() =
plotArea <- (this.GetTemplateChild("canvas") :?> Canvas)
this.Refresh()
override this.OnSeriesHostPropertyChanged(o, n) =
let points = itemSource |> Seq.of_type<Point>
if n <> null && Seq.isEmpty points |> not then
let first = Seq.nth 0 points
xaxis <- n.Axes
|> Seq.filter (fun a -> a.CanPlot(first.X) && a.Orientation = AxisOrientation.X)
|> Seq.nth 0
yaxis <- n.Axes
|> Seq.of_type<IRangeAxis>
|> Seq.filter (fun a -> a.CanPlot(first.Y) && a.Orientation = AxisOrientation.Y)
|> Seq.nth 0
xaxis.RegisteredListeners.Add(this)
yaxis.RegisteredListeners.Add(this)
do this.SizeChanged.Add(fun e -> this.Refresh())
member this.Range
with set value =
range <- value
itemSource <- calculateItems()
and get () = range
member this.Function
with set value =
f <- value
itemSource <- calculateItems()
and get () = f
member this.Points
with get () = this.GetValue(FunctionSeries.PointsProperty) :?> PointCollection
and set (value : PointCollection) = this.SetValue(FunctionSeries.PointsProperty, value)
interface IAxisListener with
member this.AxisInvalidated(a) = this.Refresh()
interface IRangeProvider with
member this.GetRange(consumer : IRangeConsumer ) =
if obj.ReferenceEquals(consumer, xaxis) then
let range =
itemSource
|> Seq.cast<Point>
|> Seq.map (fun p -> p.X)
|> Seq.range
match range with
| Some (min, max) -> Range<IComparable>(min, max)
| None -> Range()
else if obj.ReferenceEquals(consumer, yaxis) then
let range =
itemSource
|> Seq.cast<Point>
|> Seq.map (fun p -> p.Y)
|> Seq.range
match range with
| Some (min, max) -> Range<IComparable>(min, max)
| None -> Range()
else Range<IComparable>()
[<STAThread>]
do
let window = Window()
let app = Application()
let chart = Chart()
//parabola:
let functionSeries = FunctionSeries(fun x -> x * x)
//sine wave:
functionSeries.Function <- fun x -> Math.Sin x
functionSeries.Range <- Range(-10.0, 10.0)
//square wave:
functionSeries.Range <- Range(0.0, 50.0)
functionSeries.Function <- fun x -> [3.0..2.0..49.0] |> List.fold (fun a b -> a + Math.Sin(b * x) / b) (Math.Sin x)
window.Width <- 1050.0; window.Height <- 400.0
chart.Axes.Add(LinearAxis(Orientation = AxisOrientation.X))
chart.Axes.Add(LinearAxis(Orientation = AxisOrientation.Y))
chart.Series.Add functionSeries
window.Content <- chart
app.Run(window) |> ignore
you will also require this xaml file:
<Style
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
xmlns:local="clr-namespace:Charts;assembly=achart"
TargetType="local:FunctionSeries">
<Setter Property="Template">
<Setter.Value>
<ControlTemplate TargetType="local:FunctionSeries">
<Canvas x:Name="canvas">
<Polyline Points="{TemplateBinding Points}" Stroke="Red" StrokeThickness="1" StrokeMiterLimit="1" />
</Canvas>
</ControlTemplate>
</Setter.Value>
</Setter>
</Style>
note that you will have to replace "assembly=achart" in the xaml file with the name of your project/assembly.
Delay's Blog
using jafar husain's excellent tutorial on creating a custom chart series:
Writing Your Own Silverlight Chart Series (Part 1): Making Designers Happy
and
Writing Your Own Silverlight Chart Series (Part 2): Implementing the Series
i was able to create a function series in f#:
#light
namespace Charts
open System
open System.Windows
open System.Windows.Media
open System.Windows.Markup
open System.Windows.Shapes
open System.Windows.Controls
open System.Windows.Controls.DataVisualization
open System.Windows.Controls.DataVisualization.Charting
module Seq =
let of_type<'a> (s : System.Collections.IEnumerable) =
seq {
for item in s do
match item with
| :? 'a as item -> yield item
| _ -> ()
}
let range (s : 'a seq) =
if Seq.isEmpty s then None else
s |> Seq.fold
(fun (min, max) a ->
let max = if a > max then a else max
let min = if a < min then a else min
(min, max)
) (Seq.hd s, Seq.hd s) |> Some
let (|Range|_|) (range : 'a Range) =
if range.HasData then Range (range.Minimum, range.Maximum) |> Some else None
type public FunctionSeries(?fx : float -> float) as this =
inherit Series()
[<DefaultValue>]
static val mutable public PointsProperty : DependencyProperty
static do FunctionSeries.PointsProperty <- DependencyProperty.Register("Points", typeof<PointCollection>, typeof<FunctionSeries>)
let mutable itemSource : System.Collections.IEnumerable = null
let mutable plotArea : Canvas = null
let mutable (xaxis : IAxis), (yaxis : IRangeAxis) = null, null
let mutable range = Range(-1.0, 1.0)
let mutable f = fun x -> x
let calculateItems () =
let detail = 600.0
match range with
| Seq.Range (min, max) ->
[0.0..detail]
|> List.map (fun x -> x * ((max - min) / detail) + min)
|> Seq.map (fun x -> Point(x, f x))
| _ -> Seq.empty
do
match fx with | Some fx -> f <- fx | None -> ()
itemSource <- calculateItems()
do
use stream = (Application.GetResourceStream(Uri("FunctionSeries.xaml", UriKind.RelativeOrAbsolute))).Stream
this.Style <- (XamlReader.Load(stream) :?> Style)
override this.Refresh() =
if xaxis <> null && yaxis <> null then
this.Points <-
itemSource |> Seq.of_type<Point>
|> Seq.map
(fun p ->
let x = xaxis.GetPlotAreaCoordinate(p.X).Value.Value
let y = this.ActualHeight - yaxis.GetPlotAreaCoordinate(p.Y).Value.Value
Point(x, y))
|> Seq.sortBy (fun p -> p.X)
|> (fun s -> PointCollection s)
else ()
override this.OnApplyTemplate() =
plotArea <- (this.GetTemplateChild("canvas") :?> Canvas)
this.Refresh()
override this.OnSeriesHostPropertyChanged(o, n) =
let points = itemSource |> Seq.of_type<Point>
if n <> null && Seq.isEmpty points |> not then
let first = Seq.nth 0 points
xaxis <- n.Axes
|> Seq.filter (fun a -> a.CanPlot(first.X) && a.Orientation = AxisOrientation.X)
|> Seq.nth 0
yaxis <- n.Axes
|> Seq.of_type<IRangeAxis>
|> Seq.filter (fun a -> a.CanPlot(first.Y) && a.Orientation = AxisOrientation.Y)
|> Seq.nth 0
xaxis.RegisteredListeners.Add(this)
yaxis.RegisteredListeners.Add(this)
do this.SizeChanged.Add(fun e -> this.Refresh())
member this.Range
with set value =
range <- value
itemSource <- calculateItems()
and get () = range
member this.Function
with set value =
f <- value
itemSource <- calculateItems()
and get () = f
member this.Points
with get () = this.GetValue(FunctionSeries.PointsProperty) :?> PointCollection
and set (value : PointCollection) = this.SetValue(FunctionSeries.PointsProperty, value)
interface IAxisListener with
member this.AxisInvalidated(a) = this.Refresh()
interface IRangeProvider with
member this.GetRange(consumer : IRangeConsumer ) =
if obj.ReferenceEquals(consumer, xaxis) then
let range =
itemSource
|> Seq.cast<Point>
|> Seq.map (fun p -> p.X)
|> Seq.range
match range with
| Some (min, max) -> Range<IComparable>(min, max)
| None -> Range()
else if obj.ReferenceEquals(consumer, yaxis) then
let range =
itemSource
|> Seq.cast<Point>
|> Seq.map (fun p -> p.Y)
|> Seq.range
match range with
| Some (min, max) -> Range<IComparable>(min, max)
| None -> Range()
else Range<IComparable>()
[<STAThread>]
do
let window = Window()
let app = Application()
let chart = Chart()
//parabola:
let functionSeries = FunctionSeries(fun x -> x * x)
//sine wave:
functionSeries.Function <- fun x -> Math.Sin x
functionSeries.Range <- Range(-10.0, 10.0)
//square wave:
functionSeries.Range <- Range(0.0, 50.0)
functionSeries.Function <- fun x -> [3.0..2.0..49.0] |> List.fold (fun a b -> a + Math.Sin(b * x) / b) (Math.Sin x)
window.Width <- 1050.0; window.Height <- 400.0
chart.Axes.Add(LinearAxis(Orientation = AxisOrientation.X))
chart.Axes.Add(LinearAxis(Orientation = AxisOrientation.Y))
chart.Series.Add functionSeries
window.Content <- chart
app.Run(window) |> ignore
you will also require this xaml file:
<Style
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
xmlns:local="clr-namespace:Charts;assembly=achart"
TargetType="local:FunctionSeries">
<Setter Property="Template">
<Setter.Value>
<ControlTemplate TargetType="local:FunctionSeries">
<Canvas x:Name="canvas">
<Polyline Points="{TemplateBinding Points}" Stroke="Red" StrokeThickness="1" StrokeMiterLimit="1" />
</Canvas>
</ControlTemplate>
</Setter.Value>
</Setter>
</Style>
note that you will have to replace "assembly=achart" in the xaml file with the name of your project/assembly.
sub yieldfor(&\&) {
if (open(TO, "-|")) {
while(<TO>) {
&{$_[0]};
}
close(TO);
} else {
&{$_[1]};
}
}
sub yield($) {
print "$_[0]\n";
}
example usage
sub fib() {
my ($a, $b) = (0, 1);
while (1) {
yield $b;
($a, $b) = ($b, $a + $b);
}
}
yieldfor {
print;
} &fib;
my ($a, $b) = (0, 1);
while (1) {
yield $b;
($a, $b) = ($b, $a + $b);
}
}
yieldfor {
print;
} &fib;
18/03: Red-Black tree.
#light
type Colour = | Red | Black
type 'a Tree =
| Node of 'a * 'a Tree * 'a Tree * Colour
| Leaf
let rec balance = function
| Node(y, Node(x, a, b, Red), Node(z, c, d, Red), Black)
| Node(x, a, Node(z, Node(y, b, c, Red), d, Red), Black)
| Node(x, a, Node(y, b, Node(z, c, d, Red), Red), Black)
| Node(z, Node(x, a, Node(y, b, c, Red), Red), d, Black)
| Node(z, Node(y, Node(x, a, b, Red), c, Red), d, Black) -> Node(y, Node(x, a, b, Black), Node(z, c, d, Black), Red)
| a -> a
let makeblack = function
| Node(i, l, r, _) -> Node(i, l, r, Black)
| Leaf -> Leaf
let makered (Node(i, l, r, _)) = Node(i, l, r, Red)
let rec search tree value =
match tree with
| Leaf -> None
| Node(i, l, _, _) when value < i -> search l value
| Node(i, _, r, _) when value > i -> search r value
| _ -> Some value
let add tree value =
let rec insert = function
| Leaf -> Node(value, Leaf, Leaf, Red)
| Node(i, l, r, c) when value < i -> Node(i, insert l, r, c) |> balance
| Node(i, l, r, c) when value > i -> Node(i, l, insert r, c) |> balance
| a -> a
insert tree |> makeblack
let remove tree value =
let number = ref None
let rec rem = function
//red -> (black), black
| Node(i, Node(j, jl, jr, Black), Node(k, kl, kr, Black), Red) when value < i ->
Node(i, Node(j, jl, jr, Red) |> rem, Node(k, kl, kr, Red), Black) |> balance
| Node(i, Node(j, jl, jr, Black), Node(k, kl, kr, Black), Red) when value > i ->
Node(i, Node(j, jl, jr, Red), Node(k, kl, kr, Red) |> rem, Black) |> balance
//red -> black/red/leaf, (red):
| Node(p, l, Node(c, cl, cr, Red), Red) when value > p -> Node(p, l, Node(c, cl, cr, Red) |> rem, Red)
| Node(p, Node(c, cl, cr, Red), r, Red) when value < p -> Node(p, Node(c, cl, cr, Red) |> rem, r, Red)
//red -> (black), red
| Node(n3, Node(n1, Node(n0, l0, r0, Black), Node(n2, l2, r2, Black), Red), n4, Red) when value > n3 ->
Node(n1, Node(n0, l0, r0, Black), Node(n3, Node(n2, l2, r2, Black), n4, Red) |> rem, Red)
| Node(n1, n0, Node(n3, Node(n2, l2, r2, Black), Node(n4, l4, r4, Black), Red), Red) when value < n1 ->
Node(n3, Node(n1, n0, Node(n2, l2, r2, Black), Red) |> rem, Node(n4, l4, r4, Black), Red)
//(red) -> leaf
| Node(i, Leaf, Leaf, Red) when value = i -> Leaf
| Node(i, l, Leaf, Red) when value = i -> l
//non-leaf match:
| Node(i, l, r, Red) as a when value = i ->
//find successor:
match a with
| Node(i, Node(j, jl, jr, Black), Node(k, kl, kr, Black), Red) ->
Node(i, Node(j, jl, jr, Red), Node(k, kl, kr, Red) |> remsuccessor, Black) |> balance
| Node(p, l, Node(c, cl, cr, Red), Red) -> Node(p, l, Node(c, cl, cr, Red) |> remsuccessor, Red)
| Node(n3, Node(n1, Node(n0, l0, r0, Black), Node(n2, l2, r2, Black), Red), n4, Red) ->
Node(n1, Node(n0, l0, r0, Black), Node(n3, Node(n2, l2, r2, Black), n4, Red) |> rem, Red)
and remsuccessor = function
| Node(i, Node(j, jl, jr, Black), Node(k, kl, kr, Black), Red) ->
Node(i, Node(j, jl, jr, Red) |> remsuccessor, Node(k, kl, kr, Red), Black) |> balance
| Node(p, Node(c, cl, cr, Red), r, Red) -> Node(p, Node(c, cl, cr, Red) |> remsuccessor, r, Red)
| Node(n1, n0, Node(n3, Node(n2, l2, r2, Black), Node(n4, l4, r4, Black), Red), Red) ->
Node(n3, Node(n1, n0, Node(n2, l2, r2, Black), Red) |> remsuccessor, Node(n4, l4, r4, Black), Red)
| Node(i, Leaf, Leaf, Red) -> number := Some i; Leaf
| Node(i, Leaf, r, Red) -> number := Some i; r
and check tree =
match !number with
| Some x -> switch x tree
| None -> tree
and switch x = function
| Node(i, l, r, c) when value < i -> Node(i, switch x l, r, c)
| Node(i, l, r, c) when value > i -> Node(i, l, switch x r, c)
| Node(i, l, r, c) when value = i -> Node(x, l, r, c)
tree |> makered |> rem |> makeblack |> check
let rec traverse tree = seq {
match tree with
| Leaf -> ()
| Node(i, l, r, _) ->
yield! traverse l
yield i
yield! traverse r
}
let sort x = x |> Seq.fold add Leaf |> traverse
previous: binary search tree
18/03: Binary search tree
#light
type Tree<'a> =
| Node of 'a * Tree<'a> * Tree<'a>
| Leaf
let rec add tree value =
match tree with
| Leaf -> Node(value, Leaf, Leaf)
| Node(i, l, r) when value < i -> Node(i, add l value, r)
| Node(i, l, r) when value > i -> Node(i, l, add r value)
| _ -> tree
let rec remove tree value =
let rec successor tree =
match tree with
| Node(i, Leaf, _) -> i
| Node(_, l, _) -> successor l
match tree with
| Node(i, l, r) when value < i -> Node(i, remove l value, r)
| Node(i, l, r) when value > i -> Node(i, l, remove r value)
| Node(i, Leaf, Leaf) when i = value -> Leaf
| Node(i, l, Leaf) when i = value -> l
| Node(i, Leaf, r) when i = value -> r
| Node(i, l, r) when i = value ->
//find in-order successor (left-most child of right subtree):
let j = successor r
Node(j, l, remove r j)
let rec search tree value =
match tree with
| Leaf -> None
| Node(i, l, _) when value < i -> search l value
| Node(i, _, r) when value > i-> search r value
| _ -> Some value
let rec traverse tree = seq {
match tree with
| Leaf -> ()
| Node(i, l, r) ->
yield! traverse l
yield i
yield! traverse r
}
let sort x = x |> Seq.fold add Leaf |> traverse
next: red-black tree
#light
let regex s = new System.Text.RegularExpressions.Regex(s,System.Text.RegularExpressions.RegexOptions.Compiled)
let stringorregex (reg : obj) =
match reg with
| :? System.Text.RegularExpressions.Regex -> reg :?> System.Text.RegularExpressions.Regex
| :? string -> System.Text.RegularExpressions.Regex (reg :?> string)
| _ -> failwith "regular expression must be of type <regex> or <string>."
let (=~) reg str = (stringorregex reg).IsMatch(str)
let (^~) reg str = not ((stringorregex reg).IsMatch(str))
let (=~~) (reg : obj) str =
let m = (stringorregex reg).Match(str)
[0..m.Groups.Count - 1] |> List.map (fun x -> (m.Groups.Item(x)).Value)
let (=~~~) (reg : obj) str =
let groups (m : System.Text.RegularExpressions.Match) = [0..m.Groups.Count - 1] |> List.map (fun x -> (m.Groups.Item(x)).Value)
let m = ref ((stringorregex reg).Match(str))
seq {
while (!m).Success do
yield groups (!m)
m := (!m).NextMatch()
}
Example usage
regex "d[a-z]g" =~ "the dog is brown" |> printf "%b\n"
prints: true
"d[a-z]g" ^~ "the dog is brown" |> printf "%b\n"
prints: false
let [_; the; pen; works; correctly] = "(\w+) (\w+) (\w+) (\w+)" =~~ "the pen works correctly"
printf "%s,%s,%s,%s\n" the pen works correctly
prints: the,pen,works,corectly
for i in "(\w+) (\w+)" =~~~ "james 12 charles 78 helmut 43" do
printf "[%s,%s] " i.[1] i.[2]
prints: [james,12] [charles,78] [helmut,43]
".o" =~~~ "do you remember willo the wisp?"
|> Seq.map (fun (x :: []) -> x)
|> Seq.iter (printf "[%s] ")
prints: [do] [yo] [lo]
let split = (regex " ").Split("i fancy he is a bedlamite")
for word in split do printf "%s, " word
prints: i, fancy, he, is, a, bedlamite,
prints: 10,11,12,13,14,15,16,17,18,19,100,
24/02: SdlSimple highlights
previous: sdlSimple
ummmm...i thought i would highlight some things i learned while writing this library:
Importing functions from external c++ libraries
a couple of examples:
[<DllImport("libpcxf", EntryPoint="colour")>]
extern int colourC(byte r, byte g, byte b)
//useage:
let yellow = colourC(255uy, 255uy, 0uy)
[<DllImport("libpcxf")>]
extern unit setScreen(IntPtr pixels, int width, int height, int depth)
//usage:
let (screen : IntPtr) = Sdl.SDL_SetVideoMode(640, 480, 32, Sdl.SDL_DOUBLEBUF ||| Sdl.SDL_HWPALETTE)
let (surface : Sdl.SDL_Surface) = (Marshal.PtrToStructure(screen, typeof<Sdl.SDL_Surface>)) :?> Sdl.SDL_Surface
let buffer = surface.pixels
setScreen(buffer, sdlWidth, sdlHeight, sdlDepth)
extern int colourC(byte r, byte g, byte b)
//useage:
let yellow = colourC(255uy, 255uy, 0uy)
[<DllImport("libpcxf")>]
extern unit setScreen(IntPtr pixels, int width, int height, int depth)
//usage:
let (screen : IntPtr) = Sdl.SDL_SetVideoMode(640, 480, 32, Sdl.SDL_DOUBLEBUF ||| Sdl.SDL_HWPALETTE)
let (surface : Sdl.SDL_Surface) = (Marshal.PtrToStructure(screen, typeof<Sdl.SDL_Surface>)) :?> Sdl.SDL_Surface
let buffer = surface.pixels
setScreen(buffer, sdlWidth, sdlHeight, sdlDepth)
Marshaling an array of structs from c++ to f#
'getPalette' is a c++ function that takes a file location as argument and returns an array of SDL_Color structs (which are 32-bit int's basically).
to access the returned array in f# it would seem you have to increment the returned pointer and reconstruct the array.
[<DllImport("libpcxf")>]
extern IntPtr getPalette(string pal)
let mutable (palette : IntPtr) = (getPalette(file))
let colours = [|0..255|] |> Array.map (fun i -> Sdl.SDL_Color())
for i in [0..255] do
colours.[i] <- (Marshal.PtrToStructure(palette, typeof<Sdl.SDL_Color>) :?> Sdl.SDL_Color)
palette <- IntPtr(palette.ToInt32() + sizeof<Sdl.SDL_Color>)
F# keywords are not allowed as method names
because 'type' is a f# reserved keyword i was unable to extract the event type from an sdl event structure with 'event.type'
i was able to overcome this by writing a short c# library that did this for me.
so:
(!event).type
became:
GetEventType.Get(!event)
using this c# dll:
using Tao.Sdl;
public class GetEventType {
public static int Get(Sdl.SDL_Event e) {
return e.type;
}
}
i encountered a similar problem with the 'val' keyword which was solved using this dll:
using Tao.Sdl;
public class GetJaxisValue {
public static short Get(Sdl.SDL_Event e) {
return e.jaxis.val;
}
}
Overloaded functions
overloaded functions are not presently availible in f# but you can match on types which achieves a similar result:
let write c (data : obj) (x, y) =
match data with
| :? string -> writeString(x, y, (data :?> string), c)
| :? int -> writeInt(x, y, (data :?> int), c)
| :? double -> writeDouble(x, y, (data :?> double), c)
| _ -> failwith "data type not supported."
Events
for those unfamiliar with SDL (www.libsdl.org) it requires you to create an infinite loop that listens for sdl events and reacts to them. this can be seen in the previous entry under 'sdl event loop'.
in this loop i convert the wanted native SDL events into f# events of the type union 'sdlevent':
type sdlevent =
| KeyUp of int
| KeyDown of int
| MouseMove of int * int
...etc...
and fire them into the 'events' IEvent.
you can then listen for these events using the regular f# Event methods:
events |> Event.listen (fun e ->
match e with
| KeyDown x -> printf "%s pressed.\n" (scancodeToKey x)
| KeyUp x -> printf "%s released.\n" (scancodeToKey x)
| _ -> ()
)
Drawing
SdlSimple keeps a list of functions in 'drawevents' and executes each one on every iteration of the sdl event loop like so:
for (s, e) in drawevents do e()
you draw to the screen by adding a function that utilizes one or more drawing methods (pixel, line, write, rectangle, colour) to the 'drawevents' list using the 'drawfire' event firing function.
this will add the 'hello' function to the 'drawevents' list thus writing "hello" to the screen:
drawfire (Draw ("hello", (fun () ->
write (colour 255 255 255) "hello" (100, 100)
)))
and this will remove it from the same list; erasing it from the screen:
drawfire (Erease "hello")
Event and drawing DSL's
this is most likely an abuse of the f# monad syntax but i believe it allows for a concise way of drawing and responding to simple events:
//draw monad:
type DrawMonad(name) =
member this.Delay(f) = drawfire (Draw (name, f))
member this.Zero() = ()
let draw = DrawMonad("draw")
let drawn name = DrawMonad(name)
//event monad:
type EventMonad(evnt) =
member this.Delay(f) =
events |> Event.listen (fun e ->
match e with
| x when x = evnt -> f()
| _ -> ()
)
member this.Zero() = ()
let onevent e = EventMonad(e)
//clear the screen:
let cls (str : obj) =
match str with
| :? string -> drawfire (Erase (str :?> string))
| _ -> drawfire (Erase "draw")
the above classes allow you to write code like this:
//draw a green triangle:
drawn "triangle" {
let green = colour 0 255 0
[(150, 100); (200, 200); (100, 200); (150, 100)] |> Seq.reduce (line green) |> ignore
}
//erease the triangle when 'enter' is pressed:
onevent (KeyDown 13) {
cls "triangle"
}
Checking for a file in multiple locations
List.find returns the fist element for which the given function returns true and throws a 'KeyNotFoundException' if no such element exists.
try ["/usr/local/share/libpcxf/palette.gpl"; "/usr/share/libpcxf/palette.gpl"; "palette.gpl"]
|> List.find System.IO.File.Exists |> setPalette |> ignore with | _ -> ()
20/02: SdlSimple
previous: Compiling Game of Life
next: SdlSimple highlights
#light
#nowarn "9"
open System
open System.Runtime.InteropServices
open Microsoft.FSharp.NativeInterop
open Tao.Sdl
let println x = print_any x; printf "\n"
//external c libraries:
[<DllImport("libpcxf", EntryPoint="pixel")>]
extern unit internal pixelC(int x, int y, int colour)
[<DllImport("libpcxf", EntryPoint="colour")>]
extern int internal colourC(byte r, byte g, byte b)
[<DllImport("libpcxf")>]
extern unit internal setScreen(void *pixels, int width, int height, int depth)
[<DllImport("libpcxf")>]
extern unit internal loadFonts()
[<DllImport("libpcxf")>]
extern unit internal unloadFonts()
[<DllImport("libpcxf")>]
extern unit internal writeInt(int x, int y, int num, int colour)
[<DllImport("libpcxf")>]
extern unit internal writeString(int x, int y, string text, int colour)
[<DllImport("libpcxf")>]
extern unit internal writeDouble(int x, int y, double num, int colour)
[<DllImport("libpcxf", EntryPoint="line")>]
extern unit internal lineC(int x1, int y1, int x2, int y2, int colour)
[<DllImport("libpcxf", EntryPoint="rectangle")>]
extern unit internal rectangleC(int x1, int y1, int x2, int y2, int colour)
[<DllImport("libpcxf")>]
extern IntPtr internal getPalette(string pal)
//event union: (sdlFire fires these events)
type sdlevent =
| KeyUp of int
| KeyDown of int
| MouseMove of int * int
| MouseUp of int
| MouseDown of int
| JoyAxis1 of int * int
| JoyAxis2 of int * int
| JoyButtonDown1 of int
| JoyButtonDown2 of int
| JoyButtonUp1 of int
| JoyButtonUp2 of int
//draw union:
type sdldraw =
| Draw of string * (unit -> unit)
| UnDraw of string
| Erase of string
let mutable drawevents = []
//globals:
let mutable internal sdlHeight = 0
let mutable internal sdlWidth = 0
let mutable internal sdlDepth = 0
let mutable internal sdlFullScreen = false
let mutable internal sdlFire = (fun x -> ()) //fire events.
let mutable drawfire = (fun x -> ()) //fire draw event.
let mutable sdlScreen = IntPtr()
let mutable sdlBuffer = IntPtr()
let mutable (_, events) = Event.create<sdlevent>() //catch events.
//f# wrapers for pcxf functions:
let inline colour (r : int) (g : int) (b : int) = colourC((byte) r, (byte) g, (byte) b)
let inline pixel c (x, y) = pixelC(x, y, c)
let inline line c (x1, y1) (x2, y2) = lineC(x1, y1, x2, y2, c); (x2, y2)
let inline rectangle c (x1, y1) (x2, y2) = rectangleC(x1, y1, x2, y2, c)
let write c (data : obj) (x, y) =
match data with
| :? string -> writeString(x, y, (data :?> string), c)
| :? int -> writeInt(x, y, (data :?> int), c)
| :? double -> writeDouble(x, y, (data :?> double), c)
| _ -> failwith "data type not supported."
let writey data (x, y) = write (colour 255 255 255) data (x, y)
//set the palette for 8-bit colour mode:
let setPalette file =
let mutable (palette : IntPtr) = (getPalette(file))
let colours = [|0..255|] |> Array.map (fun i -> Sdl.SDL_Color())
for i in [0..255] do
colours.[i] <- (Marshal.PtrToStructure(palette, typeof<Sdl.SDL_Color>) :?> Sdl.SDL_Color)
palette <- IntPtr(palette.ToInt32() + sizeof<Sdl.SDL_Color>)
Sdl.SDL_SetPalette(sdlScreen, (int) (Sdl.SDL_LOGPAL ||| Sdl.SDL_PHYSPAL), colours, 0, 256)
//function to show the frames per second in top left corner:
let internal timer = new System.Diagnostics.Stopwatch()
let mutable internal milliseconds = (int64 0)
let mutable internal frames = 0
let mutable internal fps = 0
let internal showfps () =
frames <- frames + 1
if timer.ElapsedMilliseconds > milliseconds then
fps <- frames
milliseconds <- timer.ElapsedMilliseconds + (int64 1000)
frames <- 0
()
writey fps (10, 0)
writey "fps" (40, 0)
//convert keyboard scancodes to helpfull key string:
let scancodeToKey sc =
Sdl.SDL_GetKeyName(sc)
//draw monad:
type DrawMonad(name) =
member this.Delay(f) = drawfire (Draw (name, f))
member this.Zero() = ()
let draw = DrawMonad("draw")
let drawn name = DrawMonad(name)
//event monad:
type EventMonad(evnt) =
member this.Delay(f) =
events |> Event.listen (fun e ->
match e with
| x when x = evnt -> f()
| _ -> ()
)
member this.Zero() = ()
let onevent e = EventMonad(e)
//clear the screen:
let cls (str : obj) =
match str with
| :? string -> drawfire (UnDraw (str :?> string))
| _ -> drawfire (UnDraw "draw")
//start the sdl program loop in a seperate thread:
let internal sdlloop = async {
let _ = Sdl.SDL_Init(Sdl.SDL_INIT_VIDEO ||| Sdl.SDL_INIT_JOYSTICK)
let (screen : IntPtr) =
if sdlFullScreen = true then
Sdl.SDL_SetVideoMode(sdlWidth, sdlHeight, sdlDepth, Sdl.SDL_DOUBLEBUF ||| Sdl.SDL_HWPALETTE ||| Sdl.SDL_FULLSCREEN)
else
Sdl.SDL_SetVideoMode(sdlWidth, sdlHeight, sdlDepth, Sdl.SDL_DOUBLEBUF ||| Sdl.SDL_HWPALETTE)
//get ponter to video memory from sdl and pass it to pcxf library:
let (surface : Sdl.SDL_Surface) = (Marshal.PtrToStructure(screen, typeof<Sdl.SDL_Surface>)) :?> Sdl.SDL_Surface
let buffer = surface.pixels
sdlBuffer <- buffer
sdlScreen <- screen
setScreen(buffer, sdlWidth, sdlHeight, sdlDepth)
loadFonts()
//open and set palette if 8-bit colour is being used:
if sdlDepth = 8 then
try ["/usr/local/share/libpcxf/palette.gpl"; "/usr/share/libpcxf/palette.gpl"; "palette.gpl"]
|> List.find System.IO.File.Exists |> setPalette |> ignore with | _ -> ()
//open any joysticks that are plugged in:
let _ = Sdl.SDL_JoystickEventState(Sdl.SDL_ENABLE)
for i in [0..Sdl.SDL_NumJoysticks() - 1] do
let _ = Sdl.SDL_JoystickOpen(i)
()
//create arrays of black for clearing the screen:
let empty8 = Array.create (sdlWidth * sdlHeight) 0uy
let empty16 = Array.create (sdlWidth * sdlHeight) 0s
let empty32 = Array.create (sdlWidth * sdlHeight) 0
//sdl event loop:
let event = ref (Sdl.SDL_Event())
let running = ref 1
timer.Start()
while !running = 1 do
while Sdl.SDL_PollEvent(event) = 1 do
match GetEventType.Get(!event) with
| Sdl.SDL_KEYDOWN -> sdlFire (KeyDown (!event).key.keysym.sym)
| Sdl.SDL_KEYUP ->
if (!event).key.keysym.sym = 27 then running := 0
sdlFire (KeyUp (!event).key.keysym.sym)
| Sdl.SDL_MOUSEMOTION -> sdlFire (MouseMove (int ((!event).motion.x),int ((!event).motion.y)))
| Sdl.SDL_MOUSEBUTTONDOWN -> sdlFire (MouseDown (int (!event).button.button))
| Sdl.SDL_MOUSEBUTTONUP -> sdlFire (MouseUp (int (!event).button.button))
| Sdl.SDL_JOYAXISMOTION ->
match (!event).jaxis.which with
| 0uy -> sdlFire (JoyAxis1 ((int ((!event).jaxis.axis)), (int (GetJaxisValue.Get(!event)))))
| 1uy -> sdlFire (JoyAxis2 ((int ((!event).jaxis.axis)), (int (GetJaxisValue.Get(!event)))))
| _ -> failwith "SdlSimple only supports 2 joysticks at present. (this is easy to fix)"
| Sdl.SDL_JOYBUTTONDOWN ->
match (!event).jbutton.which with
| 0uy -> sdlFire (JoyButtonDown1 (int (!event).jbutton.button))
| 1uy -> sdlFire (JoyButtonDown2 (int (!event).jbutton.button))
| _ -> failwith "SdlSimple only supports 2 joysticks at present. (this is easy to fix)"
| Sdl.SDL_JOYBUTTONUP ->
match (!event).jbutton.which with
| 0uy -> sdlFire (JoyButtonUp1 (int (!event).jbutton.button))
| 1uy -> sdlFire (JoyButtonUp2 (int (!event).jbutton.button))
| _ -> failwith "SdlSimple only supports 2 joysticks at present. (this is easy to fix)"
| _ -> ()
if Sdl.SDL_MUSTLOCK(sdlScreen) = 1 then do Sdl.SDL_LockSurface(sdlScreen) |> ignore
//clear the screen:
match sdlDepth with
| 8 -> Marshal.Copy(empty8, 0, buffer, (sdlWidth * sdlHeight))
| 16 -> Marshal.Copy(empty16, 0, buffer, (sdlWidth * sdlHeight))
| 24 -> Marshal.Copy(empty16, 0, buffer, (sdlWidth * sdlHeight))
| 32 -> Marshal.Copy(empty32, 0, buffer, (sdlWidth * sdlHeight))
| _ -> failwith "not a valid bit depth."
for (s, e) in drawevents do e() //perform all draw events.
if Sdl.SDL_MUSTLOCK(sdlScreen) = 1 then do Sdl.SDL_UnlockSurface(sdlScreen) |> ignore
Sdl.SDL_Flip(sdlScreen) |> ignore
//clean up:
println "done."
timer.Stop()
unloadFonts()
Sdl.SDL_Quit()
}
//setup sdl and various things:
let SdlSimpleSetup width height depth fs =
sdlHeight <- height
sdlWidth <- width
sdlDepth <- try [8;16;24;32] |> List.find ((=) depth) with | _ -> 32
sdlFullScreen <- fs
//create events for sdl events and draw events:
let fire, evs = Event.create<sdlevent>()
sdlFire <- fire
events <- evs
let dfire, draw = Event.create<sdldraw>()
drawfire <- dfire
//listen for draw events and add/delete them from the drawevents list:
draw |> Event.listen (fun e ->
match e with
| Draw (s, e) -> drawevents <- drawevents @ [(s, e)]
| UnDraw x | Erase x -> drawevents <- drawevents |> List.filter (fun (s, e) -> s <> x)
)
drawfire (Draw ("fps", showfps)) //add showfps function to drawevents list.
Async.Spawn sdlloop //spawn the sdl program loop in a seperate thread.
System.Threading.Thread.Sleep 500
next: SdlSimple highlights
#light
#nowarn "9"
open System
open System.Runtime.InteropServices
open Microsoft.FSharp.NativeInterop
open Tao.Sdl
let println x = print_any x; printf "\n"
//external c libraries:
[<DllImport("libpcxf", EntryPoint="pixel")>]
extern unit internal pixelC(int x, int y, int colour)
[<DllImport("libpcxf", EntryPoint="colour")>]
extern int internal colourC(byte r, byte g, byte b)
[<DllImport("libpcxf")>]
extern unit internal setScreen(void *pixels, int width, int height, int depth)
[<DllImport("libpcxf")>]
extern unit internal loadFonts()
[<DllImport("libpcxf")>]
extern unit internal unloadFonts()
[<DllImport("libpcxf")>]
extern unit internal writeInt(int x, int y, int num, int colour)
[<DllImport("libpcxf")>]
extern unit internal writeString(int x, int y, string text, int colour)
[<DllImport("libpcxf")>]
extern unit internal writeDouble(int x, int y, double num, int colour)
[<DllImport("libpcxf", EntryPoint="line")>]
extern unit internal lineC(int x1, int y1, int x2, int y2, int colour)
[<DllImport("libpcxf", EntryPoint="rectangle")>]
extern unit internal rectangleC(int x1, int y1, int x2, int y2, int colour)
[<DllImport("libpcxf")>]
extern IntPtr internal getPalette(string pal)
//event union: (sdlFire fires these events)
type sdlevent =
| KeyUp of int
| KeyDown of int
| MouseMove of int * int
| MouseUp of int
| MouseDown of int
| JoyAxis1 of int * int
| JoyAxis2 of int * int
| JoyButtonDown1 of int
| JoyButtonDown2 of int
| JoyButtonUp1 of int
| JoyButtonUp2 of int
//draw union:
type sdldraw =
| Draw of string * (unit -> unit)
| UnDraw of string
| Erase of string
let mutable drawevents = []
//globals:
let mutable internal sdlHeight = 0
let mutable internal sdlWidth = 0
let mutable internal sdlDepth = 0
let mutable internal sdlFullScreen = false
let mutable internal sdlFire = (fun x -> ()) //fire events.
let mutable drawfire = (fun x -> ()) //fire draw event.
let mutable sdlScreen = IntPtr()
let mutable sdlBuffer = IntPtr()
let mutable (_, events) = Event.create<sdlevent>() //catch events.
//f# wrapers for pcxf functions:
let inline colour (r : int) (g : int) (b : int) = colourC((byte) r, (byte) g, (byte) b)
let inline pixel c (x, y) = pixelC(x, y, c)
let inline line c (x1, y1) (x2, y2) = lineC(x1, y1, x2, y2, c); (x2, y2)
let inline rectangle c (x1, y1) (x2, y2) = rectangleC(x1, y1, x2, y2, c)
let write c (data : obj) (x, y) =
match data with
| :? string -> writeString(x, y, (data :?> string), c)
| :? int -> writeInt(x, y, (data :?> int), c)
| :? double -> writeDouble(x, y, (data :?> double), c)
| _ -> failwith "data type not supported."
let writey data (x, y) = write (colour 255 255 255) data (x, y)
//set the palette for 8-bit colour mode:
let setPalette file =
let mutable (palette : IntPtr) = (getPalette(file))
let colours = [|0..255|] |> Array.map (fun i -> Sdl.SDL_Color())
for i in [0..255] do
colours.[i] <- (Marshal.PtrToStructure(palette, typeof<Sdl.SDL_Color>) :?> Sdl.SDL_Color)
palette <- IntPtr(palette.ToInt32() + sizeof<Sdl.SDL_Color>)
Sdl.SDL_SetPalette(sdlScreen, (int) (Sdl.SDL_LOGPAL ||| Sdl.SDL_PHYSPAL), colours, 0, 256)
//function to show the frames per second in top left corner:
let internal timer = new System.Diagnostics.Stopwatch()
let mutable internal milliseconds = (int64 0)
let mutable internal frames = 0
let mutable internal fps = 0
let internal showfps () =
frames <- frames + 1
if timer.ElapsedMilliseconds > milliseconds then
fps <- frames
milliseconds <- timer.ElapsedMilliseconds + (int64 1000)
frames <- 0
()
writey fps (10, 0)
writey "fps" (40, 0)
//convert keyboard scancodes to helpfull key string:
let scancodeToKey sc =
Sdl.SDL_GetKeyName(sc)
//draw monad:
type DrawMonad(name) =
member this.Delay(f) = drawfire (Draw (name, f))
member this.Zero() = ()
let draw = DrawMonad("draw")
let drawn name = DrawMonad(name)
//event monad:
type EventMonad(evnt) =
member this.Delay(f) =
events |> Event.listen (fun e ->
match e with
| x when x = evnt -> f()
| _ -> ()
)
member this.Zero() = ()
let onevent e = EventMonad(e)
//clear the screen:
let cls (str : obj) =
match str with
| :? string -> drawfire (UnDraw (str :?> string))
| _ -> drawfire (UnDraw "draw")
//start the sdl program loop in a seperate thread:
let internal sdlloop = async {
let _ = Sdl.SDL_Init(Sdl.SDL_INIT_VIDEO ||| Sdl.SDL_INIT_JOYSTICK)
let (screen : IntPtr) =
if sdlFullScreen = true then
Sdl.SDL_SetVideoMode(sdlWidth, sdlHeight, sdlDepth, Sdl.SDL_DOUBLEBUF ||| Sdl.SDL_HWPALETTE ||| Sdl.SDL_FULLSCREEN)
else
Sdl.SDL_SetVideoMode(sdlWidth, sdlHeight, sdlDepth, Sdl.SDL_DOUBLEBUF ||| Sdl.SDL_HWPALETTE)
//get ponter to video memory from sdl and pass it to pcxf library:
let (surface : Sdl.SDL_Surface) = (Marshal.PtrToStructure(screen, typeof<Sdl.SDL_Surface>)) :?> Sdl.SDL_Surface
let buffer = surface.pixels
sdlBuffer <- buffer
sdlScreen <- screen
setScreen(buffer, sdlWidth, sdlHeight, sdlDepth)
loadFonts()
//open and set palette if 8-bit colour is being used:
if sdlDepth = 8 then
try ["/usr/local/share/libpcxf/palette.gpl"; "/usr/share/libpcxf/palette.gpl"; "palette.gpl"]
|> List.find System.IO.File.Exists |> setPalette |> ignore with | _ -> ()
//open any joysticks that are plugged in:
let _ = Sdl.SDL_JoystickEventState(Sdl.SDL_ENABLE)
for i in [0..Sdl.SDL_NumJoysticks() - 1] do
let _ = Sdl.SDL_JoystickOpen(i)
()
//create arrays of black for clearing the screen:
let empty8 = Array.create (sdlWidth * sdlHeight) 0uy
let empty16 = Array.create (sdlWidth * sdlHeight) 0s
let empty32 = Array.create (sdlWidth * sdlHeight) 0
//sdl event loop:
let event = ref (Sdl.SDL_Event())
let running = ref 1
timer.Start()
while !running = 1 do
while Sdl.SDL_PollEvent(event) = 1 do
match GetEventType.Get(!event) with
| Sdl.SDL_KEYDOWN -> sdlFire (KeyDown (!event).key.keysym.sym)
| Sdl.SDL_KEYUP ->
if (!event).key.keysym.sym = 27 then running := 0
sdlFire (KeyUp (!event).key.keysym.sym)
| Sdl.SDL_MOUSEMOTION -> sdlFire (MouseMove (int ((!event).motion.x),int ((!event).motion.y)))
| Sdl.SDL_MOUSEBUTTONDOWN -> sdlFire (MouseDown (int (!event).button.button))
| Sdl.SDL_MOUSEBUTTONUP -> sdlFire (MouseUp (int (!event).button.button))
| Sdl.SDL_JOYAXISMOTION ->
match (!event).jaxis.which with
| 0uy -> sdlFire (JoyAxis1 ((int ((!event).jaxis.axis)), (int (GetJaxisValue.Get(!event)))))
| 1uy -> sdlFire (JoyAxis2 ((int ((!event).jaxis.axis)), (int (GetJaxisValue.Get(!event)))))
| _ -> failwith "SdlSimple only supports 2 joysticks at present. (this is easy to fix)"
| Sdl.SDL_JOYBUTTONDOWN ->
match (!event).jbutton.which with
| 0uy -> sdlFire (JoyButtonDown1 (int (!event).jbutton.button))
| 1uy -> sdlFire (JoyButtonDown2 (int (!event).jbutton.button))
| _ -> failwith "SdlSimple only supports 2 joysticks at present. (this is easy to fix)"
| Sdl.SDL_JOYBUTTONUP ->
match (!event).jbutton.which with
| 0uy -> sdlFire (JoyButtonUp1 (int (!event).jbutton.button))
| 1uy -> sdlFire (JoyButtonUp2 (int (!event).jbutton.button))
| _ -> failwith "SdlSimple only supports 2 joysticks at present. (this is easy to fix)"
| _ -> ()
if Sdl.SDL_MUSTLOCK(sdlScreen) = 1 then do Sdl.SDL_LockSurface(sdlScreen) |> ignore
//clear the screen:
match sdlDepth with
| 8 -> Marshal.Copy(empty8, 0, buffer, (sdlWidth * sdlHeight))
| 16 -> Marshal.Copy(empty16, 0, buffer, (sdlWidth * sdlHeight))
| 24 -> Marshal.Copy(empty16, 0, buffer, (sdlWidth * sdlHeight))
| 32 -> Marshal.Copy(empty32, 0, buffer, (sdlWidth * sdlHeight))
| _ -> failwith "not a valid bit depth."
for (s, e) in drawevents do e() //perform all draw events.
if Sdl.SDL_MUSTLOCK(sdlScreen) = 1 then do Sdl.SDL_UnlockSurface(sdlScreen) |> ignore
Sdl.SDL_Flip(sdlScreen) |> ignore
//clean up:
println "done."
timer.Stop()
unloadFonts()
Sdl.SDL_Quit()
}
//setup sdl and various things:
let SdlSimpleSetup width height depth fs =
sdlHeight <- height
sdlWidth <- width
sdlDepth <- try [8;16;24;32] |> List.find ((=) depth) with | _ -> 32
sdlFullScreen <- fs
//create events for sdl events and draw events:
let fire, evs = Event.create<sdlevent>()
sdlFire <- fire
events <- evs
let dfire, draw = Event.create<sdldraw>()
drawfire <- dfire
//listen for draw events and add/delete them from the drawevents list:
draw |> Event.listen (fun e ->
match e with
| Draw (s, e) -> drawevents <- drawevents @ [(s, e)]
| UnDraw x | Erase x -> drawevents <- drawevents |> List.filter (fun (s, e) -> s <> x)
)
drawfire (Draw ("fps", showfps)) //add showfps function to drawevents list.
Async.Spawn sdlloop //spawn the sdl program loop in a seperate thread.
System.Threading.Thread.Sleep 500
19/02: Compiling Game of Life.
were you wondering why the code in the previous post will not compile? curious in what obscure dll file SdlSimple is located?
well it cannot be found because i made it the fuck up.
SdlSimple is a f# graphics library that uses SDL (www.libsdl.org) to create a window and draw to the screen. it is a project i underwent to learn f# and test the ease of which it interoperates with native c++ code. to achieve this end: SdlSimple uses functions stored in an ancient, unfinished c library called pcxf that i wrote many years ago for dos. if this sounds silly; thats because it probably is.
to compile the game of life example you will need these files:
linux
windows
source code will be in the next post but if you would like to compile it yourself you can get the complete source here
source to the pcxf library is here
previous: Game of Life
next: SdlSimple
well it cannot be found because i made it the fuck up.
SdlSimple is a f# graphics library that uses SDL (www.libsdl.org) to create a window and draw to the screen. it is a project i underwent to learn f# and test the ease of which it interoperates with native c++ code. to achieve this end: SdlSimple uses functions stored in an ancient, unfinished c library called pcxf that i wrote many years ago for dos. if this sounds silly; thats because it probably is.
to compile the game of life example you will need these files:
linux
windows
source code will be in the next post but if you would like to compile it yourself you can get the complete source here
source to the pcxf library is here
previous: Game of Life
next: SdlSimple
14/02: Game of Life.
#light
open System
open Array
let width, height = 100, 100
let tick game =
let number index =
let X, Y = index % width, index / width
[|(-1, -1); (0, -1); (1, -1); (1, 0); (1, 1); (0, 1); (-1, 1); (-1, 0)|]
|> map (fun (x, y) -> X + x, Y + y)
|> filter (fun (x, y) -> x > 0 && x < width && y > 0 && y < height)
|> map (fun (x, y) -> y * width + x)
|> map (fun i -> if game.[i] then 1 else 0)
|> sum
game |> mapi (fun i alive ->
match (alive, number i) with
| (true, n) when n < 2 -> false
| (true, n) when n > 3 -> false
| (true, _) -> true
| (false, 3) -> true
| (false, _) -> false
| _ -> failwith "no."
)
let random = Random()
let mutable life = [|0..width * height - 1|] |> map (fun _ -> random.Next() % 2 = 0)
open SdlSimple
SdlSimpleSetup (width * 2) (height * 2 + 10) 16 false
draw {
let yellow = colour 255 255 0
life |> zip [|0..width * height - 1|] |> filter (fun (_, a) -> a)
|> iter (fun (i, _) -> pixel yellow (i % width * 2, i / width * 2 + 10))
life <- tick life
}
//press 'enter' to restart game.
onevent (KeyDown 13) { life <- [|0..width * height - 1|] |> map (fun _ -> random.Next() % 2 = 0) }
Console.ReadLine() |> ignore
open System
open Array
let width, height = 100, 100
let tick game =
let number index =
let X, Y = index % width, index / width
[|(-1, -1); (0, -1); (1, -1); (1, 0); (1, 1); (0, 1); (-1, 1); (-1, 0)|]
|> map (fun (x, y) -> X + x, Y + y)
|> filter (fun (x, y) -> x > 0 && x < width && y > 0 && y < height)
|> map (fun (x, y) -> y * width + x)
|> map (fun i -> if game.[i] then 1 else 0)
|> sum
game |> mapi (fun i alive ->
match (alive, number i) with
| (true, n) when n < 2 -> false
| (true, n) when n > 3 -> false
| (true, _) -> true
| (false, 3) -> true
| (false, _) -> false
| _ -> failwith "no."
)
let random = Random()
let mutable life = [|0..width * height - 1|] |> map (fun _ -> random.Next() % 2 = 0)
open SdlSimple
SdlSimpleSetup (width * 2) (height * 2 + 10) 16 false
draw {
let yellow = colour 255 255 0
life |> zip [|0..width * height - 1|] |> filter (fun (_, a) -> a)
|> iter (fun (i, _) -> pixel yellow (i % width * 2, i / width * 2 + 10))
life <- tick life
}
//press 'enter' to restart game.
onevent (KeyDown 13) { life <- [|0..width * height - 1|] |> map (fun _ -> random.Next() % 2 = 0) }
Console.ReadLine() |> ignore
next: Compiling Game of Life