Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

many small fixes for 4.00

  • Loading branch information...
commit fab91d6216e35e180309d5d97ff7b5a5565cc100 1 parent bd5311f
@serp256 authored
Showing with 179 additions and 453 deletions.
  1. +1 −1  META.ios
  2. +1 −1  META.sdl
  3. +3 −2 Makefile.common
  4. +5 −5 config.ios
  5. +1 −25 ocamllibs/extlib-1.5.2/Makefile.ios
  6. +1 −1  ocamllibs/extlib-1.5.2/extHashtbl.mli
  7. +5 −3 ocamllibs/ojson/Makefile.in
  8. +2 −12 ocamllibs/xmlm-1.0.2/Makefile
  9. +7 −7 src/Atlas.ml
  10. +3 −0  src/BitmapFont.ml
  11. +1 −1  src/Debug.ml
  12. +10 −9 src/DisplayObject.ml
  13. +1 −1  src/DisplayObject.mli
  14. +1 −0  src/LightCommon.ml
  15. +9 −0 src/Lightning.ml
  16. +8 −0 src/Lightning.mli
  17. +7 −6 src/Tween.ml
  18. +7 −4 src/ios/LightViewController.m
  19. +10 −6 src/ios/mlwrapper_ios.m
  20. +4 −1 src/light_common.h
  21. +3 −4 src/render_stub.c
  22. +9 −2 src/texture_common.c
  23. +8 −30 test/LightTest.xcodeproj/project.pbxproj
  24. +1 −1  test/Makefile.common
  25. +7 −5 test/Makefile.in
  26. +4 −4 test/Makefile.ios
  27. +58 −5 test/example.ml
  28. +2 −10 test/testz.ml
  29. +0 −1  utils/respacker/TextureLayout.ml
  30. +0 −3  utils/respacker/_tags
  31. +0 −12 utils/respacker/build.sh
  32. +0 −291 utils/respacker/respacker.ml
