diff options
23 files changed, 24 insertions, 1586 deletions
diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile index 22e09ccbe..8c3b823c5 100644 --- a/otherlibs/labltk/Makefile +++ b/otherlibs/labltk/Makefile @@ -1,6 +1,6 @@ # Top Makefile for mlTk -SUBDIRS=compiler support lib jpf frx tkanim examples_labltk \ +SUBDIRS=compiler support lib jpf frx examples_labltk \ examples_camltk browser SUBDIRS_GENERATED=camltk labltk @@ -15,7 +15,6 @@ all: cd lib; $(MAKE) cd jpf; $(MAKE) cd frx; $(MAKE) - cd tkanim; $(MAKE) cd browser; $(MAKE) allopt: @@ -27,7 +26,6 @@ allopt: cd lib; $(MAKE) opt cd jpf; $(MAKE) opt cd frx; $(MAKE) opt - cd tkanim; $(MAKE) opt byte: all opt: allopt @@ -60,7 +58,6 @@ install: cd compiler; $(MAKE) install cd jpf; $(MAKE) install cd frx; $(MAKE) install - cd tkanim; $(MAKE) install cd browser; $(MAKE) install installopt: @@ -70,7 +67,6 @@ installopt: cd camltk; $(MAKE) installopt cd jpf; $(MAKE) installopt cd frx; $(MAKE) installopt - cd tkanim; $(MAKE) installopt partialclean clean: for d in $(SUBDIRS); do \ diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml index b5195307c..c93146231 100644 --- a/otherlibs/labltk/examples_camltk/eyes.ml +++ b/otherlibs/labltk/examples_camltk/eyes.ml @@ -25,7 +25,7 @@ let _ = pack [fw] []; let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in let create_eye cx cy wx wy ewx ewy bnd = - let o2 = + let _o2 = Canvas.create_oval c (Pixels (cx - wx)) (Pixels (cy - wy)) (Pixels (cx + wx)) (Pixels (cy + wy)) diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml index e8bb69e47..835343475 100644 --- a/otherlibs/labltk/examples_camltk/tetris.ml +++ b/otherlibs/labltk/examples_camltk/tetris.ml @@ -215,7 +215,6 @@ let init fw = let scorev = Textvariable.create () and linev = Textvariable.create () and levv = Textvariable.create () - and namev = Textvariable.create () in let f = Frame.create fw [BorderWidth (Pixels 2)] in let c = Canvas.create f [Width (Pixels (block_size * 10)); diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h index 56cb29a68..5be206faa 100644 --- a/otherlibs/labltk/support/camltk.h +++ b/otherlibs/labltk/support/camltk.h @@ -27,6 +27,11 @@ #define CONST84 #endif +/* if Tcl_GetStringResult is not defined, we use interp->result */ +#ifndef Tcl_GetStringResult +# define Tcl_GetStringResult(interp) (interp->result) +#endif + /* cltkMisc.c */ /* copy a Caml string to the C heap. Must be deallocated with stat_free */ extern char *string_to_c(value s); diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c index 9272e8fc2..3d9a4c2df 100644 --- a/otherlibs/labltk/support/cltkDMain.c +++ b/otherlibs/labltk/support/cltkDMain.c @@ -223,7 +223,7 @@ int Caml_Init(interp) if (0 == access(f,R_OK)) if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { stat_free(f); - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); }; stat_free(f); } diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c index 168b9fe8f..cdd16a914 100644 --- a/otherlibs/labltk/support/cltkEval.c +++ b/otherlibs/labltk/support/cltkEval.c @@ -75,9 +75,9 @@ CAMLprim value camltk_tcl_eval(value str) switch (code) { case TCL_OK: - return tcl_string_to_caml(cltclinterp->result); + return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp)); case TCL_ERROR: - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ tk_error("bad tcl result"); } @@ -234,9 +234,9 @@ CAMLprim value camltk_tcl_direct_eval(value v) switch (result) { case TCL_OK: - return tcl_string_to_caml (cltclinterp->result); + return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp)); case TCL_ERROR: - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ tk_error("bad tcl result"); } diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c index 2853b3856..eb4617a45 100644 --- a/otherlibs/labltk/support/cltkMain.c +++ b/otherlibs/labltk/support/cltkMain.c @@ -95,7 +95,7 @@ CAMLprim value camltk_opentk(value argv) } if (Tcl_Init(cltclinterp) != TCL_OK) - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY); { /* Sets argv */ @@ -132,13 +132,13 @@ CAMLprim value camltk_opentk(value argv) } } if (Tk_Init(cltclinterp) != TCL_OK) - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); /* Retrieve the main window */ cltk_mainWindow = Tk_MainWindow(cltclinterp); if (NULL == cltk_mainWindow) - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); Tk_GeometryRequest(cltk_mainWindow,200,200); } @@ -165,7 +165,7 @@ CAMLprim value camltk_opentk(value argv) if (0 == access(f,R_OK)) if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { stat_free(f); - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); }; stat_free(f); } diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c index 23364ad11..b19713cda 100644 --- a/otherlibs/labltk/support/cltkMisc.c +++ b/otherlibs/labltk/support/cltkMisc.c @@ -47,7 +47,7 @@ CAMLprim value camltk_splitlist (value v) case TCL_ERROR: default: stat_free( utf ); - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); } } diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c index 674b8e9db..0411a94cd 100644 --- a/otherlibs/labltk/support/cltkVar.c +++ b/otherlibs/labltk/support/cltkVar.c @@ -38,8 +38,8 @@ CAMLprim value camltk_getvar(value var) stat_free(stable_var); if (s == NULL) - tk_error(cltclinterp->result); - else + tk_error(Tcl_GetStringResult(cltclinterp)); + else return(tcl_string_to_caml(s)); } @@ -64,8 +64,8 @@ CAMLprim value camltk_setvar(value var, value contents) stat_free(utf_contents); if (s == NULL) - tk_error(cltclinterp->result); - else + tk_error(Tcl_GetStringResult(cltclinterp)); + else return(Val_unit); } @@ -104,7 +104,7 @@ CAMLprim value camltk_trace_var(value var, value cbid) (ClientData) (Long_val(cbid))) != TCL_OK) { stat_free(cvar); - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); }; stat_free(cvar); return Val_unit; diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c index a4fdab0c4..4c126b5d2 100644 --- a/otherlibs/labltk/support/cltkWait.c +++ b/otherlibs/labltk/support/cltkWait.c @@ -66,7 +66,7 @@ CAMLprim value camltk_wait_vis(value win, value cbid) vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); if (vis -> win == NULL) { stat_free((char *)vis); - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); }; vis->cbid = Int_val(cbid); Tk_CreateEventHandler(vis->win, VisibilityChangeMask, @@ -93,7 +93,7 @@ CAMLprim value camltk_wait_des(value win, value cbid) vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow); if (vis -> win == NULL) { stat_free((char *)vis); - tk_error(cltclinterp->result); + tk_error(Tcl_GetStringResult(cltclinterp)); }; vis->cbid = Int_val(cbid); Tk_CreateEventHandler(vis->win, StructureNotifyMask, diff --git a/otherlibs/labltk/tkanim/.cvsignore b/otherlibs/labltk/tkanim/.cvsignore deleted file mode 100644 index 387840984..000000000 --- a/otherlibs/labltk/tkanim/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -gifanimtest -gifanimtest-static -*.so -*.a diff --git a/otherlibs/labltk/tkanim/.depend b/otherlibs/labltk/tkanim/.depend deleted file mode 100644 index 5f54ec3e4..000000000 --- a/otherlibs/labltk/tkanim/.depend +++ /dev/null @@ -1,2 +0,0 @@ -tkanim.cmo: tkanim.cmi -tkanim.cmx: tkanim.cmi diff --git a/otherlibs/labltk/tkanim/Makefile b/otherlibs/labltk/tkanim/Makefile deleted file mode 100644 index c29743881..000000000 --- a/otherlibs/labltk/tkanim/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -# tkAnimGIF.c used the function Tk_ImageObjCmd, which is not available -# in a plain Tk installation. Should we disable this subdirectory ? - -include ../support/Makefile.common - -COMPFLAGS=-I ../support -I ../camltk -I ../../unix -I ../../win32unix -CCFLAGS=-I../../../byterun -I../support $(TK_DEFS) $(SHAREDCCCOMPOPTS) - -all: tkanim.cma libtkanim.$(A) -opt: tkanim.cmxa libtkanim.$(A) -example: gifanimtest$(EXE) - -OBJS=tkanim.cmo -COBJS= cltkaniminit.$(O) tkAnimGIF.$(O) - -tkanim.cma: $(OBJS) - $(MKLIB) -ocamlc '$(CAMLCB)' -o tkanim $(OBJS) - -tkanim.cmxa: $(OBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o tkanim $(OBJS:.cmo=.cmx) - -libtkanim.$(A): $(COBJS) - $(MKLIB) -o tkanim $(COBJS) - -gifanimtest-static$(EXE): all gifanimtest.cmo - $(CAMLC) -custom -o $@ -I ../lib -I ../support -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma -ccopt -L. $(LIBNAME).cma tkanim.cma gifanimtest.cmo - -# dynamic loading -gifanimtest$(EXE): all gifanimtest.cmo - $(CAMLC) -o $@ -I ../lib -I ../support -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo - -#animwish: $(TKANIM_LIB) tkAppInit.o -# $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \ -# -L. -ltkanim $(LIBS) - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa - -clean: - rm -f *.cm* *.$(O) *.$(A) dlltkanim$(EXT_DLL) gifanimtest$(EXE) gifanimtest-static$(EXE) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .$(O) - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(O): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - - -install: - cp tkanim.cma *.cmi *.mli libtkanim.$(A) $(INSTALLDIR) - if [ -f dlltkanim$(EXT_DLL) ]; then \ - cp dlltkanim$(EXT_DLL) $(STUBLIBDIR)/; \ - fi - -installopt: - cp tkanim.cmxa tkanim.$(A) $(INSTALLDIR) - -depend: tkanim.ml - $(CAMLDEP) *.mli *.ml > .depend - -include .depend diff --git a/otherlibs/labltk/tkanim/Makefile.nt b/otherlibs/labltk/tkanim/Makefile.nt deleted file mode 100644 index 2b0b5ab53..000000000 --- a/otherlibs/labltk/tkanim/Makefile.nt +++ /dev/null @@ -1 +0,0 @@ -include Makefile diff --git a/otherlibs/labltk/tkanim/README b/otherlibs/labltk/tkanim/README deleted file mode 100644 index 65f3de081..000000000 --- a/otherlibs/labltk/tkanim/README +++ /dev/null @@ -1,5 +0,0 @@ -This ML code is an interface for Tkanim Tcl/Tk extension. Unfortunately -it is still test implementation. Look example directory for an example. - -The codes under this directory are mainly written by Jun Furuse -(Jun.Furuse@inria.fr). diff --git a/otherlibs/labltk/tkanim/cltkaniminit.c b/otherlibs/labltk/tkanim/cltkaniminit.c deleted file mode 100644 index a45bedcb5..000000000 --- a/otherlibs/labltk/tkanim/cltkaniminit.c +++ /dev/null @@ -1,28 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ -#include <tk.h> -#include <mlvalues.h> -#include "camltk.h" - -extern int Tkanim_Init(Tcl_Interp *); - -CAMLprim value tkanim_init (rien) /* ML */ - value rien; -{ - if (Tkanim_Init(cltclinterp) != TCL_OK) - tk_error ("Can't initialize TkAnim"); - return Val_unit; -} diff --git a/otherlibs/labltk/tkanim/gifanimtest.ml b/otherlibs/labltk/tkanim/gifanimtest.ml deleted file mode 100644 index 1740b8e66..000000000 --- a/otherlibs/labltk/tkanim/gifanimtest.ml +++ /dev/null @@ -1,71 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -open Tkanim -open Tk - -let main () = - let file = ref "" in - Arg.parse [] (fun s -> file := s) - "usage: gifanimtest file (animated gif)\n\ - \tbutton 1 toggles the animation,\n\ - \tbutton 2 displays the next frame,\n\ - \tbutton 3 quits."; - let t = openTk () in - - (* First of all, you must initialize the extension. *) - Tkanim.init (); - - prerr_endline !file; - - (* Then load the animated gif. *) - let anim = Tkanim.create !file in - prerr_endline "load done"; - - (* Check it is really animated or not. *) - match anim with - | Still x -> - (* Use whatever you want in CamlTk with this ImagePhoto. *) - prerr_endline "Sorry, it is not an animated GIF." - - | Animated x -> - (* OK, let's animate it. *) - let l = Label.create t [] in - pack [l] []; - - (* animate returns an interface function. *) - let f = animate l x in - - (* Button1 toggles the animation *) - bind l [[], ButtonPressDetail 1] (BindSet ([], (fun _ -> - f false))); - - (* Button2 displays the next frame. *) - bind l [[], ButtonPressDetail 2] (BindSet ([], (fun _ -> - f true))); - - (* Button3 quits. *) - bind l [[], ButtonPressDetail 3] (BindSet ([], (fun _ -> - closeTk ()))); - - (* start the animation *) - f false; - - (* Go to the main loop. *) - mainLoop () - -let _ = Printexc.print main () diff --git a/otherlibs/labltk/tkanim/libtkanim.clib b/otherlibs/labltk/tkanim/libtkanim.clib deleted file mode 100644 index 0db9d1690..000000000 --- a/otherlibs/labltk/tkanim/libtkanim.clib +++ /dev/null @@ -1 +0,0 @@ -cltkaniminit.o tkAnimGIF.o diff --git a/otherlibs/labltk/tkanim/mmm.anim.gif b/otherlibs/labltk/tkanim/mmm.anim.gif Binary files differdeleted file mode 100644 index 2cddf8195..000000000 --- a/otherlibs/labltk/tkanim/mmm.anim.gif +++ /dev/null diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c deleted file mode 100644 index a015b0484..000000000 --- a/otherlibs/labltk/tkanim/tkAnimGIF.c +++ /dev/null @@ -1,914 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ -#define TKANIM_VERSION "1.0" -/* #define TKANIM_DEBUG */ - -#include <tk.h> -#include <string.h> - -/* - * The format record for the Animated GIF file format: - */ - -static int FileMatchGIF _ANSI_ARGS_((FILE *f, char *fileName, - char *formatString, int *widthPtr, int *heightPtr)); -static int FileReadGIF _ANSI_ARGS_((Tcl_Interp *interp, - FILE *f, char *fileName, char *formatString)); - -#define INTERLACE 0x40 -#define LOCALCOLORMAP 0x80 -#define BitSet(byte, bit) (((byte) & (bit)) == (bit)) -#define MAXCOLORMAPSIZE 256 -#define CM_RED 0 -#define CM_GREEN 1 -#define CM_BLUE 2 -#define MAX_LWZ_BITS 12 -#define LM_to_uint(a,b) (((b)<<8)|(a)) -#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0) - -/* - * Prototypes for local procedures defined in this file: - */ - -static int DoExtension _ANSI_ARGS_((FILE *fd, int label, - int *transparent, int *delay, int *loop)); -static int GetCode _ANSI_ARGS_((FILE *fd, int code_size, - int flag)); -static int GetDataBlock _ANSI_ARGS_((FILE *fd, - unsigned char *buf)); -static int LWZReadByte _ANSI_ARGS_((FILE *fd, int flag, - int input_code_size)); -static int ReadColorMap _ANSI_ARGS_((FILE *fd, int number, - unsigned char buffer[3][MAXCOLORMAPSIZE])); -static int ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr, - int *heightPtr)); -static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp, - char *imagePtr, FILE *fd, int len, int height, - unsigned char cmap[3][MAXCOLORMAPSIZE], - int interlace, int transparent)); - -static int -FileMatchGIF(f, fileName, formatString, widthPtr, heightPtr) - FILE *f; /* The image file, open for reading. */ - char *fileName; /* The name of the image file. */ - char *formatString; /* User-specified format string, or NULL. */ - int *widthPtr, *heightPtr; /* The dimensions of the image are - * returned here if the file is a valid - * raw GIF file. */ -{ - return ReadGIFHeader(f, widthPtr, heightPtr); -} - -static int -FileReadGIF(interp, f, fileName, formatString) - Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ - FILE *f; /* The image file, open for reading. */ - char *fileName; /* The name of the image file. */ - char *formatString; /* User-specified format string, or NULL. */ -{ - int logicalWidth, logicalHeight; - int nBytes; - Tk_PhotoImageBlock block; - unsigned char buf[100]; - int bitPixel; - unsigned int colorResolution; - unsigned int background; - unsigned int aspectRatio; - unsigned char localColorMap[3][MAXCOLORMAPSIZE]; - unsigned char colorMap[3][MAXCOLORMAPSIZE]; - int useGlobalColormap; - int transparent = -1; - int delay = 0; - Tk_Window winPtr; - int imageLeftPos, imageTopPos, imageWidth, imageHeight; - Tk_PhotoHandle photoHandle; - - char widthbuf[32], heightbuf[32]; - Tcl_DString resultbuf; - - char newresbuf[640]; - char *imageName; - char *resultptr; - int loop = -1; - - if((winPtr = Tk_MainWindow(interp)) == NULL){ - return TCL_ERROR; - } - -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\tHeader check..."); -#endif - if (!ReadGIFHeader(f, &logicalWidth, &logicalHeight)) { - Tcl_AppendResult(interp, "couldn't read GIF header from file \"", - fileName, "\"", NULL); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "done "); -#endif - if ((logicalWidth <= 0) || (logicalHeight <= 0)) { - Tcl_AppendResult(interp, "GIF image file \"", fileName, - "\" has dimension(s) <= 0", (char *) NULL); - return TCL_ERROR; - } - - if (fread(buf, 1, 3, f) != 3) { - return TCL_OK; - } - bitPixel = 2<<(buf[0]&0x07); - colorResolution = (((buf[0]&0x70)>>3)+1); - background = buf[1]; - aspectRatio = buf[2]; - - if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */ - if (!ReadColorMap(f, bitPixel, colorMap)) { - Tcl_AppendResult(interp, "error reading color map", - (char *) NULL); - return TCL_ERROR; - } - } - -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\tReading frames "); - prevpos = ftell(f); -#endif - sprintf( widthbuf, "%d ", logicalWidth); - sprintf( heightbuf, "%d ", logicalHeight); - - Tcl_DStringInit(&resultbuf); - Tcl_DStringAppend(&resultbuf, widthbuf, -1); - Tcl_DStringAppend(&resultbuf, " ", -1); - Tcl_DStringAppend(&resultbuf, heightbuf, -1); - Tcl_DStringAppend(&resultbuf, " ", -1); - Tcl_DStringAppend(&resultbuf, "{", -1); - - while (1) { - if (fread(buf, 1, 1, f) != 1) { - /* - * Premature end of image. We should really notify - * the user, but for now just show garbage. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "Premature end of image"); -#endif - - break; - } - - if (buf[0] == ';') { - /* - * GIF terminator. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, ";"); - prevpos = ftell(f); -#endif - - break; - } - - if (buf[0] == '!') { - /* - * This is a GIF extension. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "!"); - prevpos = ftell(f); -#endif - - if (fread(buf, 1, 1, f) != 1) { - Tcl_AppendResult( interp, - "error reading extension function code in GIF image", NULL ); -/* - interp->result = - "error reading extension function code in GIF image"; -*/ - goto error; - } - if (DoExtension(f, buf[0], &transparent, &delay, &loop) < 0) { - Tcl_AppendResult( interp, - "error reading extension in GIF image", NULL ); -/* - interp->result = "error reading extension in GIF image"; -*/ goto error; - } - continue; - } - - if (buf[0] == '\0') { - /* - * Not a valid start character; ignore it. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "0", buf[0]); - prevpos = ftell(f); -#endif - continue; - } - - if (buf[0] != ',') { - /* - * Not a valid start character; ignore it. - */ -#ifdef TKANIM_DEBUG - fprintf(stderr, "?(%c)", buf[0]); - prevpos = ftell(f); -#endif - continue; - } - - if (fread(buf, 1, 9, f) != 9) { - Tcl_AppendResult( interp, - "couldn't read left/top/width/height in GIF image", NULL ); -/* - interp->result = "couldn't read left/top/width/height in GIF image"; -*/ - goto error; - } - - useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP); - - bitPixel = 1<<((buf[8]&0x07)+1); - - imageLeftPos= LM_to_uint(buf[0], buf[1]); - imageTopPos= LM_to_uint(buf[2], buf[3]); - imageWidth= LM_to_uint(buf[4], buf[5]); - imageHeight= LM_to_uint(buf[6], buf[7]); - - block.width = imageWidth; - block.height = imageHeight; - block.pixelSize = 3; - block.pitch = 3 * imageWidth; - block.offset[0] = 0; - block.offset[1] = 1; - block.offset[2] = 2; - block.offset[3] = 3; - nBytes = imageHeight * block.pitch; - block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); - - sprintf(widthbuf, "%d", imageWidth); - sprintf(heightbuf, "%d", imageHeight); - - /* save result */ - - { -#if (TK_MAJOR_VERSION >= 8 && TK_MINOR_VERSION >= 1) - Tcl_Obj *argv[7]; - int i; - - argv[0] = Tcl_NewStringObj("image", -1); - argv[1] = Tcl_NewStringObj("create", -1); - argv[2] = Tcl_NewStringObj("photo", -1); - argv[3] = Tcl_NewStringObj("-width", -1); - argv[4] = Tcl_NewStringObj(widthbuf, -1); - argv[5] = Tcl_NewStringObj("-height", -1); - argv[6] = Tcl_NewStringObj(heightbuf, -1); - - for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); } - - if( Tk_ImageObjCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> - -height <imageHeight>" */ - 7, argv) == TCL_ERROR ){ - return TCL_ERROR; - } - - for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); } - -#else - char *argv[7] = {"image", "create", "photo", "-width", NULL, - "-height", NULL}; - argv[4] = widthbuf; - argv[6] = heightbuf; -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)", - argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); -#endif - if( Tk_ImageCmd((ClientData) winPtr, interp, - /* "image create photo -width <imageWidth> - -height <imageHeight>" */ - 7, argv) == TCL_ERROR ){ - return TCL_ERROR; - } -#endif - -#ifdef TKANIM_DEBUG - fprintf(stderr, " done "); -#endif - } - - imageName = interp->result; -#if (TK_MAJOR_VERSION < 8) - photoHandle = Tk_FindPhoto(interp->result); -#else - photoHandle = Tk_FindPhoto(interp, interp->result); -#endif - if (!useGlobalColormap) { - if (!ReadColorMap(f, bitPixel, localColorMap)) { - Tcl_AppendResult(interp, "error reading color map", - (char *) NULL); - goto error; - } - if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, - imageHeight, localColorMap, BitSet(buf[8], INTERLACE), - transparent) != TCL_OK) { - goto error; - } - } else { - if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth, - imageHeight, colorMap, BitSet(buf[8], INTERLACE), - transparent) != TCL_OK) { - goto error; - } - } - Tk_PhotoPutBlock( -#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 5 || TK_MAJOR_VERSION > 8) - NULL, -#endif -photoHandle, &block, 0, 0, imageWidth, imageHeight -#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) - , TK_PHOTO_COMPOSITE_SET -#endif - ); -#ifdef TKANIM_DEBUG - fprintf(stderr, " Retrieving result\n"); -#endif - /* retrieve result */ - sprintf(newresbuf, "{%s %d %d %d %d %d} ", - imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos, - delay); -#ifdef TKANIM_DEBUG - fprintf(stderr, " newresbuf = %s\n", newresbuf); -#endif - ckfree((char *) block.pixelPtr); -#ifdef TKANIM_DEBUG - fprintf(stderr, " free done (now append result)"); -#endif - Tcl_DStringAppend( &resultbuf, newresbuf, -1 ); -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\t\tFrame done (%d)", ftell(f) - prevpos); - prevpos = ftell(f); -#endif - } - sprintf( widthbuf, "%d", loop ); - Tcl_DStringAppend( &resultbuf, "} ", -1 ); - resultptr = Tcl_DStringAppend( &resultbuf, widthbuf, -1 ); -#ifdef TKANIM_DEBUG - fprintf(stderr, "\nResult = %s\n", resultptr); -#endif - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, resultptr, NULL); - Tcl_DStringFree(&resultbuf); - return TCL_OK; - - error: - Tcl_DStringFree(&resultbuf); - ckfree((char *) block.pixelPtr); - return TCL_ERROR; - -} - -static int -DoExtension(fd, label, transparent, delay, loop) -FILE *fd; -int label; -int *transparent; -int *delay; -int *loop; -{ - static unsigned char buf[256]; - int count = 0; - - switch (label) { - case 0x01: /* Plain Text Extension */ - break; - - case 0xff: /* Application Extension */ - count = GetDataBlock(fd, (unsigned char*) buf); - if( count < 0){ - return 1; - } - if( !strncmp (buf, "NETSCAPE", 8) ) { - /* we ignore check of "2.0" */ - count = GetDataBlock (fd, (unsigned char*) buf); - if( count < 0){ - return 1; - } - if( buf[0] != 1 ){ - fprintf(stderr, "??? %d", buf[0]); - } - *loop = LM_to_uint(buf[1], buf[2]); - } - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - break; - - case 0xfe: /* Comment Extension */ - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - - case 0xf9: /* Graphic Control Extension */ - count = GetDataBlock(fd, (unsigned char*) buf); - if (count < 0) { - return 1; - } - if ((buf[0] & 0x1) != 0) { - *transparent = buf[3]; - } - - /* Delay time */ - *delay = LM_to_uint(buf[1],buf[2]); - - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; - } - - do { - count = GetDataBlock(fd, (unsigned char*) buf); - } while (count > 0); - return count; -} - -/* - *---------------------------------------------------------------------- - * - * ReadGIFHeader -- - * - * This procedure reads the GIF header from the beginning of a - * GIF file and returns the dimensions of the image. - * - * Results: - * The return value is 1 if file "f" appears to start with - * a valid GIF header, 0 otherwise. If the header is valid, - * then *widthPtr and *heightPtr are modified to hold the - * dimensions of the image. - * - * Side effects: - * The access position in f advances. - * - *---------------------------------------------------------------------- - */ - -static int -ReadGIFHeader(f, widthPtr, heightPtr) - FILE *f; /* Image file to read the header from */ - int *widthPtr, *heightPtr; /* The dimensions of the image are - * returned here. */ -{ - unsigned char buf[7]; - - if ((fread(buf, 1, 6, f) != 6) - || ((strncmp("GIF87a", (char *) buf, 6) != 0) - && (strncmp("GIF89a", (char *) buf, 6) != 0))) { - return 0; - } - - if (fread(buf, 1, 4, f) != 4) { - return 0; - } - - *widthPtr = LM_to_uint(buf[0],buf[1]); - *heightPtr = LM_to_uint(buf[2],buf[3]); - return 1; -} - -/* - *----------------------------------------------------------------- - * The code below is copied from the giftoppm program and modified - * just slightly. - *----------------------------------------------------------------- - */ - -static int -ReadColorMap(fd,number,buffer) -FILE *fd; -int number; -unsigned char buffer[3][MAXCOLORMAPSIZE]; -{ - int i; - unsigned char rgb[3]; - - for (i = 0; i < number; ++i) { - if (! ReadOK(fd, rgb, sizeof(rgb))) - return 0; - - buffer[CM_RED][i] = rgb[0] ; - buffer[CM_GREEN][i] = rgb[1] ; - buffer[CM_BLUE][i] = rgb[2] ; - } - return 1; -} - - - -static int ZeroDataBlock = 0; - -static int -GetDataBlock(fd, buf) -FILE *fd; -unsigned char *buf; -{ - unsigned char count; - - if (! ReadOK(fd,&count,1)) { - return -1; - } - - ZeroDataBlock = count == 0; - - if ((count != 0) && (! ReadOK(fd, buf, count))) { - return -1; - } - - return count; -} - - -static int -ReadImage(interp, imagePtr, fd, len, height, cmap, interlace, transparent) -Tcl_Interp *interp; -char *imagePtr; -FILE *fd; -int len, height; -unsigned char cmap[3][MAXCOLORMAPSIZE]; -int interlace; -int transparent; -{ - unsigned char c; - int v; - int xpos = 0, ypos = 0, pass = 0; - char *colStr; - - - /* - * Initialize the Compression routines - */ - if (! ReadOK(fd,&c,1)) { - Tcl_AppendResult(interp, "error reading GIF image: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - - if (LWZReadByte(fd, 1, c) < 0) { - interp->result = "format error in GIF image"; - return TCL_ERROR; - } - - if (transparent!=-1 && - (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) { - XColor *colorPtr; - colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), - Tk_GetUid(colStr)); - if (colorPtr) { -/* - printf("color is %d %d %d\n", - colorPtr->red >> 8, - colorPtr->green >> 8, - colorPtr->blue >> 8); -*/ - cmap[CM_RED][transparent] = colorPtr->red >> 8; - cmap[CM_GREEN][transparent] = colorPtr->green >> 8; - cmap[CM_BLUE][transparent] = colorPtr->blue >> 8; - Tk_FreeColor(colorPtr); - } - } - - while ((v = LWZReadByte(fd,0,c)) >= 0 ) { - - imagePtr[ (xpos*3) + (ypos *len*3)] = cmap[CM_RED][v]; - imagePtr[ (xpos*3) + (ypos *len*3) +1] = cmap[CM_GREEN][v]; - imagePtr[ (xpos*3) + (ypos *len*3) +2] = cmap[CM_BLUE][v]; - - ++xpos; - if (xpos == len) { - xpos = 0; - if (interlace) { - switch (pass) { - case 0: - case 1: - ypos += 8; break; - case 2: - ypos += 4; break; - case 3: - ypos += 2; break; - } - - if (ypos >= height) { - ++pass; - switch (pass) { - case 1: - ypos = 4; break; - case 2: - ypos = 2; break; - case 3: - ypos = 1; break; - default: - return TCL_OK; - } - } - } else { - ++ypos; - } - } - if (ypos >= height) - break; - } - return TCL_OK; -} - -static int -LWZReadByte(fd, flag, input_code_size) -FILE *fd; -int flag; -int input_code_size; -{ - static int fresh = 0; - int code, incode; - static int code_size, set_code_size; - static int max_code, max_code_size; - static int firstcode, oldcode; - static int clear_code, end_code; - static int table[2][(1<< MAX_LWZ_BITS)]; - static int stack[(1<<(MAX_LWZ_BITS))*2], *sp; - register int i; - - - if (flag) { - - set_code_size = input_code_size; - code_size = set_code_size+1; - clear_code = 1 << set_code_size ; - end_code = clear_code + 1; - max_code_size = 2*clear_code; - max_code = clear_code+2; - - GetCode(fd, 0, 1); - - fresh = 1; - - for (i = 0; i < clear_code; ++i) { - table[0][i] = 0; - table[1][i] = i; - } - for (; i < (1<<MAX_LWZ_BITS); ++i) { - table[0][i] = table[1][0] = 0; - } - - sp = stack; - - return 0; - - } else if (fresh) { - - fresh = 0; - do { - firstcode = oldcode = GetCode(fd, code_size, 0); - } while (firstcode == clear_code); - return firstcode; - } - - if (sp > stack) - return *--sp; - - while ((code = GetCode(fd, code_size, 0)) >= 0) { - if (code == clear_code) { - for (i = 0; i < clear_code; ++i) { - table[0][i] = 0; - table[1][i] = i; - } - - for (; i < (1<<MAX_LWZ_BITS); ++i) { - table[0][i] = table[1][i] = 0; - } - - code_size = set_code_size+1; - max_code_size = 2*clear_code; - max_code = clear_code+2; - sp = stack; - firstcode = oldcode = GetCode(fd, code_size, 0); - return firstcode; - - } else if (code == end_code) { - int count; - unsigned char buf[260]; - - if (ZeroDataBlock) - return -2; - - while ((count = GetDataBlock(fd, buf)) > 0) - ; - - if (count != 0) - return -2; - } - - incode = code; - - if (code >= max_code) { - *sp++ = firstcode; - code = oldcode; - } - - while (code >= clear_code) { - *sp++ = table[1][code]; - if (code == table[0][code]) { - return -2; - - fprintf(stderr, "circular table entry BIG ERROR\n"); - /* - * Used to be this instead, Steve Ball suggested - * the change to just return. - - printf("circular table entry BIG ERROR\n"); - */ - } - code = table[0][code]; - } - - *sp++ = firstcode = table[1][code]; - - if ((code = max_code) <(1<<MAX_LWZ_BITS)) { - - table[0][code] = oldcode; - table[1][code] = firstcode; - ++max_code; - if ((max_code>=max_code_size) && (max_code_size < (1<<MAX_LWZ_BITS))) { - max_code_size *= 2; - ++code_size; - } - } - - oldcode = incode; - - if (sp > stack) - return *--sp; - } - return code; -} - - -static int -GetCode(fd, code_size, flag) -FILE *fd; -int code_size; -int flag; -{ - static unsigned char buf[280]; - static int curbit, lastbit, done, last_byte; - int i, j, ret; - unsigned char count; - - if (flag) { - curbit = 0; - lastbit = 0; - done = 0; - return 0; - } - - - if ( (curbit+code_size) >= lastbit) { - if (done) { - /* ran off the end of my bits */ - return -1; - } - buf[0] = buf[last_byte-2]; - buf[1] = buf[last_byte-1]; - - if ((count = GetDataBlock(fd, &buf[2])) == 0) - done = 1; - - last_byte = 2 + count; - curbit = (curbit - lastbit) + 16; - lastbit = (2+count)*8 ; - } - - ret = 0; - for (i = curbit, j = 0; j < code_size; ++i, ++j) - ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; - - - curbit += code_size; - - return ret; -} - -int Tk_AnimationCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - char c; - int length; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg ...?\"", (char *) NULL); - return TCL_ERROR; - } - c = argv[1][0]; - length = strlen(argv[1]); - if((c == 'c') && (length >= 2) - && (strncmp(argv[1], "create", length) == 0)) { - - char * realFileName; - Tcl_DString buffer; - FILE *f; - -#ifdef TKANIM_DEBUG - fprintf(stderr, "AnimationCmd => create "); -#endif - - if ( argc != 3 ){ - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " create GifFile\"", (char *) NULL); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRealFileName = "); -#endif - realFileName = Tcl_TranslateFileName(interp, argv[2], - &buffer); - if(realFileName == NULL) { - Tcl_DStringFree(&buffer); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "%s ", realFileName); -#endif -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tOpen ", realFileName); -#endif - f = fopen(realFileName, "rb"); - Tcl_DStringFree(&buffer); - if (f == NULL ){ - Tcl_AppendResult(interp, "couldn't read image file \"", - argv[2], "\": ", Tcl_PosixError(interp), - (char *) NULL); - return TCL_ERROR; - } -#ifdef TKANIM_DEBUG - fprintf(stderr, "success ", realFileName); -#endif -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRead ", realFileName); -#endif - if( FileReadGIF(interp, f, argv[2], "gif") != TCL_OK ){ -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRead failed", realFileName); -#endif - return TCL_ERROR; - } - fclose(f); -#ifdef TKANIM_DEBUG - fprintf(stderr, "\n\tRead done", realFileName); -#endif -#ifdef TKANIM_DEBUG - fprintf(stderr, "done\n"); -#endif - } - return TCL_OK; -} - -void -TkDeleteTkAnim(clientData) - ClientData clientData; -{ -#ifdef TKANIM_DEBUG - fprintf(stderr, "TkDeleteTkAnim\n"); -#endif -} - -int Tkanim_Init(interp) - Tcl_Interp *interp; -{ -#ifdef TKANIM_DEBUG - fprintf(stderr, "Tkanim initialize..."); -#endif - Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd, - (ClientData) NULL, - (Tcl_CmdDeleteProc *) TkDeleteTkAnim); -#ifdef TKANIM_DEBUG - fprintf(stderr, "done\n"); -#endif - return Tcl_PkgProvide(interp, "Tkanim", TKANIM_VERSION ); -} diff --git a/otherlibs/labltk/tkanim/tkAppInit.c b/otherlibs/labltk/tkanim/tkAppInit.c deleted file mode 100644 index 09c943edf..000000000 --- a/otherlibs/labltk/tkanim/tkAppInit.c +++ /dev/null @@ -1,141 +0,0 @@ -/***********************************************************************/ -/* */ -/* MLTk, Tcl/Tk interface of Objective Caml */ -/* */ -/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique and Kyoto University. All rights reserved. */ -/* This file is distributed under the terms of the GNU Library */ -/* General Public License, with the special exception on linking */ -/* described in file LICENSE found in the Objective Caml source tree. */ -/* */ -/***********************************************************************/ -/* - * tkAppInit.c -- - * - * Provides a default version of the Tcl_AppInit procedure for - * use in wish and similar Tk-based applications. - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef lint -static char sccsid[] = "@(#) tkAppInit.c 1.19 95/12/23 17:09:24"; -#endif /* not lint */ - -#include "tk.h" - -int Tkanimation_Init _ANSI_ARGS_ ((Tcl_Interp *interp)); - -/* - * The following variable is a special hack that is needed in order for - * Sun shared libraries to be used for Tcl. - */ - -extern int matherr(); -int *tclDummyMathPtr = (int *) matherr; - -#ifdef TK_TEST -EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); -#endif /* TK_TEST */ - -/* - *---------------------------------------------------------------------- - * - * main -- - * - * This is the main program for the application. - * - * Results: - * None: Tk_Main never returns here, so this procedure never - * returns either. - * - * Side effects: - * Whatever the application does. - * - *---------------------------------------------------------------------- - */ - -int -main(argc, argv) - int argc; /* Number of command-line arguments. */ - char **argv; /* Values of command-line arguments. */ -{ - Tk_Main(argc, argv, Tcl_AppInit); - return 0; /* Needed only to prevent compiler warning. */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppInit -- - * - * This procedure performs application-specific initialization. - * Most applications, especially those that incorporate additional - * packages, will have their own version of this procedure. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. - * - * Side effects: - * Depends on the startup script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_AppInit(interp) - Tcl_Interp *interp; /* Interpreter for application. */ -{ - if (Tcl_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - if (Tk_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL); -#ifdef TK_TEST - if (Tktest_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif /* TK_TEST */ - - - /* - * Call the init procedures for included packages. Each call should - * look like this: - * - * if (Mod_Init(interp) == TCL_ERROR) { - * return TCL_ERROR; - * } - * - * where "Mod" is the name of the module. - */ - - if (Tkanim_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - - /* - * Call Tcl_CreateCommand for application-specific commands, if - * they weren't already created by the init procedures called above. - */ - - /* - * Specify a user-specific startup file to invoke if the application - * is run interactively. Typically the startup file is "~/.apprc" - * where "app" is the name of the application. If this line is deleted - * then no user-specific startup file will be run under any conditions. - */ - - Tcl_SetVar(interp, "tcl_rcFileName", "~/.tkanimationrc", TCL_GLOBAL_ONLY); - return TCL_OK; -} diff --git a/otherlibs/labltk/tkanim/tkanim.ml b/otherlibs/labltk/tkanim/tkanim.ml deleted file mode 100644 index 586d3569e..000000000 --- a/otherlibs/labltk/tkanim/tkanim.ml +++ /dev/null @@ -1,229 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -open Support -open Protocol -open Tkintf - -external init : unit -> unit = "tkanim_init" - -type gifFrame = { - imagephoto : imagePhoto; - frameWidth : int; - frameHeight : int; - left : int; - top : int; - delay : int - } - -type animatedGif = { - frames : gifFrame list; - animWidth : int; - animHeight : int; - loop : int -} - -type imageType = - | Still of Tk.options - | Animated of animatedGif - -let debug = ref false - -let cTKtoCAMLgifFrame s = - match splitlist s with - | [photo; width; height; left; top; delay] -> - {imagephoto = cTKtoCAMLimagePhoto photo; - frameWidth = int_of_string width; - frameHeight = int_of_string height; - left = int_of_string left; - top = int_of_string top; - delay = int_of_string delay} - | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s)) - -let cTKtoCAMLanimatedGif s = - match splitlist s with - | [width; height; frames; loop] -> - {frames = List.map cTKtoCAMLgifFrame (splitlist frames); - animWidth = int_of_string width; - animHeight = int_of_string height; - loop = int_of_string loop} - | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s)) - -(* check Tkanim package is in the interpreter *) -let available () = - let packages = - splitlist (Protocol.tkEval [| TkToken "package"; - TkToken "names" |]) - in - List.mem "Tkanim" packages - -let create file = - let s = - Protocol.tkEval [| TkToken "animation"; - TkToken "create"; - TkToken file |] - in - let anmgif = cTKtoCAMLanimatedGif s in - match anmgif.frames with - | [] -> raise (TkError "Null frame in a gif ?") - | [x] -> Still (ImagePhoto x.imagephoto) - | _ -> Animated anmgif - -let delete anim = - List.iter (fun {imagephoto = i} -> Imagephoto.delete i) anim.frames - -let width anm = anm.animWidth -let height anm = anm.animHeight -let images anm = List.map (fun x -> x.imagephoto) anm.frames - -let image_existence_check img = - (* I found there is a bug in Tk (even v8.0a2). *) - (* We can copy from deleted images, Tk never says "it doesn't exist", *) - (* But just do some operation. And sometimes it causes Seg-fault. *) - (* So, before using Imagephoto.copy, I should check the source image *) - (* really exists. *) - try ignore (Imagephoto.height img) with - TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s) - -let imagephoto_copy dst src opts = - image_existence_check src; - Imagephoto.copy dst src opts - -let animate_gen w i anim = - let length = List.length anim.frames in - let frames = Array.of_list anim.frames in - let current = ref 0 in - let loop = ref anim.loop in - let f = frames.(!current) in - imagephoto_copy i f.imagephoto - [ImgTo (f.left, f.top, f.left + f.frameWidth, - f.top + f.frameHeight)]; - let visible = ref true in - let animated = ref false in - let timer = ref None in - (* Loop *) - let display_current () = - let f = frames.(!current) in - imagephoto_copy i f.imagephoto - [ImgTo (f.left, f.top, - f.left + f.frameWidth, f.top + f.frameHeight)] - in - let rec tick () = - if not (Winfo.exists w && Winfo.viewable w) then begin - (* the widget is invisible. stop animation for efficiency *) - if !debug then prerr_endline "Stopped (Visibility)"; - visible := false; - end else - begin - display_current (); - let t = - Timer.add (if f.delay = 0 then 100 else f.delay * 10) - (fun () -> - incr current; - if !current = length then begin - current := 0; - (* loop check *) - if !loop > 1 then begin - decr loop; - if !loop = 0 then begin - if !debug then prerr_endline "Loop end"; - (* stop *) - loop := anim.loop; - timer := None - end - end - end; - tick ()) - in - timer := Some t - end - in - let start () = - animated := true; - tick () - in - let stop () = - match !timer with - | Some t -> - Timer.remove t; - timer := None; - animated := false - | None -> () - in - let next () = - if !timer = None then begin - incr current; - if !current = length then current := 0; - display_current () - end - in - (* We shouldn't delete the animation here. *) -(* - bind w [[], Destroy] - (BindSet ([], (fun _ -> Imagephoto.delete i))); -*) - bind w [[], Visibility] - (BindSet ([], (fun _ -> - if not !visible then begin - visible := true; - if !animated then start () - end))); - (function - | false -> - if !animated then stop () else start () - | true -> next ()) - -let animate label anim = - (* prerr_endline "animate"; *) - let i = Imagephoto.create [Width (Pixels anim.animWidth); - Height (Pixels anim.animHeight)] - in - bind label [[], Destroy] (BindExtend ([], (fun _ -> - Imagephoto.delete i))); - Label.configure label [ImagePhoto i]; - animate_gen label i anim - -let animate_canvas_item canvas tag anim = -(* prerr_endline "animate"; *) - let i = Imagephoto.create [Width (Pixels anim.animWidth); - Height (Pixels anim.animHeight)] - in - bind canvas [[], Destroy] (BindExtend ([], (fun _ -> - Imagephoto.delete i))); - Canvas.configure_image canvas tag [ImagePhoto i]; - animate_gen canvas i anim - -let gifdata s = - let tmp_dir = ref Filename.temp_dir_name in - let mktemp = - let cnter = ref 0 - and pid = Unix.getpid() in - (function prefx -> - incr cnter; - (Filename.concat !tmp_dir - (prefx ^ string_of_int pid ^ "." ^ string_of_int !cnter))) - in - let fname = mktemp "gifdata" in - let oc = open_out_bin fname in - try - output_string oc s; - close_out oc; - let anim = create fname in - Unix.unlink fname; - anim - with - e -> begin Unix.unlink fname; raise e end diff --git a/otherlibs/labltk/tkanim/tkanim.mli b/otherlibs/labltk/tkanim/tkanim.mli deleted file mode 100644 index 1d1a7f99a..000000000 --- a/otherlibs/labltk/tkanim/tkanim.mli +++ /dev/null @@ -1,95 +0,0 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) -open Camltk -open Widget -open Support - -(*** Data types ***) - -type animatedGif - - (* This data type contains all the information of an animation of - gif89a format. It is still test implementation, so I should - keep it abstract. --- JPF *) - -type imageType = - | Still of Tk.options - | Animated of animatedGif - - (* This data type is required to distinguish normal still images - and animated gifs. Usually objects typed imagePhoto or - imageBitmap are used for Still. *) - -(*** Flags ***) - -val debug : bool ref - -(*** Library availability check ***) - -val init : unit -> unit - - (* This function calls the initialization function for Tkanim - Tcl/Tk extension. *) - -val available : unit -> bool - - (* [available ()] returns true if there is Tkanim Tcl/Tk - extension linked statically/dynamically in Tcl/Tk - interpreter. Otherwise, return false. *) - -(*** User interface ***) - -(* create is unsafe *) -val create : string -> imageType - - (* [create file] loads a gif87 or gif89 image file and parse it, - and returns [Animated animated_gif] if the image file has - more than one images. Otherwise, it returns - [Still (ImagePhoto image_photo)] *) - -val delete : animatedGif -> unit - - (* [delete anim] deletes all the images in anim. Usually - animatedGifs contain many images, so you must not forget to - use this function to free the memory. *) - -val width : animatedGif -> int -val height : animatedGif -> int - (* [width anim] and [height anim] return the width and height of - given animated gif. *) - -val images : animatedGif -> imagePhoto list - (* [images anim] returns the list of still images used in the - animation *) - -val animate : widget -> animatedGif -> bool -> unit -val animate_canvas_item : widget -> tagOrId -> animatedGif -> bool -> unit - (* The display functions for animated gifs. Since [animatedGif] is - an abstract type, you must use those functions to display - [animatedGif] images. - [animate label anim] and [animate_canvas_item canvas tag anim] - display animation [anim] on a label widget [label] or an - image tag [tag] on a canvas widget [canvas] respectively. - - Note that animation is stopped by default. - These functions return interface functions, say, [inter : - bool -> unit]. Currently, [inter false] toggles start/stop of - the animation, and [inter true] displays the next frame of - the animation if the animation is stopped. *) - -val gifdata : string -> imageType - (* [gifdata data] reads [data] as a row data of a gif file and - decodes it. *) |
