(* ==== types ==== *)

type button_t = 
    | LEFT_BUTTON 
    | MIDDLE_BUTTON 
    | RIGHT_BUTTON
    | OTHER_BUTTON of int

type mouse_button_state_t = 
    | DOWN 
    | UP 

type special_key_t = 
    | KEY_F1
    | KEY_F2                    
    | KEY_F3            
    | KEY_F4    
    | KEY_F5
    | KEY_F6                    
    | KEY_F7                    
    | KEY_F8                    
    | KEY_F9                    
    | KEY_F10                   
    | KEY_F11                   
    | KEY_F12                   
     (* directional keys *)
    | KEY_LEFT                  
    | KEY_UP                    
    | KEY_RIGHT                 
    | KEY_DOWN                  
    | KEY_PAGE_UP               
    | KEY_PAGE_DOWN             
    | KEY_HOME                  
    | KEY_END                   
    | KEY_INSERT                        

type entry_exit_state_t =
    | LEFT                      
    | ENTERED

type menu_state_t = 
    | MENU_NOT_IN_USE   
    | MENU_IN_USE               

type visibility_state_t =
    | NOT_VISIBLE               
    | VISIBLE                   

type window_status_t = 
    | HIDDEN                    
    | FULLY_RETAINED            
    | PARTIALLY_RETAINED                
    | FULLY_COVERED             

type color_index_component_t =
    | RED                       
    | GREEN                     
    | BLUE                      

type layer_t =
    | NORMAL                    
    | OVERLAY                   

type font_t =
    | STROKE_ROMAN              
    | STROKE_MONO_ROMAN         
    | BITMAP_9_BY_15            
    | BITMAP_8_BY_13            
    | BITMAP_TIMES_ROMAN_10     
    | BITMAP_TIMES_ROMAN_24     
    | BITMAP_HELVETICA_10       
    | BITMAP_HELVETICA_12       
    | BITMAP_HELVETICA_18       

type glut_get_t =
    | WINDOW_X                  
    | WINDOW_Y                  
    | WINDOW_WIDTH              
    | WINDOW_HEIGHT             
    | WINDOW_BUFFER_SIZE                
    | WINDOW_STENCIL_SIZE       
    | WINDOW_DEPTH_SIZE         
    | WINDOW_RED_SIZE           
    | WINDOW_GREEN_SIZE         
    | WINDOW_BLUE_SIZE          
    | WINDOW_ALPHA_SIZE         
    | WINDOW_ACCUM_RED_SIZE     
    | WINDOW_ACCUM_GREEN_SIZE   
    | WINDOW_ACCUM_BLUE_SIZE    
    | WINDOW_ACCUM_ALPHA_SIZE   
    | WINDOW_DOUBLEBUFFER       
    | WINDOW_RGBA               
    | WINDOW_PARENT             
    | WINDOW_NUM_CHILDREN       
    | WINDOW_COLORMAP_SIZE      
    | WINDOW_NUM_SAMPLES                
    | WINDOW_STEREO             
    | WINDOW_CURSOR             
    | SCREEN_WIDTH              
    | SCREEN_HEIGHT             
    | SCREEN_WIDTH_MM           
    | SCREEN_HEIGHT_MM          
    | MENU_NUM_ITEMS            
    (* | DISPLAY_MODE_POSSIBLE : use getBool *)
    | INIT_WINDOW_X             
    | INIT_WINDOW_Y             
    | INIT_WINDOW_WIDTH         
    | INIT_WINDOW_HEIGHT                
    | INIT_DISPLAY_MODE         
    | ELAPSED_TIME              
    | WINDOW_FORMAT_ID 

type glut_get_bool_t = 
    | DISPLAY_MODE_POSSIBLE

let rgb = 0;;
let rgba = rgb;; (* same as in glut.h *)
let index = 1;;
let single = 0;;
let double = 2;;
let accum = 4;;
let alpha = 8;;
let depth = 16;;
let stencil = 32;;
let multisample = 128;;
let stereo = 256;;
let luminance = 512;;

