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
}
 

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
 

#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
 

#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)))
 

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)
 

let _random = System.Random()
let rand() = _random.Next()
let num = 200000
let unsorted = [1..num] |> List.map (fun _ -> rand() % num)

#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
 

regex "d[a-z]g" =~ "the dog is brown" |> printf "%b\n"

"d[a-z]g" ^~ "the dog is brown" |> printf "%b\n"

let [_; the; pen; works; correctly] = "(\w+) (\w+) (\w+) (\w+)" =~~ "the pen works correctly"
printf "%s,%s,%s,%s\n" the pen works correctly

for i in "(\w+) (\w+)" =~~~ "james 12 charles 78 helmut 43" do
   printf "[%s,%s] " i.[1] i.[2]

".o" =~~~ "do you remember willo the wisp?"
   |> Seq.map (fun (x :: []) -> x)
   |> Seq.iter (printf "[%s] ")

let split = (regex " ").Split("i fancy he is a bedlamite")
for word in split do printf "%s, " word

[1..100]
   |> List.map string
   |> List.filter ((=~) "1.+")
   |> List.iter (printf "%s,")

[<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)
 

[<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>)
 

(!event).type

GetEventType.Get(!event)

using Tao.Sdl;
public class GetEventType {
        public static int Get(Sdl.SDL_Event e) {
                return e.type;
        }
}

using Tao.Sdl;
public class GetJaxisValue {
        public static short Get(Sdl.SDL_Event e) {
                return e.jaxis.val;
        }
}
 

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."
 

type sdlevent =
   | KeyUp of int
   | KeyDown of int
   | MouseMove of int * int
   ...etc...

events |> Event.listen (fun e ->
   match e with
   | KeyDown x -> printf "%s pressed.\n" (scancodeToKey x)
   | KeyUp x -> printf "%s released.\n" (scancodeToKey x)
   | _ -> ()
)
 

for (s, e) in drawevents do e()

drawfire (Draw ("hello", (fun () ->
   write (colour 255 255 255) "hello" (100, 100)
)))

drawfire (Erease "hello")

//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")
 

//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"
}
 

try ["/usr/local/share/libpcxf/palette.gpl"; "/usr/share/libpcxf/palette.gpl"; "palette.gpl"]        
   |> List.find System.IO.File.Exists |> setPalette |> ignore with | _ -> ()
 

#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