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