type device_get_t =
    | HAS_KEYBOARD              
    | HAS_MOUSE                 
    | HAS_SPACEBALL             
    | HAS_DIAL_AND_BUTTON_BOX   
    | HAS_TABLET                        
    | NUM_MOUSE_BUTTONS         
    | NUM_SPACEBALL_BUTTONS     
    | NUM_BUTTON_BOX_BUTTONS    
    | NUM_DIALS                 
    | NUM_TABLET_BUTTONS                
    | DEVICE_IGNORE_KEY_REPEAT   
    | DEVICE_KEY_REPEAT          
    | HAS_JOYSTICK              
    | OWNS_JOYSTICK             
    | JOYSTICK_BUTTONS          
    | JOYSTICK_AXES             
    | JOYSTICK_POLL_RATE                

type layerget_t = 
    | OVERLAY_POSSIBLE           
    (* | LAYER_IN_USE : use layerGetInUse *)
    | HAS_OVERLAY               
    (* | TRANSPARENT_INDEX : use layerGetTransparentIndex *)
    | NORMAL_DAMAGED            
    | OVERLAY_DAMAGED           

type video_resize_t = 
    | VIDEO_RESIZE_POSSIBLE     
    | VIDEO_RESIZE_IN_USE       
    | VIDEO_RESIZE_X_DELTA      
    | VIDEO_RESIZE_Y_DELTA      
    | VIDEO_RESIZE_WIDTH_DELTA  
    | VIDEO_RESIZE_HEIGHT_DELTA 
    | VIDEO_RESIZE_X            
    | VIDEO_RESIZE_Y            
    | VIDEO_RESIZE_WIDTH                
    | VIDEO_RESIZE_HEIGHT       

type get_modifiers_t = 
    | ACTIVE_SHIFT               
    | ACTIVE_CTRL                
    | ACTIVE_ALT                 

let active_shift = 1
let active_ctrl = 2
let active_alt = 4

type cursor_t = 
     (* Basic arrows. *)
    | CURSOR_RIGHT_ARROW                
    | CURSOR_LEFT_ARROW         
     (* Symbolic cursor shapes. *)
    | CURSOR_INFO               
    | CURSOR_DESTROY            
    | CURSOR_HELP               
    | CURSOR_CYCLE              
    | CURSOR_SPRAY              
    | CURSOR_WAIT               
    | CURSOR_TEXT               
    | CURSOR_CROSSHAIR          
     (* Directional cursors. *)
    | CURSOR_UP_DOWN            
    | CURSOR_LEFT_RIGHT         
     (* Sizing cursors. *)
    | CURSOR_TOP_SIDE           
    | CURSOR_BOTTOM_SIDE                
    | CURSOR_LEFT_SIDE          
    | CURSOR_RIGHT_SIDE         
    | CURSOR_TOP_LEFT_CORNER    
    | CURSOR_TOP_RIGHT_CORNER   
    | CURSOR_BOTTOM_RIGHT_CORNER        
    | CURSOR_BOTTOM_LEFT_CORNER 
    | CURSOR_INHERIT              (* inherit cursor from parent window *)
    | CURSOR_NONE                     (* blank cursor *)
    | CURSOR_FULL_CROSSHAIR   (* full-screen crosshair  : if available *)

type game_mode_t = 
    | GAME_MODE_ACTIVE
    | GAME_MODE_POSSIBLE
    | GAME_MODE_WIDTH
    | GAME_MODE_HEIGHT
    | GAME_MODE_PIXEL_DEPTH
    | GAME_MODE_REFRESH_RATE
    | GAME_MODE_DISPLAY_CHANGED

type key_repeat_t = 
    | KEY_REPEAT_OFF
    | KEY_REPEAT_ON
    | KEY_REPEAT_DEFAULT

exception BadEnum of string
exception InvalidState of string 
exception OverlayNotInUse of string