View
2  META.ios
@@ -1,7 +1,7 @@
version="0.01"
archive(byte)="lightning.cma"
archive(native)="lightning.cmxa"
-requires="bigarray extlib xmlm dbm ojson"
+requires="bigarray extlib xmlm ojson"
package "tapjoy" (
description="Tapjoy Connect"
View
2  META.sdl
@@ -1,7 +1,7 @@
version="0.01"
archive(byte)="lightning.cma"
archive(native)="lightning.cmxa"
-requires="bigarray extlib xmlm dbm threads curl ojson"
+requires="bigarray extlib xmlm threads curl ojson"
package "tapjoy" (
description="Tapjoy Connect"
View
5 Makefile.common
@@ -1,7 +1,8 @@
MLPPOPT =
MLFLAGS = -package camlp4,camlp4.macro -syntax camlp4r
-MLCOMPFLAGS = -w +7+9@5@8-13 -warn-error +10 -g
+MLCOMPFLAGS = -w +7+9@5@8-13 -warn-error +10 -g
+MLNATFLAGS = -S
%.cmi: %.mli
ifneq (,$(findstring byte,$(LIB)))
@@ -14,4 +15,4 @@ endif
$(OCAMLC) $(MLFLAGS) $(MLCOMPFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) $(if $(DEBUGS),$(patsubst %,-ppopt -enable-debug -ppopt %,$(DEBUGS))) -c $<
%.cmx: %.ml
- $(OCAMLOPT) $(MLFLAGS) $(MLCOMPFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) $(if $(DEBUGS),$(patsubst %,-ppopt -enable-debug -ppopt %,$(DEBUGS))) -c $<
+ $(OCAMLOPT) $(MLFLAGS) $(MLNATFLAGS) $(MLCOMPFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) $(if $(DEBUGS),$(patsubst %,-ppopt -enable-debug -ppopt %,$(DEBUGS))) -c $<
View
10 config.ios
@@ -1,16 +1,16 @@
include myconfig.ios
export PLATFORM = IOS
SDK_VERSION ?= 5.1
-GCC ?= llvm-gcc
+GCC ?= gcc
ARCH ?= armv7
PLAT ?= /Applications/Xcode.app/Contents/Developer/Platforms/iPhoneOS.platform
SDK ?= /Developer/SDKs/iPhoneOS$(SDK_VERSION).sdk
-OCAMLDIR = /usr/local/ocaml/ios/3.12.1
-export OCAMLFIND ?= /opt/local/bin/ocamlfind -toolchain ios
+OCAMLDIR ?= /usr/local/ocaml/ios/3.12.1
+export OCAMLFIND ?= ocamlfind -toolchain ios
OCAMLBINDIR = $(OCAMLDIR)/bin/
export CC = $(PLAT)/Developer/usr/bin/$(GCC) -arch $(ARCH)
-export CFLAGS = -x objective-c -std=c99 -Wno-trigraphs -fpascal-strings -Os -Wreturn-type -Wunused-variable -isysroot $(PLAT)$(SDK) -isystem $(OCAMLDIR)/lib -DCAML_NAME_SPACE -fexceptions -miphoneos-version-min=4.2 -gdwarf-2 -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+export CFLAGS = -x objective-c -std=c99 -Wno-trigraphs -fpascal-strings -O0 -Wreturn-type -Wunused-variable -isysroot $(PLAT)$(SDK) -isystem $(OCAMLDIR)/lib -DCAML_NAME_SPACE -fexceptions -miphoneos-version-min=4.2 -gdwarf-2 -D_FILE_OFFSET_BITS=64 -D_REENTRANT
export OCAMLOPT = $(OCAMLFIND) ocamlopt
export OCAMLC = $(OCAMLFIND) ocamlc
-export OCAMLMKLIB = /usr/local/ocaml/ios/3.12.1/bin/ocamlmklib
+export OCAMLMKLIB = $(OCAMLDIR)/bin/ocamlmklib
LIB = native syntax
View
26 ocamllibs/extlib-1.5.2/Makefile.ios
@@ -1,27 +1,3 @@
-# Makefile contributed by Alain Frisch
-
-MODULES = \
- enum bitSet dynArray extArray extHashtbl extList extString global IO option \
- pMap std uChar uTF8 base64 unzip refList optParse dllist
-
-# the list is topologically sorted
-
-MLI = $(MODULES:=.mli)
-SRC = $(MLI) $(MODULES:=.ml) extLib.ml
-
OCAMLFIND=ocamlfind -toolchain ios
-OCAMLOPT=$(OCAMLFIND) ocamlopt
-OCAMLC=$(OCAMLFIND) ocamlc
-
-all:
- $(OCAMLC) -a -o extLib.cma $(SRC)
- $(OCAMLOPT) -a -o extLib.cmxa $(SRC)
-
-install:
- $(OCAMLFIND) install extlib META *.cma *.cmi $(MLI) $(wildcard *.cmxa) $(wildcard *.a)
-
-uninstall:
- $(OCAMLFIND) remove extlib
-clean:
- rm -f *.cmo *.cmx *.o *.cmi *.cma *.cmxa *.a
+include Makefile.in
View
2  ocamllibs/extlib-1.5.2/extHashtbl.mli
@@ -73,7 +73,7 @@ module Hashtbl :
functions. (note : functor support removed to avoid code
duplication). *)
- val create : int -> ('a, 'b) t
+ val create : ?random:bool -> int -> ('a, 'b) t
val clear : ('a, 'b) t -> unit
val add : ('a, 'b) t -> 'a -> 'b -> unit
val copy : ('a, 'b) t -> ('a, 'b) t
View
8 ocamllibs/ojson/Makefile.in
@@ -2,9 +2,6 @@
OCAMLOPT=$(OCAMLFIND) ocamlopt
OCAMLC=$(OCAMLFIND) ocamlc
-install:
- $(OCAMLFIND) install ojson META ojson.cmi ojson.cma ojson.cmxa ojson.mli ojson.a
-
byte:
$(OCAMLC) -c type.ml
$(OCAMLC) -c common.mli
@@ -27,6 +24,11 @@ native:
$(OCAMLOPT) -c ojson.ml
$(OCAMLOPT) -a type.cmx common.cmx read.cmx ojson.cmx -o ojson.cmxa
+install:
+ $(OCAMLFIND) install ojson META ojson.cmi ojson.cma ojson.cmxa ojson.mli ojson.a
+
+uninstall:
+ $(OCAMLFIND) remove ojson
clean:
rm -f *.cmo *.cmx *.cmxa *.a *.o *.cmi *.cma read.ml
View
14 ocamllibs/xmlm-1.0.2/Makefile
@@ -1,13 +1,3 @@
-OCAMLFIND=ocamlfind -toolchain ios
-OCAMLOPT=$(OCAMLFIND) ocamlopt
-
-all:
- $(OCAMLOPT) -c src/xmlm.mli
- $(OCAMLOPT) -c -annot -I src -I test -o src/xmlm.cmx src/xmlm.ml
-
-install:
- $(OCAMLFIND) install xmlm src/META src/xmlm.mli src/xmlm.cmi src/xmlm.cmx src/xmlm.o src/xmlm.annot
-
-uninstall:
- $(OCAMLFIND) remove xmlm
+OCAMLFIND = ocamlfind
+include Makefile.in
View
14 src/Atlas.ml
@@ -59,18 +59,18 @@ DEFINE RENDER_QUADS(program,transform,color,alpha) =
| Some index ->
try
DynArray.insert children index child
- with [ DynArray.Invalid_arg _ -> raise DisplayObject.Invalid_index ]
+ with [ DynArray.Invalid_arg _ -> raise (DisplayObject.Invalid_index (index,DynArray.length children))]
];
Node.bounds child |> ignore; (* force calc bounds *)
self#boundsChanged();
);
- method getChildAt idx = try DynArray.get children idx with [ DynArray.Invalid_arg _ -> raise DisplayObject.Invalid_index ];
+ method getChildAt idx = try DynArray.get children idx with [ DynArray.Invalid_arg _ -> raise (DisplayObject.Invalid_index (idx,DynArray.length children))];
method childIndex node =
try
DynArray.index_of (fun c -> c == node) children
- with [ Not_found -> raise DisplayObject.Invalid_index ];
+ with [ Not_found -> raise DisplayObject.Child_not_found ];
method removeChild node =
self#removeChildAt (self#childIndex node);
@@ -79,14 +79,14 @@ DEFINE RENDER_QUADS(program,transform,color,alpha) =
try
DynArray.delete children idx;
self#boundsChanged();
- with [ DynArray.Invalid_arg _ -> raise DisplayObject.Invalid_index ];
+ with [ DynArray.Invalid_arg _ -> raise (DisplayObject.Invalid_index (idx,DynArray.length children))];
method updateChild idx child =
(
assert(child.Node.texture = texture);
try
DynArray.set children idx child;
- with [ DynArray.Invalid_arg _ -> raise DisplayObject.Invalid_index ];
+ with [ DynArray.Invalid_arg _ -> raise (DisplayObject.Invalid_index (idx,DynArray.length children))];
Node.bounds child |> ignore; (* force calc bounds *)
self#boundsChanged();
);
@@ -112,10 +112,10 @@ DEFINE RENDER_QUADS(program,transform,color,alpha) =
DynArray.delete children idx;
DynArray.insert children nidx child;
)
- with [ DynArray.Invalid_arg _ -> raise DisplayObject.Invalid_index ];
+ with [ DynArray.Invalid_arg _ -> raise (DisplayObject.Invalid_index (idx,DynArray.length children))];
self#childrenDirty();
)
- else raise DisplayObject.Invalid_index;
+ else raise (DisplayObject.Invalid_index (nidx,DynArray.length children));
(* value mutable glowFilter = None; *)
View
3  src/BitmapFont.ml
@@ -138,9 +138,12 @@ value register xmlpath =
let () = XmlParser.accept (`Dtd None) in
let floats = XmlParser.floats in
let parse_pages () =
+ let () = debug "parse pages" in
match XmlParser.next () with
[ `El_start ((_,"Pages"),_) ->
+ let () = debug "this is pages" in
let rec loop res =
+ let () = debug "parse pages looop" in
match XmlParser.parse_element "page" [ "file"] with
[ Some [ file ] _ -> loop [ Texture.load ~with_suffix:False (Filename.concat dirname file) :: res ]
| None -> res
View
2  src/Debug.ml
@@ -40,7 +40,7 @@ value d_writer l =
]
in
fun addr s -> (Printf.eprintf "[DEBUG:%s(%s)] " l addr; prerr_endline s);
-value null_writer = (fun _ -> ());
+value null_writer = (fun _ _ -> ());
END;
View
19 src/DisplayObject.ml
@@ -8,7 +8,8 @@ value ev_ENTER_FRAME = Ev.gen_id "ENTER_FRAME";
type hidden 'a = 'a;
-exception Invalid_index;
+exception Invalid_index of (int*int);
+Printexc.register_printer (fun [ Invalid_index (c,n) -> Some (Printf.sprintf "DisplayObject.Invalid_index %d %d" c n) | _ -> None ]);
exception Child_not_found;
(* приходит массив точек, к ним применяется трасформация и в результате получаем min и максимальные координаты *)
@@ -774,7 +775,7 @@ class virtual container = (*{{{*)
match children with
[ None ->
match index with
- [ Some idx when idx > 0 -> raise Invalid_index
+ [ Some idx when idx > 0 -> raise (Invalid_index (idx,0))
| _ -> children := Some (Dllist.create child)
]
| Some chldrn ->
@@ -783,7 +784,7 @@ class virtual container = (*{{{*)
| Some idx when idx > 0 && idx < numChildren -> Dllist.add (Dllist.skip chldrn (idx-1)) child
| Some idx when idx = 0 -> children := Some (Dllist.prepend chldrn child)
| Some idx when idx = numChildren -> Dllist.add (Dllist.prev chldrn) child
- | _ -> raise Invalid_index
+ | Some idx -> raise (Invalid_index (idx,numChildren))
]
];
numChildren := numChildren + 1;
@@ -804,17 +805,17 @@ class virtual container = (*{{{*)
method getChildAt index =
match children with
- [ None -> raise Invalid_index
+ [ None -> raise (Invalid_index (index,0))
| Some children ->
match index >= 0 && index < numChildren with
[ True -> Dllist.get (Dllist.skip children index)
- | False -> raise Invalid_index
+ | False -> raise (Invalid_index (index,numChildren))
]
];
method getLastChild =
match children with
- [ None -> raise Invalid_index
+ [ None -> raise (Invalid_index (1,0))
| Some children -> Dllist.get (Dllist.prev children)
];
@@ -836,7 +837,7 @@ class virtual container = (*{{{*)
match children with
[ None -> raise Child_not_found
| Some chldrn ->
- if index >= numChildren || index < 0 then raise Invalid_index
+ if index >= numChildren || index < 0 then raise (Invalid_index (index,numChildren))
else
let () = debug:children "[%s] setChildIndex %s" self#name child#name in
let child = child#asDisplayObject in
@@ -951,13 +952,13 @@ class virtual container = (*{{{*)
method removeChildAtIndex index : 'displayObject =
match children with
- [ None -> raise Invalid_index
+ [ None -> raise (Invalid_index (index,0))
| Some children ->
match index >= 0 && index < numChildren with
[ True ->
let n = Dllist.skip children index in
self#removeChild'' n
- | False -> raise Invalid_index
+ | False -> raise (Invalid_index (index,numChildren))
]
];
View
2  src/DisplayObject.mli
@@ -9,7 +9,7 @@ value ev_ENTER_FRAME: Ev.id;
type hidden 'a;
-exception Invalid_index;
+exception Invalid_index of (int*int);
exception Child_not_found;
value dispatchEnterFrame: float -> unit;
View
1  src/LightCommon.ml
@@ -274,6 +274,7 @@ module MakeXmlParser(P:sig value path: string; value with_suffix: bool; end) = s
(* value get_attr name (tag_name,assoc) = try List.assoc name assoc with [ Not_found -> error "can't find attribute %s" name ]; *)
value parse_element tag_name attr_names =
+ let () = debug "Parse element %s" tag_name in
match Xmlm.input xmlinput with
[ `El_start ((_,tname),attributes) when tname = tag_name ->
let res = get_attributes tname attr_names attributes in
View
9 src/Lightning.ml
@@ -67,6 +67,15 @@ ENDIF;
external memUsage: unit -> int = "ml_memUsage";
+type malinfo =
+ {
+ malloc_total: int;
+ malloc_used: int;
+ malloc_free: int;
+ };
+
+external malinfo: unit -> malinfo = "ml_malinfo";
+
external setMaxGC: int64 -> unit = "ml_setMaxGC";
View
8 src/Lightning.mli
@@ -6,6 +6,14 @@ value openURL : string -> unit;
value sendEmail : string -> ~subject:string -> ?body:string -> unit -> unit;
external memUsage: unit -> int = "ml_memUsage";
external setMaxGC: int64 -> unit = "ml_setMaxGC";
+type malinfo =
+ {
+ malloc_total: int;
+ malloc_used: int;
+ malloc_free: int;
+ };
+
+external malinfo: unit -> malinfo = "ml_malinfo";
type remoteNotification = [= `RNBadge | `RNSound | `RNAlert ];
value request_remote_notifications: list remoteNotification -> (string -> unit) -> (string -> unit) -> unit;
View
13 src/Tween.ml
@@ -32,11 +32,11 @@ module Transitions = struct
(* value s = 1.70158; *)
- value easeInBack ratio = (ratio ** 2.0) *. (2.70158 *. ratio -. 1.70158);
+ value easeInBack ratio = (ratio *. ratio) *. (2.70158 *. ratio -. 1.70158);
value easeOutBack ratio =
let invRatio = ratio -. 1.0 in
- (invRatio ** 2.0) *. (2.70158 *. invRatio +. 1.70158) +. 1.0;
+ (invRatio *. invRatio) *. (2.70158 *. invRatio +. 1.70158) +. 1.0;
value easeInOutBack ratio =
if ratio < 0.5
@@ -80,20 +80,20 @@ module Transitions = struct
(* float p = 2.75f; *)
(* float l; *)
if ratio < 0.363636363636
- then 7.5625 *. (ratio ** 2.0)
+ then 7.5625 *. (ratio *. ratio)
else
if ratio < 0.727272727273
then
let ratio = ratio -. 0.545454545455 in
- 7.5625 *. (ratio ** 2.0) +. 0.75
+ 7.5625 *. (ratio *. ratio) +. 0.75
else
if ratio < 0.909090909091
then
let ratio = ratio -. 0.818181818182 in
- 7.5625 *. (ratio ** 2.0) +. 0.9375
+ 7.5625 *. (ratio *. ratio) +. 0.9375
else
let ratio = ratio -. 0.954545454545 in
- 7.5625 *. (ratio ** 2.0) +. 0.984375
+ 7.5625 *. (ratio *. ratio) +. 0.984375
;
value easeInBounce ratio = 1.0 -. (easeOutBounce (1.0 -. ratio));
@@ -196,6 +196,7 @@ class c ?(delay=0.) ?(repeat=(-1)) ?(transition=`linear) ?(loop=`LoopNone) time
];
let delta = action.endValue -. action.startValue in
let transitionValue = transition ratio in
+ let () = debug "ratio: %f, transitionValue: %f" ratio transitionValue in
(*
match invertTransition with
[ True -> 1. -. (transition (1. -. ratio))
View
11 src/ios/LightViewController.m
@@ -22,14 +22,17 @@ @implementation LightViewController
static LightViewController *instance = NULL;
-static void mlUncaughtException(const char* message) {
+static void mlUncaughtException(const char* exn, int bc, char** bv) {
+ // FIXME: address
NSString * to = @"nanofarm@redspell.ru";
NSString * subj = [NSString stringWithFormat:@"Сообщение об ошибке в игре '%@'", [[NSBundle mainBundle] objectForInfoDictionaryKey: @"CFBundleDisplayName"]];
UIDevice * dev = [UIDevice currentDevice];
NSString *appVersion = [[NSBundle mainBundle] objectForInfoDictionaryKey: @"CFBundleVersion"];
- // Fixme - localization here
- NSString * body = [NSString stringWithFormat:@"На моем %@ (iOS %@) ваше приложение (v%@) завершилось с ошибкой. Исправьте её как можно скорее. Спасибо!\n------------------------------------------------------\n%s", dev.model, dev.systemVersion, appVersion, message];
- //NSString *email = [NSString stringWithFormat:@"mailto:%@?subject=%@&body=%@", to, subj, [NSString stringWithCString:message encoding:NSUTF8StringEncoding]];
+ // FIXME: localization here
+ NSString * body = [NSString stringWithFormat:@"На моем %@ (iOS %@) ваше приложение (v%@) завершилось с ошибкой. Исправьте её как можно скорее. Спасибо!\n------------------------------------------------------\n%s\n", dev.model, dev.systemVersion, appVersion, exn];
+ for (int i = 0; i < bc; i++) {
+ if (bv[i]) body = [body stringByAppendingString:[NSString stringWithCString:bv[i] encoding:NSASCIIStringEncoding]];
+ };
NSString *email = [NSString stringWithFormat:@"mailto:%@?subject=%@&body=%@", to, subj, body];
email = [email stringByAddingPercentEscapesUsingEncoding:NSUTF8StringEncoding];
[[UIApplication sharedApplication] openURL:[NSURL URLWithString:email]];
View
16 src/ios/mlwrapper_ios.m
@@ -308,9 +308,13 @@ value ml_getDeviceType(value p) {
}
-
-
-
-
-
-
+#include <malloc/malloc.h>
+
+value ml_malinfo(value p) {
+ struct mstats s = mstats();
+ value res = caml_alloc_small(3,0);
+ Field(res,0) = Val_int(s.bytes_total);
+ Field(res,1) = Val_int(s.bytes_used);
+ Field(res,2) = Val_int(s.bytes_free);
+ return res;
+}
View
5 src/light_common.h
@@ -4,8 +4,11 @@
#define ERROR(fmt,args...) fprintf(stderr,fmt, ## args)
+
+#define DEBUGMSG(fmt,args...) (fprintf(stderr,"[DEBUG(%s:%d)] ",__FILE__,__LINE__),fprintf(stderr,fmt, ## args),putc('\n',stderr))
+
#ifdef LDEBUG
- #define PRINT_DEBUG(fmt,args...) (fprintf(stderr,"[DEBUG(%s:%d)] ",__FILE__,__LINE__),fprintf(stderr,fmt, ## args),putc('\n',stderr))
+ #define PRINT_DEBUG(fmt,args...) DEBUGMSG(fmt,## args)
#else
#define PRINT_DEBUG(fmt,args...)
#endif
View
7 src/render_stub.c
@@ -440,7 +440,6 @@ static value caml_hash_Color = 0;
static inline void extract_color(value color,GLfloat alpha,int pma,color4B *tl,color4B *tr,color4B *bl,color4B *br) {
if (Is_long(color)) { // white
- fprintf(stderr,"extrat_color: NoColor\n");
GLubyte a = 255 * alpha;
color4B clr;
if (pma) clr = (color4B){a,a,a,a};
@@ -451,12 +450,12 @@ static inline void extract_color(value color,GLfloat alpha,int pma,color4B *tl,c
if (Field(color,0) == caml_hash_Color) {
color4B clr;
int c = Long_val(Field(color,1));
- fprintf(stderr,"extract_color: Color - %x,%f\n",c,alpha);
+ //fprintf(stderr,"extract_color: Color - %x,%f\n",c,alpha);
if (pma) clr = COLOR_FROM_INT_PMA(c,alpha);
else clr = COLOR_FROM_INT(c,alpha);
*tl = *tr = *bl = *br = clr;
} else { // QColors
- fprintf(stderr,"extract_color: QColors\n");
+ //fprintf(stderr,"extract_color: QColors\n");
value qcolor = Field(color,1);
int c = Long_val(Field(qcolor,0));
*tl = pma ? COLOR_FROM_INT_PMA(c,alpha) : COLOR_FROM_INT(c,alpha);
@@ -1179,7 +1178,7 @@ void ml_atlas_render(value atlas, value matrix,value program, value alpha, value
double alpha;
int ic;
double quad[4];
- fprintf(stderr,"len of quads: %d\n",len);
+ //fprintf(stderr,"len of quads: %d\n",len);
for (i = 0; i < len; i++) {
child = Field(arr,i);
bounds = Field(child,1);
View
11 src/texture_common.c
@@ -12,6 +12,12 @@
static unsigned int total_tex_mem = 0;
+#ifdef DEBUG_MEM
+#define LOGMEM(op,size) DEBUGMSG("TEXTURE MEMORY <%s> %u -> %u",op,size,total_tex_mem)
+#else
+#define LOGMEM(op,size)
+#endif
+
#define TEX(v) ((struct tex*)Data_custom_val(v))
void ml_texture_id_delete(value textureID) {
@@ -22,6 +28,7 @@ void ml_texture_id_delete(value textureID) {
struct tex *t = TEX(textureID);
t->tid = 0;
total_tex_mem -= t->mem;
+ LOGMEM("delete",t->mem);
caml_free_dependent_memory(t->mem);
};
}
@@ -37,9 +44,9 @@ static void textureID_finalize(value textureID) {
glDeleteTextures(1,&tid);
struct tex *t = TEX(textureID);
total_tex_mem -= t->mem;
+ LOGMEM("finalize",t->mem);
caml_free_dependent_memory(t->mem);
};
- PRINT_DEBUG("TEXTURE MEMORY (dealloc): %d\n",total_tex_mem);
}
static int textureID_compare(value texid1,value texid2) {
@@ -64,7 +71,7 @@ struct custom_operations textureID_ops = {
#define Store_textureID(mltex,texID,dataLen) \
caml_alloc_dependent_memory(dataLen); \
mltex = caml_alloc_custom(&textureID_ops, sizeof(struct tex), dataLen, MAX_GC_MEM); \
- {struct tex *_tex = TEX(mltex); _tex->tid = texID; _tex->mem = dataLen; total_tex_mem += dataLen; PRINT_DEBUG("TEXTURE MEMORY (alloc %d): %d\n",dataLen,total_tex_mem);}
+ {struct tex *_tex = TEX(mltex); _tex->tid = texID; _tex->mem = dataLen; total_tex_mem += dataLen; LOGMEM("alloc",dataLen);}
//*TEXTURE_ID(mlTextureID) = tid;
value alloc_texture_id(GLuint textureID, unsigned int dataLen) {
View
38 test/LightTest.xcodeproj/project.pbxproj
@@ -49,26 +49,13 @@
/* Begin PBXFileReference section */
510C021214FE6C1200BDDCFC /* ra_fertilizer.caf */ = {isa = PBXFileReference; lastKnownFileType = file; name = ra_fertilizer.caf; path = ../../lightning/test/Resources/ra_fertilizer.caf; sourceTree = "<group>"; };
510C021514FE6ED800BDDCFC /* stoneBoom.caf */ = {isa = PBXFileReference; lastKnownFileType = file; name = stoneBoom.caf; path = ../../lightning/test/Resources/stoneBoom.caf; sourceTree = "<group>"; };
- 513AB2431513836200B4AF5C /* caf */ = {isa = PBXFileReference; lastKnownFileType = folder; name = caf; path = ../../lightning/test/Resources/caf; sourceTree = "<group>"; };
517411B514FB6A420022E871 /* e_cactus.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = e_cactus.png; path = ../../lightning/test/Resources/e_cactus.png; sourceTree = "<group>"; };
517411B814FB6A510022E871 /* tree.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = tree.png; path = ../../lightning/test/Resources/tree.png; sourceTree = "<group>"; };
517411CA14FB749C0022E871 /* Shaders */ = {isa = PBXFileReference; lastKnownFileType = folder; name = Shaders; path = ../../lightning/Shaders; sourceTree = "<group>"; };
517EB87F1522F888009D91B1 /* pallete.plx */ = {isa = PBXFileReference; lastKnownFileType = file; name = pallete.plx; path = ../../lightning/test/Resources/pallete.plx; sourceTree = "<group>"; };
517EB8821522F905009D91B1 /* MyriadPro-Regular0.alpha */ = {isa = PBXFileReference; lastKnownFileType = file; name = "MyriadPro-Regular0.alpha"; path = "../../lightning/test/Resources/MyriadPro-Regular0.alpha"; sourceTree = "<group>"; };
- 517EB89115235990009D91B1 /* map */ = {isa = PBXFileReference; lastKnownFileType = folder; name = map; path = ../../lightning/test/Resources/map; sourceTree = "<group>"; };
51846F6414EE704D00FDE684 /* test.native */ = {isa = PBXFileReference; lastKnownFileType = "compiled.mach-o.executable"; path = test.native; sourceTree = "<group>"; };
- 518819011519DF78002E1E1A /* wcorner.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = wcorner.png; path = ../../lightning/test/Resources/wcorner.png; sourceTree = "<group>"; };
- 518819021519DF78002E1E1A /* whborder.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = whborder.png; path = ../../lightning/test/Resources/whborder.png; sourceTree = "<group>"; };
- 518819031519DF78002E1E1A /* wvborder.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = wvborder.png; path = ../../lightning/test/Resources/wvborder.png; sourceTree = "<group>"; };
- 51881908151A00D4002E1E1A /* ui */ = {isa = PBXFileReference; lastKnownFileType = folder; name = ui; path = ../../lightning/test/Resources/ui; sourceTree = "<group>"; };
- 518874D81518823800A2892F /* frame.pvr */ = {isa = PBXFileReference; lastKnownFileType = file; name = frame.pvr; path = ../../lightning/test/Resources/frame.pvr; sourceTree = "<group>"; };
- 5189B0701521883F00CE78F0 /* 61.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = 61.png; path = ../../lightning/test/Resources/61.png; sourceTree = "<group>"; };
- 518A5291152434A000556D2C /* default.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = default.png; path = ../../lightning/test/Resources/default.png; sourceTree = "<group>"; };
518D151A14FE441300B5436E /* MyriadPro-Regular.fnt */ = {isa = PBXFileReference; lastKnownFileType = text.xml; name = "MyriadPro-Regular.fnt"; path = "../../lightning/test/Resources/MyriadPro-Regular.fnt"; sourceTree = "<group>"; };
- 518FDADA152085CA00F9E211 /* palletes */ = {isa = PBXFileReference; lastKnownFileType = folder; name = palletes; path = ../../lightning/test/Resources/palletes; sourceTree = "<group>"; };
- 518FDADD152085DA00F9E211 /* tree.plx */ = {isa = PBXFileReference; lastKnownFileType = file; name = tree.plx; path = ../../lightning/test/Resources/tree.plx; sourceTree = "<group>"; };
- 518FDAEA1520B1AA00F9E211 /* 60.pvr */ = {isa = PBXFileReference; lastKnownFileType = file; name = 60.pvr; path = ../../lightning/test/Resources/60.pvr; sourceTree = "<group>"; };
- 519017B4151B091600B789EC /* zobjects */ = {isa = PBXFileReference; lastKnownFileType = text; name = zobjects; path = ../../lightning/test/Resources/zobjects; sourceTree = "<group>"; };
5191FD9214FF5FC900DD8677 /* frame.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; name = frame.png; path = ../../lightning/test/Resources/frame.png; sourceTree = "<group>"; };
51B5418414F273C300EB2241 /* items */ = {isa = PBXFileReference; lastKnownFileType = folder; name = items; path = ../../lightning/test/Resources/items; sourceTree = "<group>"; };
51DC6E0414EE5E960084EB76 /* LightTest.app */ = {isa = PBXFileReference; explicitFileType = wrapper.application; includeInIndex = 0; path = LightTest.app; sourceTree = BUILT_PRODUCTS_DIR; };
@@ -91,21 +78,8 @@
51DC6DF914EE5E960084EB76 = {
isa = PBXGroup;
children = (
- 518A5291152434A000556D2C /* default.png */,
- 517EB89115235990009D91B1 /* map */,
517EB8821522F905009D91B1 /* MyriadPro-Regular0.alpha */,
517EB87F1522F888009D91B1 /* pallete.plx */,
- 5189B0701521883F00CE78F0 /* 61.png */,
- 518FDAEA1520B1AA00F9E211 /* 60.pvr */,
- 518FDADD152085DA00F9E211 /* tree.plx */,
- 518FDADA152085CA00F9E211 /* palletes */,
- 519017B4151B091600B789EC /* zobjects */,
- 51881908151A00D4002E1E1A /* ui */,
- 518819011519DF78002E1E1A /* wcorner.png */,
- 518819021519DF78002E1E1A /* whborder.png */,
- 518819031519DF78002E1E1A /* wvborder.png */,
- 518874D81518823800A2892F /* frame.pvr */,
- 513AB2431513836200B4AF5C /* caf */,
5191FD9214FF5FC900DD8677 /* frame.png */,
510C021514FE6ED800BDDCFC /* stoneBoom.caf */,
510C021214FE6C1200BDDCFC /* ra_fertilizer.caf */,
@@ -292,6 +266,7 @@
buildSettings = {
ARCHS = armv7;
DEBUGGING_SYMBOLS = YES;
+ GCC_DYNAMIC_NO_PIC = NO;
GCC_ENABLE_OBJC_EXCEPTIONS = YES;
GCC_GENERATE_DEBUGGING_SYMBOLS = YES;
GCC_OPTIMIZATION_LEVEL = 0;
@@ -301,7 +276,7 @@
ONLY_ACTIVE_ARCH = YES;
OTHER_CFLAGS = "";
OTHER_LDFLAGS = "";
- PATH = "/opt/local/bin:$PATH";
+ PATH = "/usr/local/bin:$PATH";
PRODUCT_NAME = "$(TARGET_NAME)";
SDKROOT = iphoneos;
};
@@ -312,13 +287,14 @@
buildSettings = {
ARCHS = armv7;
DEBUG_INFORMATION_FORMAT = "dwarf-with-dsym";
+ GCC_DYNAMIC_NO_PIC = NO;
GCC_ENABLE_OBJC_EXCEPTIONS = YES;
GCC_WARN_64_TO_32_BIT_CONVERSION = YES;
IPHONEOS_DEPLOYMENT_TARGET = 4.2;
MACOSX_DEPLOYMENT_TARGET = 10.7;
OTHER_CFLAGS = "";
OTHER_LDFLAGS = "";
- PATH = "/opt/local/bin:$PATH";
+ PATH = "/usr/local/bin:$PATH";
PRODUCT_NAME = "$(TARGET_NAME)";
SDKROOT = iphoneos;
};
@@ -374,9 +350,10 @@
buildSettings = {
GCC_PRECOMPILE_PREFIX_HEADER = YES;
GCC_PREFIX_HEADER = "LightTest/LightTest-Prefix.pch";
- GCC_VERSION = com.apple.compilers.llvm.clang.1_0;
+ GCC_VERSION = com.apple.compilers.llvmgcc42;
INFOPLIST_FILE = "LightTest/LightTest-Info.plist";
IPHONEOS_DEPLOYMENT_TARGET = 4.3;
+ LD_NO_PIE = YES;
PRODUCT_NAME = "$(TARGET_NAME)";
WRAPPER_EXTENSION = app;
};
@@ -387,9 +364,10 @@
buildSettings = {
GCC_PRECOMPILE_PREFIX_HEADER = YES;
GCC_PREFIX_HEADER = "LightTest/LightTest-Prefix.pch";
- GCC_VERSION = com.apple.compilers.llvm.clang.1_0;
+ GCC_VERSION = com.apple.compilers.llvmgcc42;
INFOPLIST_FILE = "LightTest/LightTest-Info.plist";
IPHONEOS_DEPLOYMENT_TARGET = 4.3;
+ LD_NO_PIE = YES;
PRODUCT_NAME = "$(TARGET_NAME)";
WRAPPER_EXTENSION = app;
};
View
2  test/Makefile.common
@@ -12,4 +12,4 @@ MLFLAGS = -package camlp4,camlp4.macro -syntax camlp4r -w +7+9 -g
$(OCAMLC) $(MLFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) -c $<
%.cmx: %.ml
- $(OCAMLOPT) $(MLFLAGS) $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) -c $<
+ $(OCAMLOPT) $(MLFLAGS) -S $(if $(MLPPOPT),$(patsubst %,-ppopt %,$(MLPPOPT))) -c $<
View
12 test/Makefile.in
@@ -6,25 +6,27 @@ MLFLAGS += -I ../src -package extlib -package ojson -I ../src/social
#MLFILES = panelbg.cmo testz.cmo
-SOCIAL= ../src/social/oauth/oauth.cma ../src/social/OK.cmo ../src/social/VK.cmo -ccopt -L../src/social/oauth
+SOCIAL= ../src/social/OK.cmo ../src/social/VK.cmo -ccopt -L../src/social/oauth
+OAUTH = ../src/social/oauth/oauth.cma
example.byte: $(MLFILES) example.cmo
$(OCAMLC) -custom -verbose -o test.byte -g \
- -I ../src ../src/lightning.cma $(SOCIAL) $(MLFILES) example.cmo \
- -package curl,bigarray,extlib,xmlm,ojson,dbm,threads -thread -linkpkg
+ -I ../src ../src/lightning.cma $(OAUTH) $(SOCIAL) $(MLFILES) example.cmo \
+ -package curl,bigarray,extlib,xmlm,ojson,threads -thread -linkpkg
example.cmo: $(MLFILES)
MLXFILES = $(MLFILES:.cmo=.cmx)
SOCIALX = $(SOCIAL:.cmo=.cmx)
+OAUTHX = ../src/social/oauth/oauth.cmxa
example.cmx: $(MLXFILES)
example.native: $(MOBS) $(MLXFILES) example.cmx
$(OCAMLOPT) -verbose -o test.native -g \
- -I ../src ../src/lightning.cmxa $(SOCIALX) $(MOBS) $(MLXFILES) example.cmx \
- -package extlib,xmlm,dbm,ojson,bigarray,threads -thread -linkpkg
+ -I ../src ../src/lightning.cmxa $(OAUTHX) $(SOCIALX) $(MOBS) $(MLXFILES) example.cmx \
+ -package extlib,xmlm,ojson,bigarray,threads -thread -linkpkg
.PHONY: clean
clean::
View
8 test/Makefile.ios
@@ -1,11 +1,11 @@
-PLAT = /Developer/Platforms/iPhoneOS.platform
-SDK = /Developer/SDKs/iPhoneOS5.0.sdk
-OCAMLFIND = ocamlfind -toolchain ios
+PLAT = /Applications/Xcode.app/Contents/Developer/Platforms/iPhoneOS.platform
+SDK = /Developer/SDKs/iPhoneOS5.1.sdk
+OCAMLFIND = /usr/local/bin/ocamlfind -toolchain ios
OCAMLOPT = $(OCAMLFIND) ocamlopt
OCAMLC = $(OCAMLFIND) ocamlc
OCAMLLIBDIR = $(shell ${OCAMLOPT} -where)
ARCH = -arch armv7
-CC = $(PLAT)/Developer/usr/bin/llvm-gcc $(ARCH)
+CC = $(PLAT)/Developer/usr/bin/gcc $(ARCH)
CFLAGS = -x objective-c -std=c99 -Wno-trigraphs -fpascal-strings -Os -Wreturn-type -Wunused-variable -isysroot $(PLAT)$(SDK) -isystem $(OCAMLLIBDIR) -DCAML_NAME_SPACE -fexceptions -miphoneos-version-min=4.2 -gdwarf-2 -D_FILE_OFFSET_BITS=64 -D_REENTRANT
include Makefile.common
View
63 test/example.ml
@@ -2,6 +2,7 @@ open LightCommon;
(* Gc.set {(Gc.get ()) with Gc.verbose = (0x001 lor 0x002 lor 0x004 lor 0x010 lor 0x040 lor 0x080)}; *)
+Printexc.record_backtrace True;
value max_anim_len = 40;
value (|>) a b = b a;
(*
@@ -134,7 +135,9 @@ value onClick obj handler =
value tlf (stage:Stage.c) =
(
+ debug "REGISTR FONT";
BitmapFont.register "MyriadPro-Regular.fnt";
+ debug "FONT REGISTRED";
TLF.default_font_family.val := "Myriad Pro";
let quad = Quad.create ~color:(`Color 0xCC0000) 100. 20. in
(
@@ -223,6 +226,7 @@ value tlf (stage:Stage.c) =
);
+(*
value masks (stage:Stage.c) =
(
let tree = Image.load "tree.png" in
@@ -248,6 +252,7 @@ value atlas (stage:Stage.c) =
);
);
+*)
value disable_filter =
Bigarray.Array1.of_array Bigarray.float32 Bigarray.c_layout
@@ -305,6 +310,7 @@ value filters (stage:Stage.c) =
);
+(*
value size (stage:Stage.c) =
let img = Image.load "tree.png" in
(
@@ -316,6 +322,7 @@ value size (stage:Stage.c) =
)
end;
);
+*)
value flip (stage:Stage.c) =
@@ -336,6 +343,7 @@ value flip (stage:Stage.c) =
);
+(*
value async_load (stage:Stage.c) =
(
let lib = LightLib.load "Clips" in
@@ -870,14 +878,23 @@ value glow (stage:Stage.c) =
*)
);
);
+*)
+value raise_some_exn () =
+ if True then raise (Failure "BLYYYY exn") else ();
value test_exn (stage:Stage.c) =
Timers.start 5. begin fun () ->
- failwith("BLYYYY exn");
+(* try *)
+ (
+ prerr_endline "now call exn";
+ raise_some_exn ();
+ )
+(* with [ exn -> (Printexc.print_backtrace stderr; flush stderr) ] *)
end;
+(*
value social (stage:Stage.c) =
(
let b = Image.load "tree.png" in
@@ -937,12 +954,46 @@ value social (stage:Stage.c) =
end
);
);
+*)
+
+
+value tweens (stage:Stage.c) =
+ let bt = Image.load "tree.png" in
+ let () = stage#addChild bt in
+ let tweenY = Tween.create ~transition:`easeOutBounce 10.
+ (* and tweenX = Tween.create 0.7 *)
+ (* and tweenAlpha = Tween.create 0.8 *)
+ in
+ (
+ bt#setX 100.;
+ (* Stage.addTween tweenX; *)
+ Stage.addTween tweenY;
+ (* Stage.addTween tweenAlpha; *)
+ (* tweenX#animate bt#prop'x 300.; *)
+ tweenY#animate bt#prop'y 600.;
+ (* tweenAlpha#animate bt#prop'alpha 0.5; *)
+ (* tweenX#setOnComplete (fun () -> Stage.removeTween tweenX); *)
+ (* tweenY#setOnComplete (fun () -> Stage.removeTween tweenY); *)
+ (* tweenAlpha#setOnComplete begin fun () ->
+ (
+ Stage.removeTween tweenAlpha;
+ let tween = Tween.create 0.15 in
+ (
+ Stage.addTween tween;
+ tween#animate bt#prop'alpha 0.;
+ (* tween#setOnComplete (fun () -> Stage.removeTween tween); *)
+ (* ignore(tween#process 0.04); *)
+ )
+ ) end; *)
+ );
+
let stage width height =
object(self)
inherit Stage.c width height as super;
value bgColor = 0xCCCCCC;
initializer begin
+ debug "START OCAML";
(* BitmapFont.register "MyriadPro-Regular.fnt"; *)
(* BitmapFont.register "MyriadPro-Bold.fnt"; *)
(* TLF.default_font_family.val := "Myriad Pro"; *)
@@ -951,16 +1002,18 @@ let stage width height =
self#addChild tlf;
*)
(* map self; *)
- image self;
+(* image self; *)
+(* rec_fun self; *)
(* test_alpha self; *)
(* alert self; *)
-(* test_exn self; *)
-(* flip self; *)
+ (* test_exn self; *)
+ tweens self;
+ (* flip self; *)
(* social self; *)
(* async_load self; *)
(* filters self; *)
(* size self; *)
- tlf self;
+ (* tlf self; *)
(* external_image self; *)
(* sound self; *)
(* atlas self; *)
View
12 test/testz.ml
@@ -10,7 +10,7 @@ class wobj bpos tpos depth =
value zObjects : DynArray.t wobj = DynArray.create ();
value init () =
- let f = LightCommon.open_resource "zobjects" in
+ let f = open_in "zobjects" in
read () where
rec read () =
try
@@ -18,12 +18,11 @@ value init () =
Scanf.sscanf l "(%d:%d)(%d:%d)%d" begin fun bposx bposy tposx tposy depth ->
DynArray.add zObjects (new wobj (bposx,bposy) (tposx,tposy) depth)
end;
- read ();
+(* read (); *)
with [ End_of_file -> close_in f ];
value zSort () =
- let () = debug "zSort: %d" (DynArray.length zObjects) in
let ls = DynArray.copy zObjects in
let stack = ref []
and max = ref (DynArray.length ls)
@@ -33,7 +32,6 @@ value zSort () =
in
(
while (!max > 0) do
- let () = debug:zsort "max: %d" !max in
let woA = ref (DynArray.get ls 0)
and m = ref 0
and go = ref True
@@ -44,7 +42,6 @@ value zSort () =
DynArray.delete ls 0;
while !go do
(
- debug:zsort "isStack: %b" !isStack;
match !isStack with
[ True ->
(
@@ -61,7 +58,6 @@ value zSort () =
)
| _ -> ()
];
- debug:zsort "woA: [%d;%d] %d" (fst !woA#bpos) (snd !woA#bpos) !m;
match !go with
[ True ->
(
@@ -70,7 +66,6 @@ value zSort () =
match cnt < !m with
[ True -> ()
| _ ->
- let () = debug:zsort "for i = %d to %d" !m cnt in
try
for i = !m to cnt do
let woB = DynArray.get ls i in
@@ -78,7 +73,6 @@ value zSort () =
[ True ->
(
flag.val := False;
- debug:zsort "woB: [ %d; %d] %d" (fst woB#bpos) (snd woB#bpos) i;
stack.val := [ (i, !woA) :: (List.map (fun (k,wo) -> match k > 0 && k >= i with [ True -> (k - 1, wo) | _ -> (k, wo)]) !stack) ];
woA.val := woB;
m.val := 0;
@@ -91,7 +85,6 @@ value zSort () =
done
with [ Exit -> () ]
];
- debug:zsort "flag: %b" !flag;
match !flag with
[ True ->
(
@@ -121,7 +114,6 @@ value zSort () =
)
| _ -> ()
];
- debug:zsort "go: %b" !go;
)
done
)
View
1  utils/respacker/TextureLayout.ml
View
3  utils/respacker/_tags
@@ -1,3 +0,0 @@
-<*.ml>: package(camlp4),syntax(camlp4r),package(camlimages.core)
-<respacker.{ml,byte,native}>: package(extlib),package(camlimages.png),package(json-wheel),package(xmlm)
-true: debug
View
12 utils/respacker/build.sh
@@ -1,12 +0,0 @@
-#!/bin/bash
-
-OCB="ocamlbuild -use-ocamlfind"
-target=respacker
-
-case $1 in
- clean) $OCB -clean ;;
- byte) $OCB ${target}.byte ;;
- *) $OCB $target.native
-esac
-
-#ocamlbuild -use-ocamlfind respacker.native
View
291 utils/respacker/respacker.ml
@@ -1,291 +0,0 @@
-(* Скрипт пакует данные swf потрошителя *)
-open ExtList;
-open ExtString;
-open Printf;
-
-value (//) = Filename.concat;
-value (=|=) k v = (("",k),v);
-value (=.=) k v = k =|= string_of_float v;
-value (=*=) k v = k =|= string_of_int v;
-
-value bgcolor = {Color.color = {Color.r = 0; g = 0; b = 0}; alpha = 0};
-
-(*
-*)
-
-(*
-type element =
- [= `image of Texture.c
- | `sprite of list sprite_element
- | `clip of array frame
- ]
-and sprite_element = (element * Point.t)
-and frame =
-{
- hotpos: Point.t;
- content: element;
- label: string; (* ну тут еще duration нужон но это после нах. *)
-};
-
-type lib = Hashtbl.t string element;
-*)
-
-type pos = (float*float);
-type texinfo = {page:mutable int; x:mutable int;y:mutable int; width: int;height:int};
-type children = list (int * option string * pos);
-type frame = {children:children; label: option string; duration: mutable int};
-type iteminfo = [= `image of texinfo | `sprite of children | `clip of list frame ];
-
-value items : DynArray.t iteminfo = DynArray.create ();
-
-(* value compare_img img1 img2 = *)
- (* возвращает либо что полностью идентичны, либо что отличаюца только по альфе *)
-
-value push_item item =
- try
- match item with
- [ `sprite _ | `clip _ -> DynArray.index_of (fun i -> i = item) items
- | `image _ -> raise Not_found
- ]
- with
- [ Not_found ->
- (
- DynArray.add items item;
- (DynArray.length items) - 1;
- )
- ];
-
-value images = RefList.empty ();
-
-
-value add_image dirname mobj =
- let img = Images.load (dirname // (Json_type.Browse.string (List.assoc "file" mobj))) [] in
- try
- let (id,_) = RefList.find (fun (id,img') -> img = img') images in
- id
- with
- [ Not_found ->
- let id =
- let (width,height) = Images.size img in
- push_item (`image {page=0;x=0;y=0;width;height})
- in
- (
- RefList.push images (id,img);
- id
- )
- ];
-
-value getpos jsinfo = let open Json_type.Browse in (number (List.assoc "x" jsinfo),number (List.assoc "y" jsinfo));
-
-(* можно при добавлении картинок палить что они такие-же только разница в альфе - это легко
- * а в группировке есть засада, что мы можем не понять что это одно и тоже так как мы с чем-то слепим и будет не круто
- * *)
-
-(* value calc_diff oldchildrens newchildrens = *)
-
-value rec process_children dirname children =
- let open Json_type.Browse in
- list begin fun child ->
- let child = objekt child in
- let name = try Some (string (List.assoc "name" child)) with [ Not_found -> None ] in
- let pos = getpos child in
- let id =
- match string (List.assoc "type" child) with
- [ "image" -> add_image dirname child
- | "clip" -> process_dir (dirname // (string (List.assoc "dir" child)))
- | _ -> assert False
- ]
- in
- (id,name,pos)
- end children
-and process_dir dirname = (* найти мету в этой директории и от нее плясать *)
- let () = printf "process directory: %s\n%!" dirname in
- let meta = Json_io.load_json (dirname // "meta.json") in
- let open Json_type.Browse in
- let mobj = objekt meta in
- match string (List.assoc "type" mobj) with
- [ "image" -> add_image dirname mobj
- | "sprite" ->
- let children = process_children dirname (List.assoc "children" mobj) in
- push_item (`sprite children)
- | "clip" ->
- let frames =
- list begin fun frame ->
- let frame = objekt frame in
- let label = try Some (string (List.assoc "label" frame)) with [ Not_found -> None ] in
- let children = process_children dirname (List.assoc "children" frame) in
- {label;children;duration=1}
- end (List.assoc "frames" mobj)
- in
- (* вычислим duration *)
- (* FIXME: придумать сдесь механизм изменений *)
- let frames =
- List.fold_left begin fun frames frame ->
- match frames with
- [ [ pframe :: _ ] when pframe = frame ->
- (
- pframe.duration := pframe.duration + 1;
- frames
- )
- | _ -> [ frame :: frames ]
- ]
- end [] frames
- in
- push_item (`clip (List.rev frames))
- | _ -> assert False
- ];
-
-value outdir = ref "output";
-
-value do_work indir =
- let exports = RefList.empty () in
- (
- Array.iter begin fun fl ->
- let dirname = indir // fl in
- if Sys.is_directory dirname
- then
- let item_id = process_dir dirname in
- RefList.push exports (fl,item_id)
- else ()
- end (Sys.readdir indir);
- let outdir = !outdir // (Filename.basename indir) in
- let () = printf "output to %s\n%!" outdir in
- (
- if Sys.file_exists outdir
- then
- match Sys.command (Printf.sprintf "rm -rf %s" outdir) with
- [ 0 -> ()
- | n -> exit n
- ]
- else ();
- Unix.mkdir outdir 0o755;
- (* Теперича сохранить xml и усе *)
- let out = open_out (outdir // "lib.xml") in
- let xmlout = Xmlm.make_output ~indent:(Some 2) (`Channel out) in
- (
- Xmlm.output xmlout (`Dtd None);
- Xmlm.output xmlout (`El_start (("","lib"),[]));
- Xmlm.output xmlout (`El_start (("","textures"),[])); (* write textures {{{*)
- let pages = TextureLayout.layout (RefList.to_list images) in
- List.iteri begin fun i (w,h,imgs) ->
- let texture = Rgba32.make w h bgcolor in
- (
- List.iter begin fun (key,(x,y,img)) ->
- (
- let img = match img with [ Images.Rgba32 img -> img | _ -> assert False ] in
- Rgba32.blit img 0 0 texture x y img.Rgba32.width img.Rgba32.height;
- match DynArray.get items key with
- [ `image inf -> ( inf.x := x; inf.y := y; inf.page := i;)
- | _ -> assert False
- ]
- )
- end imgs;
- let imgname = Printf.sprintf "%d.png" i in
- (
- Images.save (outdir // imgname) (Some Images.Png) [] (Images.Rgba32 texture);
- Xmlm.output xmlout (`El_start (("","texture"),["file" =|= imgname]));
- Xmlm.output xmlout `El_end;
- )
- )
- end pages;
- Xmlm.output xmlout `El_end;(*}}}*)
- Xmlm.output xmlout (`El_start (("","items"),[]));(* write items {{{ *)
- let write_children =
- List.iter begin fun (id,name,(posX,posY)) ->
- (
- let attrs = [ "id" =*= id; "posX" =.= posX; "posY" =.= posY ] in
- let attrs = match name with [ Some n -> [ "name" =|= n :: attrs ] | None -> attrs ] in
- Xmlm.output xmlout (`El_start (("","child"),attrs));
- Xmlm.output xmlout `El_end;
- )
- end
- in
- DynArray.iteri begin fun id item ->
- (
- match item with
- [ `image info ->
- let attributes =
- [
- "type" =|= "image";
- "texture" =*= info.page;
- "x" =*= info.x;
- "y" =*= info.y;
- "width" =*= info.width;
- "height" =*= info.height
- ]
- in
- Xmlm.output xmlout (`El_start (("","item"),[ "id" =*= id :: attributes ]))
- | `sprite children ->
- (
- Xmlm.output xmlout (`El_start (("","item"),[ "id" =*= id ; "type" =|= "sprite" ]));
- write_children children;
- )
- | `clip frames ->
- (
- Xmlm.output xmlout (`El_start (("","item"),[ "id" =*= id ; "type" =|= "clip" ]));
- List.iter begin fun frame ->
- (
- let attrs = [ "duration" =*= frame.duration ] in
- let attrs = match frame.label with [ Some l -> [ "label" =|= l :: attrs ] | None -> attrs ] in
- Xmlm.output xmlout (`El_start (("","frame"),attrs));
- write_children frame.children;
- Xmlm.output xmlout `El_end;
- )
- end frames;
- )
- ];
- Xmlm.output xmlout `El_end;
- )
- end items;
- Xmlm.output xmlout `El_end;(*}}}*)
- Xmlm.output xmlout (`El_start (("","symbols"),[])); (* write symbols {{{*)
- RefList.iter begin fun (cls,id) ->
- (
- Xmlm.output xmlout (`El_start (("","symbol"),[ "class" =|= cls; "id" =*= id ]));
- Xmlm.output xmlout `El_end;
- )
- end exports;
- Xmlm.output xmlout `El_end;(*}}}*)
- Xmlm.output xmlout `El_end;
- close_out out;
- )
- );
- );
-
-
-value () =
- let indir = ref None in
- (
- Arg.parse [ ("-o",Arg.Set_string outdir,"outpud directory") ] (fun id -> indir.val := Some id) "usage msg";
- match !indir with
- [ None -> failwith "You must spec input dir"
- | Some indir ->
- let indir = if indir.[String.length indir - 1] = '/' then String.rchop indir else indir in
- do_work indir
- ]
- );
-
-(*
-----
-<lib>
-<textures><texture file=""/></textures>
-<items>
-<item id="1" type="image" texture="0" x="" y="" width="" height=""/>
-<item id="2"
-<item id="2" type="sprite">
- <child id="3" xPos="" yPos=""/>
- <child id="4" xPos="" yPos=""/>
-</item>
-<item id="10" type="clip">
-<frame duration="" posX="" posY="" item="3">
-<child id=2 posX posY/>
-</frame>
-<frame duration="" posX="" posY="" item="3"/>
-<frame duration="" posX="" posY="" item="3"/>
-</item>
-<exports>
-<export class="ESkins.Bg_Exp" item="2"/>
-</exports>
-</lib>
-----
-*)
Please sign in to comment.
Something went wrong with that request. Please try again.