Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial commit

  • Loading branch information...
commit d54460078b8248a2032948956bf9f0c29557baa6 0 parents
@serp256 authored
Showing with 25,568 additions and 0 deletions.
  1. +1 −0  LICENSE
  2. +4 −0 META
  3. +10 −0 Makefile
  4. +13 −0 Makefile.include
  5. +25 −0 Makefile.ios
  6. +14 −0 Makefile.macos
  7. +1 −0  README
  8. +230 −0 src/BitmapFont.ml
  9. +6 −0 src/BitmapFont.mli
  10. +127 −0 src/Button.ml
  11. +264 −0 src/CompiledSprite.ml
  12. +645 −0 src/DisplayObject.ml
  13. +102 −0 src/DisplayObject.mli
  14. +79 −0 src/DisplayObjectT.ml
  15. +20 −0 src/Event.ml
  16. +55 −0 src/EventDispatcher.ml
  17. +169 −0 src/GLTexture.ml
  18. +62 −0 src/Image.ml
  19. +14 −0 src/Image.mli
  20. +42 −0 src/LightCommon.ml
  21. +28 −0 src/Lightning.ml
  22. +77 −0 src/MLDepend
  23. +293 −0 src/MList.ml
  24. +55 −0 src/Makefile
  25. +59 −0 src/Matrix.ml
  26. +34 −0 src/OMakefile
  27. BIN  src/OMakefile.omc
  28. +9 −0 src/ObjMemo.ml
  29. +28 −0 src/Point.ml
  30. +110 −0 src/Quad.ml
  31. +18 −0 src/Quad.mli
  32. +8 −0 src/Rectangle.ml
  33. +173 −0 src/RenderSupport.ml
  34. +9 −0 src/Sprite.ml
  35. +8 −0 src/Sprite.mli
  36. +109 −0 src/Stage.ml
  37. +150 −0 src/TextField.ml
  38. +17 −0 src/TextField.mli
  39. +119 −0 src/Texture.ml
  40. +15 −0 src/Texture.mli
  41. +56 −0 src/TextureAtlas.ml
  42. +65 −0 src/Touch.ml
  43. BIN  src/gl/2.1/gl.cmi
  44. +3,997 −0 src/gl/2.1/gl.ml
  45. +2,952 −0 src/gl/2.1/gl.mli
  46. +7,875 −0 src/gl/2.1/gl_stub.c
  47. +890 −0 src/gl/es/gl.ml
  48. +782 −0 src/gl/es/gl.mli
  49. +1,309 −0 src/gl/es/gl_stub.c
  50. BIN  src/gl/gl.cmo
  51. BIN  src/ios/.mlwrapper_ios.m.swp
  52. +79 −0 src/ios/LightView.h
  53. +307 −0 src/ios/LightView.m
  54. +4 −0 src/ios/mlwrapper_ios.h
  55. +41 −0 src/ios/mlwrapper_ios.m
  56. +323 −0 src/ios/texture.m
  57. +103 −0 src/mlwrapper.c
  58. +32 −0 src/mlwrapper.h
  59. BIN  src/sdl/.main.ml.swp
  60. +965 −0 src/sdl/sdl.ml
  61. +1,026 −0 src/sdl/sdl.mli
  62. +25 −0 src/sdl/sdl_image.ml
  63. +27 −0 src/sdl/sdl_image_stub.c
  64. BIN  src/sdl/sdl_run.cmo
  65. +92 −0 src/sdl/sdl_run.ml
  66. +1,416 −0 src/sdl/sdl_stub.c