open Printf;;

external getWindow: unit -> int = "ml_glutGetWindow"

(* generate name for callbacks, based on window id *)
let cbname glutname = 
    let name = sprintf "ocaml_%s_cb_%i" glutname (getWindow()) in
    (* printf "ocaml cbname: %s" name; print_newline(); *)
    name;;

(* general routine to set up a glut callback *)
let setup glutname glutwrapper cb = 
    let _ = Callback.register (cbname glutname) cb in
    glutwrapper (); (* register the callback with GLUT *)
    ;;


(* ==== file-local variables ==== *)

let is_init = ref false;;
let is_displayModeInit = ref false;;
let is_windowSizeInit = ref false;;
let is_windowPositionInit = ref false;;
let has_createdWindow = ref false;;

 (* === GLUT initialization sub-API. === *)
external _glutInit : int -> string array -> unit = "ml_glutInit" 

let new_argv = ref [];; (* built by a callback from _glutInit *)

let add_arg str =
    new_argv := str :: !new_argv;;

let init ~argv = 
    is_init := true;
    let argc = (Array.length argv) in
    let _ = Callback.register "add_arg" add_arg in
    _glutInit argc argv;
    let retargs = Array.of_list(List.rev !new_argv) in
    retargs;;

external _glutInitDisplayMode : 
    double_buffer:bool ->
    index:bool ->
    accum:bool ->
    alpha:bool ->
    depth:bool ->
    stencil:bool ->
    multisample:bool ->
    stereo:bool ->
    luminance:bool ->
    unit =
    "bytecode_glutInitDisplayMode"
    "native_glutInitDisplayMode"

let initDisplayMode 
    ?(double_buffer=false)
    ?(index=false) 
    ?(accum=false)
    ?(alpha=false) 
    ?(depth=false) 
    ?(stencil=false) 
    ?(multisample=false) 
    ?(stereo=false) 
    ?(luminance=false) 
    dummy_unit
    = 
    is_displayModeInit := true;
    _glutInitDisplayMode 
        double_buffer
        index
        accum
        alpha
        depth
        stencil
        multisample
        stereo
        luminance
    ;;

external _glutInitWindowSize : int->int->unit = "ml_glutInitWindowSize"

external _glutInitWindowPosition : int->int->unit = "ml_glutInitWindowPosition"
let initWindowPosition ~x ~y =
    is_windowPositionInit := true;
    _glutInitWindowPosition x y;;

let initWindowSize ~w ~h =   
    is_windowSizeInit := true;
    _glutInitWindowSize w h;;

external mainLoop : unit->unit = "ml_glutMainLoop"

 (* === GLUT window sub-API. === *)

external _glutCreateWindow : string->int = "ml_glutCreateWindow"

let createWindow ~title =
    has_createdWindow := true;
    let winid = _glutCreateWindow title in
    winid;;

external postRedisplay : unit->unit = 
    "ml_glutPostRedisplay"
external swapBuffers : unit->unit = 
    "ml_glutSwapBuffers" 
external createSubWindow: win:int->x:int->y:int->w:int->h:int->int = 
    "ml_glutCreateSubWindow"
external destroyWindow: win:int -> unit = 
    "ml_glutDestroyWindow"
external setWindow: win:int -> unit = 
    "ml_glutSetWindow"
external setWindowTitle: title:string -> unit  = 
    "ml_glutSetWindowTitle"
external setIconTitle: title:string -> unit = 
    "ml_glutSetIconTitle"
external positionWindow: x:int -> y:int -> unit = 
    "ml_glutPositionWindow"
external reshapeWindow: w:int -> h:int -> unit = 
    "ml_glutReshapeWindow"
external popWindow: unit -> unit = 
    "ml_glutPopWindow"
external pushWindow: unit -> unit = 
    "ml_glutPushWindow"
external iconifyWindow: unit -> unit = 
    "ml_glutIconifyWindow"