1  LICENSE
@@ -0,0 +1 @@
+he he he
4 META
@@ -0,0 +1,4 @@
+version="0.01"
+archive(byte)="lightning.cma"
+archive(native)="lightning.cmxa"
+requires="bigarray extlib xmlm"
10 Makefile
@@ -0,0 +1,10 @@
+
+all:
+ $(MAKE) -C src
+
+install:
+ $(OCAMLFIND) install lightning META lightning/lightning.cmxa lightning/lightning.a lightning/*.cmi lightning/*.mli
+
+clean:
+ $(MAKE) -C src clean
+
13 Makefile.include
@@ -0,0 +1,13 @@
+include /Users/serp/Projects/osparrow/Makefile.ios
+
+MLPPOPT =
+MLFLAGS = -package camlp4,camlp4.macro -syntax camlp4r -w +7+9 -g
+
+%.cmi: %.mli
+ $(OCAMLC) $(MLFLAGS) -c $<
+
+%.cmo: %.ml
+ $(OCAMLC) $(MLFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) -c $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(MLFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) -c $<
25 Makefile.ios
@@ -0,0 +1,25 @@
+PLATFORM = ios
+PLAT = /Developer/Platforms/iPhoneOS.platform
+SDK = /Developer/SDKs/iPhoneOS4.3.sdk
+OCAMLDIR = /usr/local/ocaml/xarm/3.12.0
+OCAMLFIND = /usr/local/bin/ocamlfind -toolchain arm
+ARCH = -arch armv6
+OCAMLBINDIR = $(OCAMLDIR)/bin/
+CC = $(PLAT)/Developer/usr/bin/gcc-4.2 $(ARCH)
+CFLAGS = -x objective-c -std=c99 -Wno-trigraphs -fpascal-strings -O0 -DDEBUG -Wreturn-type -Wunused-variable -isysroot $(PLAT)$(SDK) -isystem $(OCAMLDIR)/lib -DCAML_NAME_SPACE -fexceptions -miphoneos-version-min=4.2 -gdwarf-2 -DDEBUG -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+#CFLAGS = -std=c99 -DDEBUG -Wreturn-type -Wunused-variable -isysroot $(PLAT)$(SDK) -isystem $(OCAMLDIR)/lib -DCAML_NAME_SPACE -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+# -mmacosx-version-min=10.6 -fobjc-abi-version=2 -fobjc-legacy-dispatch -D__IPHONE_OS_VERSION_MIN_REQUIRED=40200
+OCAMLOPT = $(OCAMLFIND) ocamlopt
+OCAMLC = $(OCAMLFIND) ocamlc
+OCAMLLIB = /usr/local/ocaml/xarm/3.12.0/bin/ocamlmklib
+MLFLAGS = -package camlp4,camlp4.macro -syntax camlp4r -w +7+9 -g
+
+
+%.cmi: %.mli
+ $(OCAMLC) $(MLFLAGS) -c $<
+
+%.cmo: %.ml
+ $(OCAMLC) $(MLFLAGS) -c $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(MLFLAGS) -c $<
14 Makefile.macos
@@ -0,0 +1,14 @@
+#PLAT = /Developer/Platforms/MaxOSX.platform
+#SDK = /Developer/SDKs/iPhoneOS4.3.sdk
+SDK = /Developer/SDKs/MacOSX10.6.sdk
+OCAMLDIR = /usr/local/
+OCAMLFIND = /usr/local/bin/ocamlfind
+#ARCH = -arch armv6
+OCAMLBINDIR = $(OCAMLDIR)/bin/
+CC = gcc-4.2
+CFLAGS = -x objective-c -std=c99 -Wno-trigraphs -fpascal-strings -O0 -DDEBUG -Wreturn-type -Wunused-variable -isysroot $(SDK) -isystem $(OCAMLDIR)/lib/ocaml -DCAML_NAME_SPACE -fexceptions -gdwarf-2 -DDEBUG -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+#CFLAGS = -std=c99 -DDEBUG -Wreturn-type -Wunused-variable -isysroot $(PLAT)$(SDK) -isystem $(OCAMLDIR)/lib -DCAML_NAME_SPACE -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+# -mmacosx-version-min=10.6 -fobjc-abi-version=2 -fobjc-legacy-dispatch -D__IPHONE_OS_VERSION_MIN_REQUIRED=40200
+OCAMLOPT = $(OCAMLFIND) ocamlopt
+OCAMLC = $(OCAMLFIND) ocamlc
+OCAMLLIB = /usr/local/bin/ocamlmklib
1  README
@@ -0,0 +1 @@
+ha ha ha
230 src/BitmapFont.ml
@@ -0,0 +1,230 @@
+
+open LightCommon;
+
+
+type bc =
+ {
+ charID:int;
+ xOffset:float;
+ yOffset:float;
+ xAdvance: float;
+ charTexture: Texture.c;
+ };
+
+type t =
+ {
+ texture: Texture.c;
+ chars: Hashtbl.t int bc;
+ name: string;
+ size: float;
+ lineHeight: float;
+ };
+
+value fonts = Hashtbl.create 0;
+value exists name = Hashtbl.mem fonts name;
+exception Font_not_found of string;
+value get name =
+ try
+ Hashtbl.find fonts name
+ with [ Not_found -> raise (Font_not_found name) ];
+
+DEFINE CHAR_NEWLINE = 10;
+DEFINE CHAR_SPACE = 32;
+DEFINE CHAR_TAB = 9;
+
+value createText t ~width ~height ?(size=t.size) ~color ?(border=False) ?hAlign ?vAlign text =
+ let lineContainer = Sprite.create ()
+ and scale = size /. t.size in
+ let containerWidth = width /. scale
+ and containerHeight = height /. scale
+ in
+ (
+ lineContainer#setScale scale;
+ let lines = Queue.create () in
+ (
+ let strLength = String.length text
+ and lastWhiteSpace = ref None in
+ let rec add_line currentLine index =
+ (
+ Queue.add currentLine lines;
+ match index with
+ [ Some index ->
+ let nextLineY = currentLine#y +. t.lineHeight in
+ if nextLineY +. t.lineHeight <= containerHeight
+ then
+ let nextLine = Sprite.create () in
+ (
+ nextLine#setY nextLineY;
+ lastWhiteSpace.val := None;
+ add_char nextLine 0. index
+ )
+ else ()
+ | None -> ()
+ ]
+ )
+ and add_char currentLine (currentX:float) index =
+(* let () = Printf.printf "add char with index: %d\n%!" index in *)
+ if index < strLength
+ then
+ let code = UChar.code (UTF8.look text index) in
+ let bchar = try Hashtbl.find t.chars code with [ Not_found -> let () = Printf.eprintf "char %d not found\n%!" code in Hashtbl.find t.chars CHAR_SPACE ] in
+ if code = CHAR_NEWLINE
+ then
+ add_line currentLine (Some (UTF8.next text index))
+ else
+ if currentX +. bchar.xAdvance > containerWidth
+ then
+ let idx =
+ match !lastWhiteSpace with
+ [ Some idx ->
+ let removeIndex = idx in
+ let numCharsToRemove = currentLine#numChildren - removeIndex in
+ (
+(* let () = Printf.printf "lastWhiteSpace: numChildren: %d, removeIndex: %d, numCharsToRemove: %d\n%!" currentLine#numChildren removeIndex numCharsToRemove in *)
+ for i = 0 to numCharsToRemove - 1 do
+(* let () = Printf.printf "remove %d\n%!" currentLine#numChildren in *)
+ currentLine#removeChildAtIndex removeIndex
+ done;
+ UTF8.move text index ~-numCharsToRemove
+ )
+ | None -> index
+ ]
+ in
+ add_line currentLine (Some idx)
+ else
+ let bitmapChar = Image.create bchar.charTexture in
+ (
+ bitmapChar#setName (Printf.sprintf "letter: %d" index);
+ bitmapChar#setX (currentX +. bchar.xOffset);
+ bitmapChar#setY bchar.yOffset;
+ bitmapChar#setColor color;
+ currentLine#addChild bitmapChar;
+ if code = CHAR_SPACE then lastWhiteSpace.val := Some currentLine#numChildren else ();
+ add_char currentLine (currentX +. bchar.xAdvance) (UTF8.next text index)
+ )
+ else add_line currentLine None
+ in
+ add_char (Sprite.create()) 0. 0;
+ match hAlign with
+ [ Some ((`HAlignRight | `HAlignCenter) as halign) ->
+ Queue.iter begin fun line ->
+ (
+ let lastChar = line#getLastChild in
+ let lineWidth = lastChar#x +. lastChar#width in
+ let widthDiff = containerWidth -. lineWidth in
+ let () = Printf.printf "lastChar#x: %f, lastChar#width: %f, lineWidth: %f, widthDiff: %f\n%!" lastChar#x lastChar#width lineWidth widthDiff in
+ line#setX begin
+ match halign with
+ [ `HAlignRight -> widthDiff
+ | `HAlignCenter -> widthDiff /. 2.
+ ]
+ end;
+ lineContainer#addChild line
+ )
+ end lines
+ | _ -> Queue.iter lineContainer#addChild lines
+ ];
+ );
+ let outerContainer = CompiledSprite.create () in (* FIXME: must be compiled sprite *)
+ (
+ outerContainer#addChild lineContainer;
+ match vAlign with
+ [ Some ((`VAlignCenter | `VAlignBottom) as valign) ->
+ let contentHeight = (float lineContainer#numChildren) *. t.lineHeight *. scale in
+ let heightDiff = height -. contentHeight in
+ lineContainer#setY begin
+ match valign with
+ [ `VAlignBottom -> heightDiff
+ | `VAlignCenter -> heightDiff /. 2.
+ ]
+ end
+ | _ -> ()
+ ];
+ if border
+ then
+ let topBorder = Quad.create width 1.
+ and bottomBorder = Quad.create width 1.
+ and leftBorder = Quad.create 1. (height -. 2.)
+ and rightBorder = Quad.create 1. (height -. 2.)
+ in
+ (
+ topBorder#setColor color;
+ bottomBorder#setColor color;
+ leftBorder#setColor color;
+ rightBorder#setColor color;
+ bottomBorder#setY (height -. 1.);
+ leftBorder#setY 1.;
+ rightBorder#setY 1.;
+ rightBorder#setX (width -. 1.);
+ outerContainer#addChild topBorder;
+ outerContainer#addChild bottomBorder;
+ outerContainer#addChild leftBorder;
+ outerContainer#addChild rightBorder;
+ )
+ else ();
+ outerContainer;
+ )
+ );
+
+value register path = (*{{{*)
+ let path = resource_path path 1. in
+ let input = open_in path in
+ let xmlinput = Xmlm.make_input ~strip:True (`Channel input) in
+ let () = ignore(Xmlm.input xmlinput) in (* ignore dtd *)
+ let parse_info () =
+ let res = parse_xml_element xmlinput "info" [ "face"; "size"] in
+ (List.assoc "face" res,float_of_string (List.assoc "size" res))
+ and parse_common () =
+ let res = parse_xml_element xmlinput "common" [ "lineHeight"] in
+ float_of_string ( List.assoc "lineHeight" res)
+ and parse_page () =
+ match Xmlm.input xmlinput with
+ [ `El_start ((_,"pages"),_) ->
+ let res = parse_xml_element xmlinput "page" [ "file"] in
+ (
+ match Xmlm.input xmlinput with
+ [ `El_end -> List.assoc "file" res
+ | _ -> failwith "Bitmap fonts with multiple pages are not supported"
+ ]
+ )
+ | _ -> assert False
+ ]
+ and parse_chars texture =
+ match Xmlm.input xmlinput with
+ [ `El_start ((_,"chars"),attributes) ->
+ let count = get_xml_attribute "count" attributes in
+ let chars = Hashtbl.create (int_of_string count) in
+ let rec loop () =
+ match Xmlm.peek xmlinput with
+ [ `El_end -> (ignore(Xmlm.input xmlinput); chars)
+ | _ ->
+ (
+ let res = parse_xml_element xmlinput "char" ["id";"x";"y";"width";"height";"xoffset";"yoffset";"xadvance"] in
+ let charID = int_of_string (List.assoc "id" res) in
+ let get_float x = float_of_string (List.assoc x res) in
+ let bc =
+ let region = Rectangle.create (get_float "x") (get_float "y") (get_float "width") (get_float "height") in
+ let charTexture = Texture.createSubTexture region texture in
+ { charID ; xOffset = get_float "xoffset"; yOffset = get_float "yoffset"; xAdvance = get_float "xadvance"; charTexture }
+ in
+ Hashtbl.add chars charID bc;
+ loop ()
+ )
+ ]
+ in
+ loop ()
+ | _ -> assert False
+ ]
+ in
+ match Xmlm.input xmlinput with
+ [ `El_start ((_,"font"),_) ->
+ let (name,size) = parse_info () in
+ let lineHeight = parse_common () in
+ let imgFile = parse_page () in
+ let texture = Texture.createFromFile imgFile in
+ let chars = parse_chars texture in
+ let bf = { texture; chars; name; size; lineHeight } in
+ let () = Printf.printf "register font %s\n%!" name in
+ Hashtbl.add fonts name bf
+ | _ -> assert False
+ ];(*}}}*)
6 src/BitmapFont.mli
@@ -0,0 +1,6 @@
+
+type t;
+value register: string -> unit;
+value exists: string -> bool;
+value get: string -> t;
+value createText: t -> ~width:float -> ~height:float -> ?size:float -> ~color:int -> ?border:bool -> ?hAlign:LightCommon.halign -> ?vAlign:LightCommon.valign -> string -> CompiledSprite.c _ _;
127 src/Button.ml
@@ -0,0 +1,127 @@
+
+DEFINE MAX_DRAG_DIST = 40.;
+
+class c ['event_type,'event_data] ?downstate ?text upstate =
+ let width = upstate#width and height = upstate#height in
+ object(self)
+ inherit DisplayObject.container ['event_type,'event_data];
+ value upState:Texture.c = upstate;
+ value downState:Texture.c = match downstate with [ None -> upstate | Some ds -> ds ];
+ value contents = Sprite.create ();
+ value background = Image.create upstate;
+ value mutable textBounds: Rectangle.t = Rectangle.create 0. 0. width height;
+ value scaleWhenDown: float = match downstate with [ None -> 0.9 | _ -> 1.0 ];
+ value alphaWhenDisabled: float = 0.5;
+ value mutable enabled = True;
+ value mutable isDown = False;
+ value mutable textField =
+ match text with
+ [ None -> None
+ | Some text ->
+ let r = TextField.create ~width ~height text in
+ (
+ r#setBorder True;
+ r#setHAlign `HAlignCenter; r#setVAlign `VAlignCenter;
+ Some r
+ )
+ ];
+
+ initializer
+ (
+ background#setName "button background";
+ contents#addChild background;
+ match textField with [ Some tf -> contents#addChild tf | None -> () ];
+ self#addChild contents;
+ self#addEventListener `TOUCH self#onTouch;
+ );
+
+ method private onTouch touchEvent = (*{{{*)
+ match enabled with
+ [ False -> ()
+ | True ->
+ let open Touch in
+ match touchEvent.Event.data with
+ [ `Touch touches ->
+ match touchesWithTarget touches self with
+ [ [ touch :: _ ] ->
+ match touch.phase with
+ [ TouchPhaseBegan ->
+ (
+ background#setTexture downState;
+ contents#setScale scaleWhenDown;
+ contents#setX ((1. -. scaleWhenDown) /. 2. *. downState#width);
+ contents#setY ((1. -. scaleWhenDown) /. 2. *. downState#height);
+ isDown := True;
+ )
+ | TouchPhaseMoved when isDown ->
+ let open Rectangle in
+ let () = Printf.eprintf "self: %s, parent: %s\n%!" name (match parent with [ None -> "NONE" | Some p -> p#name ]) in
+ let buttonRect = self#boundsInSpace self#stage in
+ if (touch.globalX < buttonRect.x -. MAX_DRAG_DIST) ||
+ (touch.globalY < buttonRect.y -. MAX_DRAG_DIST) ||
+ (touch.globalX > buttonRect.x +. buttonRect.width +. MAX_DRAG_DIST) ||
+ (touch.globalY > buttonRect.y +. buttonRect.height +. MAX_DRAG_DIST)
+ then
+ self#resetContents ()
+ else ()
+ | TouchPhaseEnded when isDown ->
+ (
+ self#resetContents ();
+ self#dispatchEvent (Event.create `TRIGGERED ());
+ )
+ | TouchPhaseCancelled when isDown -> self#resetContents ()
+ | _ -> ()
+ ]
+ | _ -> assert False
+ ]
+ | _ -> assert False
+ ]
+ ];(*}}}*)
+
+ method private resetContents () = (*{{{*)
+ (
+ isDown := False;
+ background#setTexture upState;
+ contents#setPos (0.,0.);
+ contents#setScale 1.;
+ );(*}}}*)
+
+
+ method private textField =
+ match textField with
+ [ None ->
+ let r = TextField.create ~width:textBounds.Rectangle.width ~height:textBounds.Rectangle.height "" in
+ (
+ r#setX textBounds.Rectangle.x;
+ r#setY textBounds.Rectangle.y;
+ r#setHAlign `HAlignCenter; r#setVAlign `VAlignCenter;
+ contents#addChild r;
+ textField := Some r;
+ r
+ )
+ | Some tf -> tf
+ ];
+
+ method setText text =
+ let tf = self#textField in
+ tf#setText text;
+
+ method setFontName fname =
+ let tf = self#textField in
+ tf#setFontName fname;
+
+ method setFontColor color =
+ let tf = self#textField in
+ tf#setColor color;
+
+ method setFontSize size =
+ let tf = self#textField in
+ tf#setFontSize size;
+
+ method setTextBounds bounds = textBounds := bounds;
+
+ end;
+
+
+
+value create = new c;
264 src/CompiledSprite.ml
@@ -0,0 +1,264 @@
+open Gl;
+
+value collectInfo obj = (*{{{*)
+ let scratchBuf = Gl.make_float_array 8
+ and vertexData = IO.output_string ()
+ and colorData = IO.output_string ()
+ and texCoordData = IO.output_string ()
+ in
+ let rec loop obj currentMatrix alpha textures =
+ match obj#alpha = 0.0 || not obj#visible with
+ [ True -> textures
+ | False ->
+ match obj#dcast with
+ [ `Container cont ->
+ Enum.fold begin fun child textures ->
+ let childMatrix = child#transformationMatrix in
+ (
+ Matrix.concat childMatrix currentMatrix;
+ loop child childMatrix (alpha *. child#alpha) textures
+ )
+ end textures cont#children
+ | `Object obj ->
+ match Quad.cast obj with
+ [ Some quad ->
+ (
+ (* Vertexes *)
+ quad#copyVertexCoords scratchBuf;
+ for i = 0 to 3 do
+ let x = scratchBuf.{2*i}
+ and y = scratchBuf.{2*i+1}
+ in
+ let (x,y) = Matrix.transformPoint currentMatrix (x,y) in
+ (
+ Printf.eprintf "%s = %s\n" quad#name (Point.to_string (x,y));
+ IO.write_real_i32 vertexData (Int32.bits_of_float x);
+ IO.write_real_i32 vertexData (Int32.bits_of_float y);
+ )
+ done;
+ (* Colors *)
+ let alphaBits = Int32.shift_left (Int32.of_float (alpha *. 255.)) 24 in
+ Enum.iter begin fun c ->
+ let c = Int32.logor (Int32.of_int c) alphaBits in
+ IO.write_real_i32 colorData c
+ end quad#vertexColors;
+ (* and textures *)
+ match Image.cast quad with
+ [ Some image ->
+ let texture = image#texture in
+ let textures =
+ match textures with
+ [ [ (Some last_texture,count) :: tl ] when last_texture#textureID = texture#textureID -> [ (Some texture,count + 4) :: tl]
+ | _ -> [ (Some texture,4) :: textures ]
+ ]
+ in
+ ( (* texture vertexes *)
+ image#copyTexCoords scratchBuf;
+ texture#adjustTextureCoordinates scratchBuf;
+ for i = 0 to 3 do
+ IO.write_real_i32 texCoordData (Int32.bits_of_float scratchBuf.{2*i});
+ IO.write_real_i32 texCoordData (Int32.bits_of_float scratchBuf.{2*i + 1});
+ done;
+ textures
+ )
+ | None ->
+ (
+ (* we need to push fake texCoords *)
+ IO.nwrite texCoordData "00000000000000000000000000000000";
+ match textures with
+ [ [ (None, count) :: tl ] -> [ (None,count + 4) :: tl]
+ | _ -> [ (None,4) :: textures ]
+ ];
+ )
+ ]
+ )
+ | None -> assert False
+ ]
+ ]
+ ]
+ in
+ let textures = loop obj#asDisplayObject (Matrix.create()) 1.0 [] in
+ (IO.close_out vertexData,IO.close_out colorData,IO.close_out texCoordData,List.rev textures);
+(*}}}*)
+
+class c ['event_type,'event_data] =
+ object(self)
+ inherit Sprite.c ['event_type,'event_data];
+
+ value buffers = Array.make 4 0;
+ value mutable textureSwitches = [];
+ value mutable colorData = "";
+ value mutable compiled = False;
+ value mutable colorsUpdated = False;
+ initializer Gc.finalise (fun _ -> self#deleteBuffers()) self;
+
+ method private deleteBuffers () =
+ match ExtArray.Array.for_all (fun x -> x = 0) buffers with
+ [ True -> ()
+ | False ->
+ (
+ prerr_endline "delete buffers";
+ glDeleteBuffers 4 buffers;
+ for i = 0 to 3 do buffers.(i) := 0; done;
+ )
+ ];
+
+ method compile () = (*{{{*)
+ (
+(* prerr_endline "compile"; *)
+ self#deleteBuffers();
+ textureSwitches := [];
+ colorData := "";
+ colorsUpdated := False;
+ let (vertexData,colorData',texCoordData,textures) = collectInfo self in
+ (
+ glGenBuffers 4 buffers;
+ let () = Printf.eprintf "buffers: [ %s ]\n" (String.concat ";" (List.map string_of_int (Array.to_list buffers))) in
+ let numVerticies = String.length vertexData / 4 / 2 in
+ let numQuads = numVerticies / 4 in
+ let indexBufferSize = numQuads * 6 in (* 4 + 2 for degenerate triangles *)
+ let indices = Gl.make_ushort_array indexBufferSize in
+ (
+ let pos = ref 0 in
+ for i = 0 to numQuads - 1 do
+ indices.{!pos} := i*4; incr pos;
+ for j = 0 to 3 do
+ indices.{!pos} := i*4 + j; incr pos;
+ done;
+ indices.{!pos} := i*4 + 3; incr pos;
+ done;
+
+
+(*
+ for i = 0 to indexBufferSize - 1 do
+ Printf.eprintf "indices %d = %d\n" i indices.{i};
+ done;
+*)
+
+ (* index buffer *)
+ glBindBuffer gl_element_array_buffer buffers.(0);
+ glBufferData gl_element_array_buffer (indexBufferSize * 2) indices gl_static_draw;
+ glBindBuffer gl_element_array_buffer 0;
+ );
+
+ (* vertex buffer *)
+ glBindBuffer gl_array_buffer buffers.(1);
+(* Printf.eprintf "vertexData: %d=[%s]\n" (String.length vertexData) (String.concat "," (ExtString.String.fold_right (fun x res -> [ string_of_int (int_of_char x) :: res ]) vertexData [])); *)
+ glBufferData gl_array_buffer (String.length vertexData) vertexData gl_static_draw;
+
+ (* color buffer *)
+ glBindBuffer gl_array_buffer buffers.(2);
+(* Printf.eprintf "colorData: %d=[%s]\n" (String.length colorData') (String.concat "," (ExtString.String.fold_right (fun x res -> [ string_of_int (int_of_char x) :: res ]) colorData' [])); *)
+ glBufferData gl_array_buffer (String.length colorData') colorData' gl_dynamic_draw;
+
+ (* texture coordinate buffer *)
+ glBindBuffer gl_array_buffer buffers.(3);
+(* Printf.eprintf "texCoordData: %d\n" (String.length texCoordData); *)
+ glBufferData gl_array_buffer (String.length texCoordData) texCoordData gl_static_draw;
+
+ glBindBuffer gl_array_buffer 0;
+
+(* Printf.eprintf "textures len: %d\n" (List.length textures); *)
+ textureSwitches := textures;
+ colorData := colorData';
+ prerr_endline "compiled";
+ compiled := True;
+
+ );
+ ); (*}}}*)
+
+ method private updateColorData () = (*{{{*)
+ let currentColors = IO.output_string () (* String.create (String.length colorData) *) (* TODO: may be optimize this allocation? *) in
+ (
+ let offset = ref 0 in
+ List.iter begin fun (texture,numVerticies) ->
+ (
+(* let () = Printf.eprintf "texture:%d,num:%d\n%!" (match texture with [ None -> 0 | Some t -> t#textureID ]) numVerticies in *)
+ let pma =
+ match texture with
+ [ Some texture -> texture#hasPremultipliedAlpha
+ | None -> False
+ ]
+ in
+ for i = 0 to numVerticies - 1 do
+ let j = offset.val + i * 4 in
+ let vertexAlpha = (float_of_int (int_of_char colorData.[j + 3])) /. 255. *. alpha in
+ let blue = int_of_char colorData.[j] and green = int_of_char colorData.[j+1] and red = int_of_char colorData.[j+2] in
+ let newColors =
+ let c =
+ match pma with
+ [ True ->
+ (int_of_float ((float red) *. vertexAlpha)) lor
+ (int_of_float ((float green) *. vertexAlpha) lsl 8) lor
+ (int_of_float ((float blue) *. vertexAlpha) lsl 16)
+ | False -> red lor (green lsl 8) lor (blue lsl 16)
+ ]
+ in
+ Int32.logor (Int32.of_int c) (Int32.shift_left (Int32.of_float (vertexAlpha *. 255.)) 24)
+ in
+ IO.write_real_i32 currentColors newColors;
+ done;
+ offset.val := !offset + (numVerticies * 4)
+ )
+ end textureSwitches;
+
+ (* update buffer *)
+ glBindBuffer gl_array_buffer buffers.(2);
+ let currentColors = IO.close_out currentColors in
+(* let () = Printf.eprintf "currentColors: [%s]\n%!" (String.concat "," (ExtString.String.fold_right (fun x res -> [ string_of_int (int_of_char x) :: res ]) currentColors [])) in *)
+ glBufferSubData gl_array_buffer 0 (String.length currentColors) currentColors;
+ glBindBuffer gl_array_buffer 0;
+ colorsUpdated := True;
+ );(*}}}*)
+
+ method! render () =
+ (
+ if not compiled then self#compile () else ();
+ if not colorsUpdated then self#updateColorData () else ();
+ glBindBuffer gl_element_array_buffer buffers.(0);
+
+ let vertexOffset = ref 0 in
+ List.iter begin fun (texture,numVertices) ->
+ let renderedVertices = (numVertices / 4 ) * 6 in
+(* let () = Printf.eprintf "rendered vertices: %d\n" renderedVertices in *)
+ (
+ match texture with
+ [ None -> RenderSupport.clearTexture ()
+ | Some texture ->
+ (
+ RenderSupport.bindTexture texture;
+ glBindBuffer gl_array_buffer buffers.(3);
+ glEnableClientState gl_texture_coord_array;
+ glTexCoordPointer 2 gl_float 0 0;
+ )
+ ];
+
+ glBindBuffer gl_array_buffer buffers.(1);
+ glEnableClientState gl_vertex_array;
+ glVertexPointer 2 gl_float 0 0;
+
+ glBindBuffer gl_array_buffer buffers.(2);
+ glEnableClientState gl_color_array;
+ glColorPointer 4 gl_unsigned_byte 0 0;
+
+ glDrawElements gl_triangle_strip renderedVertices gl_unsigned_short (!vertexOffset * 2);
+
+ glDisableClientState gl_vertex_array;
+ glDisableClientState gl_color_array;
+ glDisableClientState gl_texture_coord_array;
+
+ vertexOffset.val := !vertexOffset + renderedVertices;
+ )
+ end textureSwitches;
+ glBindBuffer gl_array_buffer 0;
+ glBindBuffer gl_element_array_buffer 0;
+ );
+
+
+
+
+ end;
+
+
+
+value create () = new c;
645 src/DisplayObject.ml
@@ -0,0 +1,645 @@
+open Gl;
+open LightCommon;
+
+type eventType = [= `ADDED | `ADDED_TO_STAGE | `REMOVED | `REMOVED_FROM_STAGE ];
+
+type hidden 'a = 'a;
+
+class virtual _c [ 'event_type, 'event_data , 'parent ] = (*{{{*)
+ object(self:'self)
+ type 'displayObject = _c 'event_type 'event_data 'parent;
+ inherit EventDispatcher.c [ 'event_type , 'event_data, 'displayObject ];
+ type 'event_type = [> eventType ];
+ value mutable scaleX = 1.0;
+
+
+ method scaleX = scaleX;
+ method setScaleX ns = scaleX := ns;
+
+ value mutable scaleY = 1.0;
+ method scaleY = scaleY;
+ method setScaleY ns = scaleY := ns;
+
+ method setScale s = (self#setScaleX s; self#setScaleY s);
+
+ value mutable visible = True;
+ method visible = visible;
+ method setVisible nv = visible := nv;
+
+ value mutable touchable = True;
+ method touchable = touchable;
+ method setTouchable v = touchable := v;
+
+ value mutable x = 0.0;
+ method x = x;
+ method setX x' = x := x';
+
+ value mutable y = 0.0;
+ method y = y;
+ method setY y' = y := y';
+
+ method setPos (x',y') = (x := x'; y := y');
+
+ value mutable parent : option 'parent = None;
+ method parent = parent;
+ method setParent p = parent := Some p;
+ method clearParent () = parent := None;
+
+(* method virtual boundsInSpace: !'target. option ((#_c 'et 'ed 'p) as 'target) -> Rectangle.t; *)
+
+ method virtual boundsInSpace: option (_c 'event_type 'event_data 'parent) -> Rectangle.t;
+
+(* method bounds = self#boundsInSpace (parent :> option (_c 'event_type 'event_data 'parent)); *)
+
+ method bounds =
+ (* бага типовыводилки здеся *)
+ match parent with
+ [ None -> self#boundsInSpace None
+ | Some parent -> self#boundsInSpace (Some parent#asDisplayObject)
+ ];
+
+
+ method width = self#bounds.Rectangle.width;
+
+ method setWidth nw =
+ (
+ (* this method calls 'self.scaleX' instead of changing mScaleX directly.
+ that way, subclasses reacting on size changes need to override only the scaleX method. *)
+ scaleX := 1.0;
+ let actualWidth = self#width in
+ if actualWidth <> 0.0
+ then
+ self#setScaleX (nw /. actualWidth)
+ else self#setScaleX 1.0;
+ );
+
+ method height = self#bounds.Rectangle.height;
+
+ method setHeight nh =
+ (
+ scaleY := 1.0;
+ let actualHeight = self#height in
+ if actualHeight <> 0.0
+ then
+ self#setScaleY (nh /. actualHeight)
+ else self#setScaleY 1.0
+ );
+
+
+ value mutable rotation = 0.0;
+ method rotation = rotation;
+ method setRotation nr =
+ (* clamp between [-180 deg, +180 deg] *)
+ let nr =
+ if nr < ~-.pi
+ then loop nr where rec loop nr = let nr = nr +. two_pi in if nr < ~-.pi then loop nr else nr
+ else nr
+ in
+ let nr =
+ if nr > pi
+ then loop nr where rec loop nr = let nr = nr -. two_pi in if nr > pi then loop nr else nr
+ else nr
+ in
+ rotation := nr;
+
+ value mutable alpha = 1.0;
+ method alpha = alpha;
+ method setAlpha na = alpha := max 0.0 (min 1.0 na);
+
+ value mutable name = "";
+ initializer name := Printf.sprintf "instance%d" (Oo.id self);
+ method name = name;
+ method setName n = name := n;
+
+ value lastTouchTimestamp = 0.;
+ method asDisplayObject = (self :> _c 'event_type 'event_data 'parent);
+ method virtual dcast: [= `Object of 'displayObject | `Container of 'parent ];
+ method isStage = False;
+ method transformationMatrix =
+ let matrix = Matrix.create () in
+ (
+ if scaleX <> 1.0 || scaleY <> 1.0 then Matrix.scaleByXY matrix scaleX scaleY else ();
+ if rotation <> 0.0 then Matrix.rotate matrix rotation else ();
+ if x <> 0.0 || y <> 0.0 then Matrix.translateByXY matrix x y else ();
+ matrix
+ );
+
+ method root =
+ loop self#asDisplayObject where
+ rec loop currentObject =
+ match currentObject#parent with
+ [ None -> currentObject
+ | Some p -> loop p#asDisplayObject
+ ];
+
+ method stage =
+ let root = self#root in
+ match root#isStage with
+ [ True -> Some root
+ | False -> None
+ ];
+
+
+ method transformationMatrixToSpace: option 'displayObject -> Matrix.t = fun targetCoordinateSpace -> (*{{{*)
+ match targetCoordinateSpace with
+ [ None ->
+ let matrix = Matrix.create () in
+ let rec loop currentObject =
+ (
+ Matrix.concat matrix currentObject#transformationMatrix;
+ match currentObject#parent with
+ [ Some parent -> loop parent#asDisplayObject
+ | None -> ()
+ ]
+ )
+ in
+ (
+ loop self#asDisplayObject;
+ matrix
+ )
+ | Some targetCoordinateSpace ->
+ if targetCoordinateSpace#asDisplayObject = self#asDisplayObject
+ then Matrix.create ()
+ else
+ match targetCoordinateSpace#parent with
+ [ Some targetParent when targetParent#asDisplayObject = self#asDisplayObject -> (* optimization *)
+ let targetMatrix = targetCoordinateSpace#transformationMatrix in
+ (
+ Matrix.invert targetMatrix;
+ targetMatrix
+ )
+ | _ ->
+ let () = Printf.eprintf "self: [%s], parent: [%s], targetCoordinateSpace: [%s]\n%!" name (match parent with [ None -> "NONE" | Some s -> s#name ]) targetCoordinateSpace#name in
+ match parent with
+ [ Some parent when parent#asDisplayObject = targetCoordinateSpace -> self#transformationMatrix (* optimization *)
+ | _ ->
+ (* 1.: Find a common parent of self and the target coordinate space *)
+ let ancessors =
+ loop self#asDisplayObject where
+ rec loop currentObject =
+ let next =
+ match currentObject#parent with
+ [ None -> []
+ | Some cp -> loop cp#asDisplayObject
+ ]
+ in
+ [ currentObject :: next ]
+ in
+ let () = Printf.eprintf "ancessors: [%s]\n%!" (String.concat ";" (List.map (fun o -> o#name) ancessors)) in
+ let commonParent =
+ loop targetCoordinateSpace where
+ rec loop currentObject =
+ match List.mem currentObject ancessors with
+ [ True -> currentObject
+ | False ->
+ match currentObject#parent with
+ [ None -> failwith "Object not connected to target"
+ | Some cp -> loop cp#asDisplayObject
+ ]
+ ]
+ in
+ let move_up obj =
+ let matrix = Matrix.create () in
+ (
+ loop obj where
+ rec loop currentObject =
+ match currentObject = commonParent with
+ [ True -> ()
+ | False ->
+ (
+ Matrix.concat matrix currentObject#transformationMatrix;
+ match currentObject#parent with
+ [ Some p -> loop p#asDisplayObject
+ | None -> assert False
+ ]
+ )
+ ];
+ matrix;
+ )
+ in
+ (* 2.: Move up from self to common parent *)
+ let selfMatrix = move_up self#asDisplayObject
+ (* 3.: Move up from target to common parent *)
+ and targetMatrix = move_up targetCoordinateSpace
+ in
+ (
+ (* 4.: Combine the two matrices *)
+ Matrix.invert targetMatrix;
+ Matrix.concat selfMatrix targetMatrix;
+ selfMatrix;
+ )
+ ]
+ ]
+ ];(*}}}*)
+
+ method virtual render: unit -> unit;
+
+ method private upcast = (self :> _c _ _ _);
+ method private bubbleEvent event =
+ match parent with
+ [ Some p ->
+ let event = {(event) with Event.target = Some self#asDisplayObject; currentTarget = None } in
+ p#dispatchEvent' event
+ | None -> ()
+ ];
+
+
+ (*
+ type 'event = Event.t 'event_type 'event_data 'displayObject 'self;
+ value listeners: Hashtbl.t 'event_type 'listener = Hashtbl.create 0;
+ method hasEventListeners eventType = Hashtbl.mem listeners eventType;
+ method private dispatchEvent' event =
+ let listeners =
+ try
+ let listeners = Hashtbl.find_all listeners event.Event.etype in
+ Some listeners
+ with [ Not_found -> None ]
+ in
+ match (event.Event.bubbles,listeners) with
+ [ (False,None) -> ()
+ | (_,lstnrs) ->
+ (
+ match lstnrs with
+ [ Some listeners ->
+(* let event = {(event) with Event.currentTarget = Some self } in *)
+ ignore(
+ List.for_all begin fun l ->
+ (
+ l event;
+ event.Event.stopImmediatePropagation;
+ )
+ end listeners
+ )
+ | None -> ()
+ ];
+ (*
+ match event.Event.bubbles && not event.Event.stopPropagation with
+ [ True -> self#bubbleEvent event
+ | False -> ()
+ ]
+ *)
+ )
+ ];
+
+ method dispatchEvent (event:'event) =
+ let event = {(event) with Event.target = Some self#asDisplayObject} in
+ self#dispatchEvent' event;
+ *)
+
+
+ method hitTestPoint localPoint isTouch =
+(* let () = Printf.printf "hitTestPoint: %s, %s - %s\n" name (Point.to_string localPoint) (Rectangle.to_string (self#boundsInSpace (Some self#asDisplayObject))) in *)
+ (* on a touch test, invisible or untouchable objects cause the test to fail *)
+ match (isTouch && (not visible || not touchable)) with
+ [ True -> None
+ | False ->
+ match Rectangle.containsPoint (self#boundsInSpace (Some self#asDisplayObject)) localPoint with
+ [ True -> Some self#asDisplayObject
+ | False -> None
+ ]
+ ];
+
+ method removeFromParent () =
+ match parent with
+ [ Some parent -> parent#removeChild' self#asDisplayObject
+ | None -> ()
+ ];
+
+(* method dispatchEventOnChildren event = self#dispatchEvent event; *)
+
+ method localToGlobal localPoint =
+ (* move up until parent is nil *)
+ let matrix = Matrix.create () in
+ (
+ loop self#asDisplayObject where
+ rec loop currentObject =
+ (
+ Matrix.concat matrix currentObject#transformationMatrix;
+ match currentObject#parent with
+ [ None -> ()
+ | Some p -> loop p#asDisplayObject
+ ]
+ );
+ Matrix.transformPoint matrix localPoint;
+ );
+
+
+ method globalToLocal globalPoint =
+ (* move up until parent is nil, then invert matrix *)
+ let matrix = Matrix.create () in
+ (
+ loop self#asDisplayObject where
+ rec loop currentObject =
+ (
+ Matrix.concat matrix currentObject#transformationMatrix;
+ match currentObject#parent with
+ [ None -> ()
+ | Some p -> loop p#asDisplayObject
+ ]
+ );
+ Matrix.invert matrix;
+ Matrix.transformPoint matrix globalPoint;
+ );
+
+ end;(*}}}*)
+
+exception Invalid_index;
+exception Child_not_found;
+
+(* Dll additional functions {{{*)
+value dllist_find node el =
+ match Dllist.get node = el with
+ [ True -> node
+ | False ->
+ let rec loop n =
+ if n != node
+ then
+ match Dllist.get n = el with
+ [ True -> n
+ | False -> loop (Dllist.next n)
+ ]
+ else raise Not_found
+ in
+ loop (Dllist.next node)
+ ];
+
+value dllist_existsf f node =
+ match f (Dllist.get node) with
+ [ True -> True
+ | False ->
+ let rec loop n =
+ if n != node
+ then
+ match f (Dllist.get n) with
+ [ True -> True
+ | False -> loop (Dllist.next n)
+ ]
+ else
+ False
+ in
+ loop (Dllist.next node)
+ ];
+
+value dllist_find_map f node =
+ match f (Dllist.get node) with
+ [ Some r -> r
+ | None ->
+ let rec loop n =
+ if n != node
+ then
+ match f (Dllist.get n) with
+ [ Some r -> r
+ | None -> loop (Dllist.next n)
+ ]
+ else raise Not_found
+ in
+ loop (Dllist.next node)
+ ];
+
+
+value dllist_find_map_back f node =
+ let node = Dllist.prev node in
+ match f (Dllist.get node) with
+ [ Some r -> r
+ | None ->
+ let rec loop n =
+ if n != node
+ then
+ match f (Dllist.get n) with
+ [ Some r -> r
+ | None -> loop (Dllist.prev n)
+ ]
+ else raise Not_found
+ in
+ loop (Dllist.prev node)
+ ];
+
+(*}}}*)
+
+
+class virtual container [ 'event_type, 'event_data ] = (*{{{*)
+ object(self:'self)
+ inherit _c [ 'event_type, 'event_data , container 'event_type 'event_data ] as super;
+ type 'displayObject = _c 'event_type 'event_data (container 'event_type 'event_data);
+ type 'displayObjectContainer = container 'event_type 'event_data;
+ (* пока на листах, потом видно будет *)
+ value mutable children : option (Dllist.node_t 'displayObject) = None;
+ value mutable numChildren = 0;
+ method children = match children with [ None -> Enum.empty () | Some children -> Dllist.enum children];
+ method numChildren = numChildren;
+ method asDisplayObjectContainer = (self :> container 'event_type 'event_data);
+ method dcast = `Container self#asDisplayObjectContainer;
+
+ method dispatchEventOnChildren event =
+ let rec loop obj =
+ let res = Enum.empty () in
+ (
+ if obj#hasEventListeners event.Event.etype then Enum.push res obj else ();
+ match obj#dcast with
+ [ `Container cont ->
+ Enum.fold begin fun child res ->
+ Enum.append res (loop child)
+ end res cont#children
+ | _ -> res
+ ]
+ )
+ in
+ let listeners = loop self#asDisplayObject in
+(* let event = (event :> Event.t 'event_type 'event_data 'displayObject) in *)
+ match Enum.is_empty listeners with
+ [ True -> ()
+ | False -> Enum.iter (fun listener -> listener#dispatchEvent event) listeners
+ ];
+
+
+ method addChild: !'child. ?index:int -> ((#_c 'event_type 'event_data 'dislpayObjectContainer) as 'child) -> unit = fun ?index child ->
+ let child = child#asDisplayObject in
+ (
+ match children with
+ [ None ->
+ match index with
+ [ Some idx when idx > 0 -> raise Invalid_index
+ | _ -> ( child#removeFromParent(); children := Some (Dllist.create child))
+ ]
+ | Some chldrn ->
+ match index with
+ [ None -> (* добавить с канец *) (child#removeFromParent(); Dllist.add (Dllist.prev chldrn) child )
+ | Some idx when idx > 0 && idx < numChildren -> (child#removeFromParent(); Dllist.add (Dllist.skip chldrn (idx-1)) child)
+ | Some idx when idx = 0 -> (child#removeFromParent(); children := Some (Dllist.prepend chldrn child))
+ | Some idx when idx = numChildren -> (child#removeFromParent(); Dllist.add (Dllist.prev chldrn) child)
+ | _ -> raise Invalid_index
+ ]
+ ];
+ numChildren := numChildren + 1;
+ child#setParent self#asDisplayObjectContainer;
+ let event = Event.create `ADDED () in
+ child#dispatchEvent event;
+ match self#stage with
+ [ Some _ ->
+ let event = Event.create `ADDED_TO_STAGE () in
+ match child#dcast with
+ [ `Container cont -> cont#dispatchEventOnChildren event
+ | `Object _ -> child#dispatchEvent event
+ ]
+ | None -> ()
+ ]
+ );
+
+ method getChildAt index =
+ match children with
+ [ None -> raise Invalid_index
+ | Some children ->
+ match index >= 0 && index < numChildren with
+ [ True -> Dllist.get (Dllist.skip children index)
+ | False -> raise Invalid_index
+ ]
+ ];
+
+ method getLastChild =
+ match children with
+ [ None -> raise Invalid_index
+ | Some children -> Dllist.get (Dllist.prev children)
+ ];
+
+ (* FIXME: защиту от зацикливаний бы поставить нах *)
+ method private removeChild'' child_node =
+ let child = Dllist.get child_node in
+ (
+ let event = Event.create `REMOVED () in
+ child#dispatchEvent event;
+ match self#stage with
+ [ Some _ ->
+ let event = Event.create `REMOVED_FROM_STAGE () in
+ match child#dcast with
+ [ `Container cont -> cont#dispatchEventOnChildren event
+ | `Object _ -> child#dispatchEvent event
+ ]
+ | None -> ()
+ ];
+ child#clearParent();
+ match children with
+ [ Some chldrn ->
+ if chldrn == child_node
+ then
+ match Dllist.next child_node == chldrn with
+ [ True -> children := None
+ | False -> children := Some (Dllist.drop child_node)
+ ]
+ else
+ Dllist.remove child_node
+ | None -> assert False
+ ];
+ numChildren := numChildren - 1;
+ );
+
+ method removeChild' child =
+ match children with
+ [ None -> raise Child_not_found
+ | Some children ->
+ let n = try dllist_find children child with [ Not_found -> raise Child_not_found ] in
+ self#removeChild'' n
+ ];
+
+ method removeChild: !'child. ((#_c 'event_type 'event_data 'displayObjectContainer) as 'child) -> unit = fun child -> (* чекать сцука надо блядь *)
+ let child = child#asDisplayObject in
+ self#removeChild' child;
+
+ method removeChildAtIndex index =
+ match children with
+ [ None -> raise Invalid_index
+ | Some children ->
+ match index >= 0 && index < numChildren with
+ [ True ->
+ let n = Dllist.skip children index in
+ self#removeChild'' n
+ | False -> raise Invalid_index
+ ]
+ ];
+
+ method containsChild' child =
+ match children with
+ [ None -> False
+ | Some children ->
+ dllist_existsf begin fun chld ->
+ match chld = child with
+ [ True -> True
+ | False ->
+ match chld#dcast with
+ [ `Container container -> container#containsChild' child
+ | _ -> False
+ ]
+ ]
+ end children
+ ];
+
+ method containsChild: !'child. ((#_c 'event_type 'event_data 'displayObjectContainer) as 'child) -> bool = fun child ->
+ let child = child#asDisplayObject in
+ self#containsChild' child;
+
+ method boundsInSpace targetCoordinateSpace =
+ match children with
+ [ None -> Rectangle.create 0. 0. 0. 0.
+ | Some children when children == (Dllist.next children) (* 1 child *) -> (Dllist.get children)#boundsInSpace targetCoordinateSpace
+ | Some children ->
+ let (minX,maxX,minY,maxY) =
+ let open Rectangle in
+ Dllist.fold_left begin fun (minX,maxX,minY,maxY) child ->
+ let childBounds = child#boundsInSpace targetCoordinateSpace in
+ (
+ min minX childBounds.x,
+ max maxX (childBounds.x +. childBounds.width),
+ min minY childBounds.y,
+ max maxY (childBounds.y +. childBounds.height)
+ )
+ end (max_float,~-.max_float,max_float,~-.max_float) children
+ in
+ Rectangle.create minX minY (maxX -. minX) (maxY -. minY)
+ ];
+
+ method! hitTestPoint localPoint isTouch =
+ match isTouch && (not visible || not touchable) with
+ [ True -> None
+ | False -> (* бля это правда важно с конца сцука нахуй *)
+ match children with
+ [ None -> None
+ | Some children ->
+ try
+ let res =
+ dllist_find_map_back begin fun child ->
+ let transformationMatrix = self#transformationMatrixToSpace (Some child) in
+ let transformedPoint = Matrix.transformPoint transformationMatrix localPoint in
+ child#hitTestPoint transformedPoint isTouch
+ end children
+ in
+ Some res
+ with [ Not_found -> None ]
+ ]
+ ];
+
+ method render () = (* А здесь нужно наоборот сцука *)
+ match children with
+ [ None -> ()
+ | Some children ->
+ Dllist.iter begin fun child ->
+ let childAlpha = child#alpha in
+ if (childAlpha > 0.0 && child#visible)
+ then
+ (
+ glPushMatrix();
+ RenderSupport.transformMatrixForObject child;
+ child#setAlpha (childAlpha *. alpha);
+ child#render ();
+ glPopMatrix();
+ )
+ else ()
+ end children
+ ];
+ end;(*}}}*)
+
+
+
+class virtual c [ 'event_type, 'event_data ] =
+ object(self)
+ inherit _c [ 'event_type, 'event_data, (container 'event_type 'event_data) ];
+ method dcast = `Object self#asDisplayObject;
+ end;
102 src/DisplayObject.mli
@@ -0,0 +1,102 @@
+
+
+type eventType = [= `ADDED | `ADDED_TO_STAGE | `REMOVED | `REMOVED_FROM_STAGE ];
+
+type hidden 'a;
+
+class virtual _c [ 'event_type, 'event_data, 'parent ] :
+ object
+ type 'event_type = [> eventType ];
+ type 'parent = < asDisplayObject: _c _ _ _; removeChild': _c _ _ _ -> unit; dispatchEvent': Event.t 'event_type 'event_data _ _ -> unit; name: string; .. >;
+ inherit EventDispatcher.c [ 'event_type, 'event_data , _c _ _ _];
+
+ method private upcast: _c _ _ _;
+ method private bubbleEvent: _;
+
+ value name: string;
+ method name: string;
+ method setName: string -> unit;
+ value x:float;
+ method x: float;
+ method setX: float -> unit;
+ value y:float;
+ method y: float;
+ method setY: float -> unit;
+ method setPos: Point.t -> unit;
+ method width: float;
+ method setWidth: float -> unit;
+ method height: float;
+ method setHeight: float -> unit;
+ value scaleX:float;
+ method scaleX: float;
+ method setScaleX: float -> unit;
+ value scaleY:float;
+ method scaleY: float;
+ method setScaleY: float -> unit;
+ method setScale: float -> unit;
+ value alpha:float;
+ method alpha: float;
+ method setAlpha: float -> unit;
+ method rotation: float;
+ method setRotation: float -> unit;
+ method setAlpha: float -> unit;
+ value visible: bool;
+ method visible: bool;
+ method setVisible: bool -> unit;
+ value touchable: bool;
+ method touchable: bool;
+ method setTouchable: bool -> unit;
+ value parent: option 'parent;
+ method parent: option 'parent;
+ method removeFromParent: unit -> unit;
+ method hitTestPoint: Point.t -> bool -> option (_c _ _ _ );
+ method bounds: Rectangle.t;
+ method transformationMatrix: Matrix.t;
+ method transformationMatrixToSpace: option (_c _ _ _) -> Matrix.t;
+ method virtual boundsInSpace: option (_c _ _ _) -> Rectangle.t;
+ method globalToLocal: Point.t -> Point.t;
+ method localToGlobal: Point.t -> Point.t;
+ method virtual render: unit -> unit;
+ method asDisplayObject: _c _ _ _;
+ method virtual dcast: [= `Object of _c _ _ _ | `Container of 'parent ];
+ method root: _c _ _ _;
+ (* need to be hidden *)
+ method clearParent: hidden unit -> unit;
+ method isStage: bool;
+ method setParent: hidden 'parent -> unit;
+ method stage: option (_c _ _ _);
+ end;
+
+
+class virtual container [ 'event_type, 'event_data ]:
+ object
+ inherit _c [ 'event_type, 'event_data, (container 'event_type 'event_data)];
+ type 'displayObjectContainer = container 'event_type 'event_data;
+ type 'displayObject = _c 'event_type 'event_data 'displayObjectContainer;
+
+ method dcast: [= `Object of 'displayObject | `Container of 'displayObjectContainer ];
+
+ method asDisplayObjectContainer: 'displayObjectContainer;
+ method children: Enum.t 'displayObject;
+ method addChild: !'child. ?index:int -> (#_c 'event_type 'event_data (container 'event_type 'event_data) as 'child) -> unit;
+ method containsChild: !'child. (#_c 'event_type 'event_data (container 'event_type 'event_data) as 'child) -> bool;
+ method getChildAt: int -> 'displayObject;
+ method getLastChild: 'displayObject;
+ method numChildren: int;
+ method removeChild: !'child. (#_c 'event_type 'event_data (container 'event_type 'event_data) as 'child) -> unit;
+ method removeChildAtIndex: int -> unit;
+ (* need to be hidden *)
+ method removeChild': 'displayObject -> unit;
+ method containsChild': 'displayObject -> bool;
+ method dispatchEventOnChildren: Event.t 'event_type 'event_data 'displayObject 'displayObject -> unit;
+ method boundsInSpace: option 'displayObject -> Rectangle.t;
+ method render: unit -> unit;
+ end;
+
+
+class virtual c [ 'event_type, 'event_data ]:
+ object
+ inherit _c [ 'event_type, 'event_data, (container 'event_type 'event_data) ];
+ method dcast: [= `Object of c _ _ | `Container of container _ _ ];
+ end;
+
79 src/DisplayObjectT.ml
@@ -0,0 +1,79 @@
+
+type eventType = [= `ADDED | `ADDED_TO_STAGE | `REMOVED | `REMOVED_FROM_STAGE ];
+
+class type virtual base [ 'event_type, 'event_data, 'parent, 'super ] =
+ object
+ type 'event_type = [> eventType ];
+ type 'parent = < asDisplayObject: base _ _ _ _; removeChild': base _ _ _ _ -> unit; .. >;
+ inherit EventDispatcher.c [ 'event_type, 'event_data ];
+ method name: string;
+ method setName: string -> unit;
+ method x: float;
+ method setX: float -> unit;
+ method y: float;
+ method setY: float -> unit;
+ method setPos: Point.t -> unit;
+ method width: float;
+ method setWidth: float -> unit;
+ method height: float;
+ method setHeight: float -> unit;
+ method scaleX: float;
+ method setScaleX: float -> unit;
+ method scaleY: float;
+ method setScaleY: float -> unit;
+ method setScale: float -> unit;
+ method alpha: float;
+ method setAlpha: float -> unit;
+ method rotation: float;
+ method setRotation: float -> unit;
+ method setAlpha: float -> unit;
+ method visible: bool;
+ method setVisible: bool -> unit;
+ method touchable: bool;
+ method setTouchable: bool -> unit;
+ method parent: option 'parent;
+ method removeFromParent: unit -> unit;
+ method hitTestPoint: Point.t -> bool -> option (base _ _ _ _);
+ method bounds: Rectangle.t;
+ method transformationMatrix: Matrix.t;
+ method transformationMatrixToSpace: option (base _ _ _ _) -> Matrix.t;
+ method virtual boundsInSpace: option (base _ _ _ _) -> Rectangle.t;
+ method globalToLocal: Point.t -> Point.t;
+ method localToGlobal: Point.t -> Point.t;
+ method virtual render: unit -> unit;
+ method asDisplayObject: base _ _ _ _;
+ method virtual supers: list 'super;
+ method virtual dcast: [= `Object of base _ _ _ _ | `Container of 'parent ];
+ method root: base _ _ _ _;
+ (* need to be hidden *)
+ method clearParent: unit -> unit;
+ method isStage: bool;
+ method setParent: 'parent -> unit;
+ method stage: option (base _ _ _ _);
+ (*
+ *)
+ end;
+
+
+class type virtual container [ 'event_type, 'event_data, 'super ] =
+ object
+ inherit base [ 'event_type, 'event_data, (container 'event_type 'event_data 'super), 'super];
+ type 'displayObjectContainer = container 'event_type 'event_data 'super;
+ type 'displayObject = base 'event_type 'event_data 'displayObjectContainer 'super;
+ type 'super = [> `Object of 'displayObject | `Container of 'displayObjectContainer ];
+
+ method asDisplayObjectContainer: 'displayObjectContainer;
+ method children: Enum.t 'displayObject;
+ method addChild: !'child. ?index:int -> (#base 'event_type 'event_data (container 'event_type 'event_data 'super) 'super as 'child) -> unit;
+ method containsChild: !'child. (#base 'event_type 'event_data (container 'event_type 'event_data 'super) 'super as 'child) -> bool;
+ method getChildAt: int -> 'displayObject;
+ method getLastChild: 'displayObject;
+ method numChildren: int;
+ method removeChild: !'child. (#base 'event_type 'event_data (container 'event_type 'event_data 'super) 'super as 'child) -> unit;
+ method removeChildAtIndex: int -> unit;
+ method dispatchEventOnChildren: Event.t 'event_type 'event_data 'displayObject -> unit;
+ method removeChild': 'displayObject -> unit;
+
+ method containsChild': 'displayObject -> bool;
+
+ end;
20 src/Event.ml
@@ -0,0 +1,20 @@
+
+type dataEmpty = [= `Empty ];
+
+type t 'etype 'data 'target 'current_target =
+ {
+ etype:'etype ;
+ stopImmediatePropagation:mutable bool;
+ stopPropagation:mutable bool;
+ bubbles:bool;
+(* eventPhase: [= `AT_TARGET | `BUBBLING_PHASE ]; *)
+ target: option 'target;
+ currentTarget: option 'current_target;
+ data:'data;
+ } constraint 'eype = [> ] constraint 'data = [> dataEmpty ] constraint 'target = < .. > constraint 'current_target = < .. >;
+
+value create etype ?(bubbles=False) ?(data=`Empty) () =
+ {
+ etype; stopImmediatePropagation = False; stopPropagation = False; bubbles; data;
+ target = None; currentTarget = None
+ };
55 src/EventDispatcher.ml
@@ -0,0 +1,55 @@
+open Event;
+
+
+class virtual c [ 'event_type , 'event_data , 'target ] =
+ object(self:'self)
+ type 'target = #c 'event_type 'event_data _;
+ type 'event = Event.t 'event_type 'event_data 'target 'self;
+ type 'listener = 'event -> unit;
+ value listeners: Hashtbl.t 'event_type 'listener = Hashtbl.create 0;
+ method private virtual upcast: 'target;
+ method addEventListener eventType listener = Hashtbl.add listeners eventType listener;
+
+ (* не трогает target *)
+ method virtual private bubbleEvent: 'event -> unit;
+ method dispatchEvent' event =
+ let listeners =
+ try
+ let listeners = Hashtbl.find_all listeners event.etype in
+ Some listeners
+ with [ Not_found -> None ]
+ in
+ match (event.bubbles,listeners) with
+ [ (False,None) -> ()
+ | (_,lstnrs) ->
+ (
+ match lstnrs with
+ [ Some listeners ->
+ let event = {(event) with currentTarget = Some self } in
+ ignore(
+ List.for_all begin fun l ->
+ (
+ l event;
+ event.stopImmediatePropagation;
+ )
+ end listeners
+ )
+ | None -> ()
+ ];
+ match event.bubbles && not event.stopPropagation with
+ [ True -> self#bubbleEvent event
+ | False -> ()
+ ]
+ )
+ ];
+
+
+ (* всегда ставить таргет в себя и соответственно current_target *)
+ method dispatchEvent (event:'event) =
+ let event = {(event) with target = Some self#upcast} in
+ self#dispatchEvent' event;
+
+ method hasEventListeners eventType = Hashtbl.mem listeners eventType;
+
+ end;
+
169 src/GLTexture.ml
@@ -0,0 +1,169 @@
+open Gl;
+
+type textureFormat =
+ [ TextureFormatRGBA
+ | TextureFormatAlpha
+ | TextureFormatPvrtcRGB2
+ | TextureFormatPvrtcRGBA2
+ | TextureFormatPvrtcRGB4
+ | TextureFormatPvrtcRGBA4
+ | TextureFormat565
+ | TextureFormat5551
+ | TextureFormat4444
+ ];
+
+type textureInfo =
+ {
+ texFormat: textureFormat;
+ width: int;
+ height: int;
+ numMipmaps: int;
+ generateMipmaps: bool;
+ premultipliedAlpha:bool;
+ scale: float;
+ imgData: ubyte_array;
+ };
+
+
+type tinfo =
+ {
+ compressed: bool;
+ glTexType: int;
+ bitsPerPixel: int;
+ glTexFormat: int
+ };
+
+value create textureInfo =
+ let repeat = False in
+ let info =
+ let info =
+ {
+ compressed = False;
+ glTexType = gl_unsigned_byte;
+ bitsPerPixel = 8;
+ glTexFormat = gl_rgba
+ }
+ in
+ match textureInfo.texFormat with (*{{{*)
+ [ TextureFormatRGBA ->
+ {(info) with
+ bitsPerPixel = 8;
+ glTexFormat = gl_rgba
+ }
+ | TextureFormatAlpha ->
+ {(info) with
+ bitsPerPixel = 8;
+ glTexFormat = gl_alpha
+ }
+ | TextureFormatPvrtcRGBA2 ->
+ IFDEF GLES THEN
+ {(info) with
+ compressed = True;
+ bitsPerPixel = 2;
+ glTexFormat = gl_compressed_rgba_pvrtc_2bppv1_img
+ }
+ ELSE failwith "PVRTC not supported on this platform" END
+ | TextureFormatPvrtcRGB2 ->
+ IFDEF GLES THEN
+ {(info) with
+ compressed = True;
+ bitsPerPixel = 2;
+ glTexFormat = gl_compressed_rgb_pvrtc_2bppv1_img
+ }
+ ELSE failwith "PVRTC not supported on this platform" END
+ | TextureFormatPvrtcRGBA4 ->
+ IFDEF GLES THEN
+ {(info) with
+ compressed = True;
+ bitsPerPixel = 4;
+ glTexFormat = gl_compressed_rgba_pvrtc_4bppv1_img
+ }
+ ELSE failwith "PVRTC not supported on this platform" END
+ | TextureFormatPvrtcRGB4 ->
+ IFDEF GLES THEN
+ {(info) with
+ compressed = True;
+ bitsPerPixel = 4;
+ glTexFormat = gl_compressed_rgb_pvrtc_4bppv1_img
+ }
+ ELSE failwith "PVRTC not supported on this platform" END
+ | TextureFormat565 ->
+ {(info) with
+ bitsPerPixel = 16;
+ glTexFormat = gl_rgb;
+ glTexType = gl_unsigned_short_5_6_5
+ }
+ | TextureFormat5551 ->
+ {(info) with
+ bitsPerPixel = 16;
+ glTexFormat = gl_rgba;
+ glTexType = gl_unsigned_short_5_5_5_1
+ }
+ | TextureFormat4444 ->
+ {(info) with
+ bitsPerPixel = 16;
+ glTexFormat = gl_rgba;
+ glTexType = gl_unsigned_short_4_4_4_4
+ }
+ ](*}}}*)
+ in
+ let texturesID = Array.make 1 0 in
+ (
+ glGenTextures 1 texturesID;
+ let textureID = texturesID.(0) in
+ (
+ glBindTexture gl_texture_2d textureID;
+ glTexParameteri gl_texture_2d gl_texture_mag_filter gl_linear;
+ glTexParameteri gl_texture_2d gl_texture_wrap_s (if repeat then gl_repeat else gl_clamp_to_edge);
+ glTexParameteri gl_texture_2d gl_texture_wrap_t (if repeat then gl_repeat else gl_clamp_to_edge);
+ match info.compressed with
+ [ False ->
+ (
+ if textureInfo.numMipmaps > 0 || textureInfo.generateMipmaps
+ then
+ glTexParameteri gl_texture_2d gl_texture_min_filter gl_linear_mipmap_nearest
+ else
+ glTexParameteri gl_texture_2d gl_texture_min_filter gl_linear;
+
+ if textureInfo.numMipmaps = 0 && textureInfo.generateMipmaps
+ then
+ glTexParameteri gl_texture_2d gl_generate_mipmap gl_true
+ else ();
+
+ let levelWidth = ref textureInfo.width and levelHeight = ref textureInfo.height and levelPtr = ref 0 in
+ for level = 0 to textureInfo.numMipmaps do
+ (
+ let size = !levelWidth * !levelHeight * info.bitsPerPixel / 8 in
+ (
+ let levelData = Bigarray.Array1.sub textureInfo.imgData !levelPtr size in
+ glTexImage2D gl_texture_2d level info.glTexFormat !levelWidth !levelHeight 0 info.glTexFormat info.glTexType levelData;
+ levelPtr.val := !levelPtr + size;
+ );
+ levelWidth.val := !levelWidth / 2;
+ levelHeight.val := !levelHeight / 2;
+ )
+ done
+ )
+ | True ->
+ (
+ (* 'generateMipmaps' not supported for compressed textures *)
+ glTexParameteri gl_texture_2d gl_texture_min_filter (if textureInfo.numMipmaps = 0 then gl_linear else gl_linear_mipmap_nearest);
+ let levelWidth = ref textureInfo.width and levelHeight = ref textureInfo.height and levelPtr = ref 0 in
+ for level = 0 to textureInfo.numMipmaps do
+ (
+ let size = max 32 (!levelWidth * !levelHeight * info.bitsPerPixel / 8) in
+ (
+ let levelData = Bigarray.Array1.sub textureInfo.imgData !levelPtr size in
+ glCompressedTexImage2D gl_texture_2d level info.glTexFormat !levelWidth !levelHeight 0 size levelData;
+ levelPtr.val := !levelPtr + size;
+ );
+ levelWidth.val := !levelWidth / 2;
+ levelHeight.val := !levelHeight / 2;
+ )
+ done
+ )
+ ];
+ glBindTexture gl_texture_2d 0;
+ textureID;
+ );
+ );
62 src/Image.ml
@@ -0,0 +1,62 @@
+open Gl;
+open LightCommon;
+
+value memo = ObjMemo.create 1;
+value gl_tex_coords = make_float_array 8;
+
+class c [ 'event_type, 'event_data ] texture =
+ object(self)
+ inherit Quad.c ['event_type,'event_data ] texture#width texture#height as super;
+ initializer ObjMemo.add memo (self :> < >);
+ value mutable texture: Texture.c = texture;
+ method texture = texture;
+ method setTexture nt = texture := nt;
+ value texCoords =
+ let res = Array.make 8 0. in
+ (
+ res.(2) := 1.0; res.(5) := 1.0;
+ res.(6) := 1.0; res.(7) := 1.0;
+ res
+ );
+ method virtual copyTexCoords: Bigarray.Array1.t float Bigarray.float32_elt Bigarray.c_layout -> unit;
+ method copyTexCoords dest = Array.iteri (fun i a -> Bigarray.Array1.unsafe_set dest i a) texCoords;
+
+ method! render () =
+ (
+ RenderSupport.bindTexture texture;
+(*
+ for i = 0 to 3 do
+ RenderSupport.convertColors vertexColors.(i) alpha (Bigarray.Array1.sub Quad.gl_quad_colors (i*4) 4);
+ done;
+*)
+ let alphaBits = Int32.shift_left (Int32.of_float (alpha *. 255.)) 24 in
+ Array.iteri (fun i c -> Quad.gl_quad_colors.{i} := Int32.logor (Int32.of_int c) alphaBits) vertexColors;
+ Array.iteri (fun i a -> Bigarray.Array1.unsafe_set gl_tex_coords i a) texCoords;
+ texture#adjustTextureCoordinates gl_tex_coords;
+ glEnableClientState gl_texture_coord_array;
+ glEnableClientState gl_vertex_array;
+ glEnableClientState gl_color_array;
+ glTexCoordPointer 2 gl_float 0 gl_tex_coords;
+ glVertexPointer 2 gl_float 0 vertexCoords;
+ glColorPointer 4 gl_unsigned_byte 0 Quad.gl_quad_colors;
+ glDrawArrays gl_triangle_strip 0 4;
+ glDisableClientState gl_texture_coord_array;
+ glDisableClientState gl_vertex_array;
+ glDisableClientState gl_color_array;
+ );
+
+ end;
+
+
+value cast: #DisplayObject.c 'event_type 'event_data -> option (c 'event_type 'event_data) =
+ fun q ->
+ match ObjMemo.mem memo (q :> < >) with
+ [ True -> Some ((Obj.magic q) : c 'event_type 'event_data)
+ | False -> None
+ ];
+
+value createFromFile path =
+ let texture = Texture.createFromFile path in
+ new c texture;
+
+value create = new c;
14 src/Image.mli
@@ -0,0 +1,14 @@
+
+
+class c ['event_type,'event_data ]: [ Texture.c ] ->
+ object
+ inherit Quad.c [ 'event_type, 'event_data ];
+ method copyTexCoords: Bigarray.Array1.t float Bigarray.float32_elt Bigarray.c_layout -> unit;
+ method texture: Texture.c;
+ method setTexture: Texture.c -> unit;
+ end;
+
+value cast: #DisplayObject.c 'event_type 'event_data -> option (c 'event_type 'event_data);
+
+value createFromFile: string -> c _ _;
+value create: Texture.c -> c _ _;
42 src/LightCommon.ml
@@ -0,0 +1,42 @@
+
+value color_white = 0xFFFFFF;
+value color_black = 0x000000;
+
+
+type halign = [= `HAlignLeft | `HAlignCenter | `HAlignRight ];
+type valign = [= `VAlignTop | `VAlignCenter | `VAlignBottom ];
+
+value pi = 3.14159265359;
+value two_pi = 6.28318530718;
+
+IFDEF IOS THEN
+external resource_path: string -> float -> string = "ml_resourcePath";
+ELSE
+value resource_path path scale =
+ match Filename.is_relative path with
+ [ True -> Filename.concat "Resources" path
+ | False -> path
+ ];
+ENDIF;
+
+exception Xml_attribute_not_found of string;
+value get_xml_attribute local_name attributes =
+ try
+ MList.find_map (fun ((_,ln),v) -> match ln = local_name with [ True -> Some v | False -> None ]) attributes;
+ with [ Not_found -> raise (Xml_attribute_not_found local_name) ];
+
+(* допилить пока так сойдет *)
+value parse_xml_element xmlinput tag_name attributes =
+ match Xmlm.input xmlinput with
+ [ `El_start ((_,tname),attrs) when tname = tag_name ->
+ let res =
+ List.map begin fun att_name ->
+ (att_name,get_xml_attribute att_name attrs)
+ end attributes
+ in
+ match Xmlm.input xmlinput with
+ [ `El_end -> res
+ | _ -> assert False
+ ]
+ | _ -> assert False
+ ];
28 src/Lightning.ml
@@ -0,0 +1,28 @@
+
+type stage_constructor =
+ float -> float ->
+ <
+ render: unit -> unit;
+ processTouches: list Touch.t -> unit;
+ advanceTime: float -> unit;
+ name: string;
+ >;
+
+(* value _stage: ref (option (float -> float -> stage eventTypeDisplayObject eventEmptyData)) = ref None; *)
+
+IFDEF SDL THEN
+value init s = Sdl_run.run s;
+ELSE
+value _stage : ref (option stage_constructor) = ref None;
+value init s = _stage.val := Some s;
+value stage_create width height =
+ match _stage.val with
+ [ None -> failwith "Stage not initialized"
+ | Some stage -> stage width height
+ ];
+value () =
+(
+(* Callback.register "clear_texture" RenderSupport.clearTexture; *)
+ Callback.register "stage_create" stage_create;
+);
+ENDIF;
77 src/MLDepend
@@ -0,0 +1,77 @@
+gl/es/gl.cmo: gl/es/gl.cmi
+gl/es/gl.cmx: gl/es/gl.cmi
+gl/es/gl.cmi:
+BitmapFont.cmo: Texture.cmi Sprite.cmi Rectangle.cmo Quad.cmi LightCommon.cmo \
+ Image.cmi CompiledSprite.cmo BitmapFont.cmi
+BitmapFont.cmx: Texture.cmx Sprite.cmx Rectangle.cmx Quad.cmx LightCommon.cmx \
+ Image.cmx CompiledSprite.cmx BitmapFont.cmi
+Button.cmo: Touch.cmo Texture.cmi TextField.cmi Sprite.cmi Rectangle.cmo \
+ Image.cmi Event.cmo DisplayObject.cmi
+Button.cmx: Touch.cmx Texture.cmx TextField.cmx Sprite.cmx Rectangle.cmx \
+ Image.cmx Event.cmx DisplayObject.cmx
+CompiledSprite.cmo: Sprite.cmi RenderSupport.cmo Quad.cmi Point.cmo \
+ Matrix.cmo Image.cmi gl/es/gl.cmi
+CompiledSprite.cmx: Sprite.cmx RenderSupport.cmx Quad.cmx Point.cmx \
+ Matrix.cmx Image.cmx gl/es/gl.cmx
+DisplayObject.cmo: RenderSupport.cmo Rectangle.cmo Matrix.cmo LightCommon.cmo \
+ gl/es/gl.cmi EventDispatcher.cmo Event.cmo DisplayObject.cmi
+DisplayObject.cmx: RenderSupport.cmx Rectangle.cmx Matrix.cmx LightCommon.cmx \
+ gl/es/gl.cmx EventDispatcher.cmx Event.cmx DisplayObject.cmi
+DisplayObjectT.cmo: Rectangle.cmo Point.cmo Matrix.cmo EventDispatcher.cmo \
+ Event.cmo
+DisplayObjectT.cmx: Rectangle.cmx Point.cmx Matrix.cmx EventDispatcher.cmx \
+ Event.cmx
+Event.cmo:
+Event.cmx:
+EventDispatcher.cmo: Event.cmo
+EventDispatcher.cmx: Event.cmx
+GLTexture.cmo: gl/es/gl.cmi
+GLTexture.cmx: gl/es/gl.cmx
+Image.cmo: Texture.cmi RenderSupport.cmo Quad.cmi ObjMemo.cmo LightCommon.cmo \
+ gl/es/gl.cmi DisplayObject.cmi Image.cmi
+Image.cmx: Texture.cmx RenderSupport.cmx Quad.cmx ObjMemo.cmx LightCommon.cmx \
+ gl/es/gl.cmx DisplayObject.cmx Image.cmi
+LightCommon.cmo: MList.cmo
+LightCommon.cmx: MList.cmx
+Lightning.cmo: Touch.cmo
+Lightning.cmx: Touch.cmx
+MList.cmo:
+MList.cmx:
+Matrix.cmo:
+Matrix.cmx:
+ObjMemo.cmo:
+ObjMemo.cmx:
+Point.cmo:
+Point.cmx:
+Quad.cmo: RenderSupport.cmo Rectangle.cmo ObjMemo.cmo Matrix.cmo \
+ LightCommon.cmo gl/es/gl.cmi DisplayObject.cmi Quad.cmi
+Quad.cmx: RenderSupport.cmx Rectangle.cmx ObjMemo.cmx Matrix.cmx \
+ LightCommon.cmx gl/es/gl.cmx DisplayObject.cmx Quad.cmi
+Rectangle.cmo:
+Rectangle.cmx:
+RenderSupport.cmo: LightCommon.cmo gl/es/gl.cmi
+RenderSupport.cmx: LightCommon.cmx gl/es/gl.cmx
+Sprite.cmo: DisplayObject.cmi Sprite.cmi
+Sprite.cmx: DisplayObject.cmx Sprite.cmi
+Stage.cmo: Touch.cmo RenderSupport.cmo Rectangle.cmo Event.cmo \
+ DisplayObject.cmi
+Stage.cmx: Touch.cmx RenderSupport.cmx Rectangle.cmx Event.cmx \
+ DisplayObject.cmx
+TextField.cmo: Rectangle.cmo Quad.cmi LightCommon.cmo DisplayObject.cmi \
+ BitmapFont.cmi TextField.cmi
+TextField.cmx: Rectangle.cmx Quad.cmx LightCommon.cmx DisplayObject.cmx \
+ BitmapFont.cmx TextField.cmi
+Texture.cmo: Rectangle.cmo gl/es/gl.cmi GLTexture.cmo Texture.cmi
+Texture.cmx: Rectangle.cmx gl/es/gl.cmx GLTexture.cmx Texture.cmi
+TextureAtlas.cmo: Texture.cmi Rectangle.cmo LightCommon.cmo
+TextureAtlas.cmx: Texture.cmx Rectangle.cmx LightCommon.cmx
+Touch.cmo: DisplayObject.cmi
+Touch.cmx: DisplayObject.cmx
+BitmapFont.cmi: LightCommon.cmo CompiledSprite.cmo
+DisplayObject.cmi: Rectangle.cmo Point.cmo Matrix.cmo EventDispatcher.cmo \
+ Event.cmo
+Image.cmi: Texture.cmi Quad.cmi DisplayObject.cmi
+Quad.cmi: Rectangle.cmo DisplayObject.cmi
+Sprite.cmi: DisplayObject.cmi
+TextField.cmi: Rectangle.cmo LightCommon.cmo DisplayObject.cmi
+Texture.cmi: Rectangle.cmo gl/es/gl.cmi
293 src/MList.ml
@@ -0,0 +1,293 @@
+open List;
+
+type mut_list 'a = {
+ hd: 'a;
+ tl: mutable list 'a
+};
+
+external inj : mut_list 'a -> list 'a = "%identity";
+value dummy_node () = { hd = Obj.magic (); tl = [] };
+
+value rec find_map f = fun
+ [ [] -> raise Not_found
+ | [ x :: xs ] ->
+ match f x with
+ [ Some y -> y
+ | None -> find_map f xs
+ ]
+ ];
+
+value remove_exn l x =
+ let rec loop dst = fun
+ [ [] -> raise Not_found
+ | [ h :: t ] ->
+ if x = h
+ then dst.tl := t
+ else
+ let r = { hd = h; tl = [] } in
+ (
+ dst.tl := inj r;
+ loop r t
+ )
+ ]
+ in
+ let dummy = dummy_node () in
+ (
+ loop dummy l;
+ dummy.tl
+ );
+
+
+value map2_1 f l1 l2 =
+ let rec loop dst src1 src2 =
+ match (src1, src2) with
+ [ ([], []) -> ()
+ | ( [ h1 :: t1 ] , [ h2 :: t2 ] ) ->
+ let r = { hd = f h1 h2; tl = [] } in
+ (
+ dst.tl := inj r;
+ loop r t1 t2
+ )
+ | _ -> ()
+ ]
+ in
+ let dummy = dummy_node () in
+ (
+ loop dummy l1 l2;
+ dummy.tl
+ );
+
+
+value remove_if_exn f l =
+ let rec loop dst = fun
+ [ [] -> raise Not_found
+ | [ h :: t ] ->
+ if f h
+ then dst.tl := t
+ else
+ let r = { hd = h; tl = [] } in
+ (
+ dst.tl := inj r;
+ loop r t
+ )
+ ]
+ in
+ let dummy = dummy_node () in
+ (
+ loop dummy l;
+ dummy.tl
+ );
+
+
+value pop_assoc x lst =
+ let rec loop dst = fun
+ [ [] -> raise Not_found
+ | [ ((a,v) as pair) :: t ] ->
+ if a = x
+ then
+ (
+ dst.tl := t;
+ v
+ )
+ else
+ let r = { hd = pair; tl = [] } in
+ (
+ dst.tl := inj r;
+ loop r t
+ )
+ ]
+ in
+ let dummy = dummy_node () in
+ (
+ let v = loop dummy lst in
+ (v,dummy.tl);
+ );
+
+
+value pop_if f lst =
+ let rec loop dst = fun
+ [ [] -> raise Not_found
+ | [ v :: t ] ->
+ if f v
+ then
+ (
+ dst.tl := t;
+ v
+ )
+ else
+ let r = { hd = v; tl = [] } in
+ (
+ dst.tl := inj r;
+ loop r t
+ )
+ ]
+ in
+ let dummy = dummy_node () in
+ (
+ let v = loop dummy lst in
+ (v,dummy.tl);
+ );
+
+
+value replace_assoc k v lst =
+ let r = { hd = (k,v); tl = [] } in
+ let rec loop dst = fun
+ [ [] -> dst.tl := inj r
+ | [ (k',_) :: tl ] when k' = k ->
+ (
+ r.tl := tl;
+ dst.tl := inj r;
+ )
+ | [ h :: tl ] ->
+ let r = { hd = h; tl = [] } in
+ (
+ dst.tl := inj r;
+ loop r tl
+ )
+ ]
+ in
+ let dummy = dummy_node () in
+ (
+ loop dummy lst;
+ dummy.tl;
+ );
+
+
+
+(* requires HSet
+
+(* возвращает элементы первого списка, которых нет во вотором *)
+value diff l1 l2 =
+ if l1 = [] || l2 = []
+ then l1
+ else
+ let hs = HSet.create (List.length l2) in
+ (
+ iter (fun el -> HSet.add hs el) l2;
+ fold_left (fun res el -> try HSet.remove_exn hs el; res with [ Not_found -> [ el :: res ]]) [] l1
+ );
+
+value _union minlen l1 l2 =
+ let hs = HSet.create minlen in
+ (
+ iter (fun el -> HSet.add hs el) l1;
+ fold_left (fun res el -> try HSet.remove_exn hs el; [ el :: res ] with [ Not_found -> res]) [] l2
+ );
+
+value union l1 l2 =
+ if l1 = [] || l2 = []
+ then []
+ else
+ let l1len = List.length l1
+ and l2len = List.length l2
+ in
+ match l1len < l2len with
+ [ True -> _union l1len l1 l2
+ | False -> _union l2len l2 l1
+ ];
+
+*)
+
+value full_uniq_diff l1 l2 =
+ let l2 = ref l2 in
+ let res =
+ fold_left (fun r e ->
+ try
+ l2.val := remove_exn !l2 e;
+ r
+ with [ Not_found -> [ e :: r] ]
+ ) [] l1
+ in
+ (!l2,res);
+
+value split3 lst =
+ let rec loop adst bdst cdst = fun
+ [ [] -> ()
+ | [ (a, b, c) :: t ] ->
+ let x = { hd = a; tl = [] }
+ and y = { hd = b; tl = [] }
+ and z = { hd = c; tl = [] } in
+ (
+ adst.tl := inj x;
+ bdst.tl := inj y;
+ cdst.tl := inj z;
+ loop x y z t
+ )
+ ]
+ in
+ let adummy = dummy_node ()
+ and bdummy = dummy_node ()
+ and