external showWindow: unit -> unit = 
    "ml_glutShowWindow"
external hideWindow: unit -> unit = 
    "ml_glutHideWindow"
external fullScreen: unit -> unit = 
    "ml_glutFullScreen"

external _setCursor: c:int -> unit = "ml_glutSetCursor"
let setCursor c = 
    let ic = match c with 
     (* Basic arrows. *)
    | CURSOR_RIGHT_ARROW -> 0  (* values from glut.h *)
    | CURSOR_LEFT_ARROW -> 1 
     (* Symbolic cursor shapes. *)
    | CURSOR_INFO -> 2
    | CURSOR_DESTROY -> 3
    | CURSOR_HELP -> 4
    | CURSOR_CYCLE -> 5
    | CURSOR_SPRAY -> 6
    | CURSOR_WAIT -> 7
    | CURSOR_TEXT -> 8
    | CURSOR_CROSSHAIR -> 9
     (* Directional cursors. *)
    | CURSOR_UP_DOWN -> 10
    | CURSOR_LEFT_RIGHT -> 11
     (* Sizing cursors. *)
    | CURSOR_TOP_SIDE -> 12
    | CURSOR_BOTTOM_SIDE -> 13
    | CURSOR_LEFT_SIDE -> 14
    | CURSOR_RIGHT_SIDE -> 15
    | CURSOR_TOP_LEFT_CORNER -> 16
    | CURSOR_TOP_RIGHT_CORNER -> 17
    | CURSOR_BOTTOM_RIGHT_CORNER -> 18
    | CURSOR_BOTTOM_LEFT_CORNER -> 19
    | CURSOR_INHERIT -> 100
    | CURSOR_NONE -> 101
    | CURSOR_FULL_CROSSHAIR -> 102
    in _setCursor ic
    ;;

 (* === GLUT overlay sub-API. === *)
external establishOverlay: unit->unit  = "ml_glutEstablishOverlay"
external removeOverlay: unit->unit = "ml_glutRemoveOverlay"
external postOverlayRedisplay: unit->unit = "ml_glutPostOverlayRedisplay"
external showOverlay: unit->unit = "ml_glutShowOverlay"
external hideOverlay: unit->unit = "ml_glutHideOverlay"

external _useLayer: int -> unit = "ml_glutUseLayer"
let useLayer layer = _useLayer (match layer with NORMAL -> 0 | OVERLAY -> 1)

 (* === GLUT menu sub-API. === *)

external _glutCreateMenu : unit->int = "ml_glutCreateMenu"
let createMenu ~cb =
    let _ = Callback.register "ocaml_glutCreateMenu" cb in
    let menu_id = _glutCreateMenu() in
    menu_id
    ;;
    
external destroyMenu: menu:int->unit = 
    "ml_glutDestroyMenu"
external getMenu: unit->int = 
    "ml_glutGetMenu"
external setMenu: menu:int->unit  = 
    "ml_glutSetMenu"
external addMenuEntry: label:string->value:int->unit  = 
    "ml_glutAddMenuEntry"
external addSubMenu: label:string->submenu:int->unit  = 
    "ml_glutAddSubMenu"
external changeToMenuEntry: item:int->label:string->value:int->unit = 
    "ml_glutChangeToMenuEntry"
external changeToSubMenu: item:int->label:string->submenu:int->unit = 
    "ml_glutChangeToSubMenu"
external removeMenuItem: item:int->unit= 
    "ml_glutRemoveMenuItem"

let int_of_button b = match b with
    | LEFT_BUTTON -> 0
    | MIDDLE_BUTTON -> 1
    | RIGHT_BUTTON -> 2
    | OTHER_BUTTON n -> n

let b2i b = int_of_button b;;

external _attachMenu: button:int->unit= "ml_glutAttachMenu"
let attachMenu ~button = _attachMenu (b2i button);;

external _detachMenu: button:int->unit= "ml_glutDetachMenu"
let detachMenu ~button =