diff options
220 files changed, 13053 insertions, 1967 deletions
diff --git a/otherlibs/labltk/Changes b/otherlibs/labltk/Changes new file mode 100644 index 000000000..bd671fdb6 --- /dev/null +++ b/otherlibs/labltk/Changes @@ -0,0 +1,13 @@ +version 1.0a1 + +General Changes +* Merging CamlTk and LablTk API interfaces +* Activate and Deactivate Events are added +* Virtual events support +* Added UTF conversion + +Incompatibilities between the previous camltk/labltk versions +* CamlTk's bind_tag and bind_class superseded tag_bind and class_bind. +* added optional arguments to some functions of CamlTk. +* The library name libfrx and libjpf are changed to frxlib and jpflib + respectively, to avoid the library name confusion. diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile index 1ba69dd0d..6fe24eb78 100644 --- a/otherlibs/labltk/Makefile +++ b/otherlibs/labltk/Makefile @@ -1,38 +1,70 @@ -# Top Makefile for LablTk +# Top Makefile for mlTk -SUBDIRS=compiler support lib jpf example browser +SUBDIRS=compiler support lib labltk camltk jpf frx tkanim examples_labltk examples_camltk browser all: cd support; $(MAKE) cd compiler; $(MAKE) - cd lib; $(MAKE) -f Makefile.gen; $(MAKE) + cd labltk; $(MAKE) -f Makefile.gen + cd labltk; $(MAKE) + cd camltk; $(MAKE) -f Makefile.gen + cd camltk; $(MAKE) + cd lib; $(MAKE) cd jpf; $(MAKE) + cd frx; $(MAKE) + cd tkanim; $(MAKE) cd browser; $(MAKE) allopt: cd support; $(MAKE) opt - cd lib; $(MAKE) -f Makefile.gen; $(MAKE) opt + cd labltk; $(MAKE) -f Makefile.gen + cd labltk; $(MAKE) opt + cd camltk; $(MAKE) -f Makefile.gen + cd camltk; $(MAKE) opt + cd lib; $(MAKE) opt cd jpf; $(MAKE) opt + cd frx; $(MAKE) opt + cd tkanim; $(MAKE) opt -lib: Widgets.src - compiler/tkcompiler - cd lib; $(MAKE) +byte: all +opt: allopt + +.PHONY: labltk camltk examples_labltk examples_camltk + +labltk: Widgets.src + compiler/tkcompiler -outdir labltk + cd labltk; $(MAKE) + +camltk: Widgets.src + compiler/tkcompiler -camltk -outdir camltk + cd camltk; $(MAKE) + +examples: examples_labltk examples_camltk -example: example/all +examples_labltk: + cd examples_labltk; $(MAKE) all -example/all: - cd example; $(MAKE) all +examples_camltk: + cd examples_camltk; $(MAKE) all install: + cd labltk; $(MAKE) install + cd camltk; $(MAKE) install cd lib; $(MAKE) install cd support; $(MAKE) install cd compiler; $(MAKE) install cd jpf; $(MAKE) install + cd frx; $(MAKE) install + cd tkanim; $(MAKE) install cd browser; $(MAKE) install installopt: + cd labltk; $(MAKE) installopt + cd camltk; $(MAKE) installopt cd lib; $(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/Makefile.nt b/otherlibs/labltk/Makefile.nt index 73530676d..c5e979a06 100644 --- a/otherlibs/labltk/Makefile.nt +++ b/otherlibs/labltk/Makefile.nt @@ -2,39 +2,58 @@ !include ..\..\config\Makefile.nt -SUBDIRS=compiler support lib jpf browser +SUBDIRS=compiler support lib labltk camltk jpf frx tkanim examples_labltk examples_camltk browser all: cd support & $(MAKEREC) cd compiler & $(MAKEREC) - cd lib & $(MAKE) -nologo -f Makefile.gen.nt & $(MAKEREC) + cd labltk & $(MAKE) -nologo -f Makefile.gen.nt + cd labltk & $(MAKEREC) + cd camltk & $(MAKE) -nologo -f Makefile.gen.nt + cd camltk & $(MAKEREC) + cd lib & $(MAKEREC) cd jpf & $(MAKEREC) + cd frx & $(MAKEREC) + cd tkanim & $(MAKEREC) cd browser & $(MAKEREC) allopt: cd support & $(MAKEREC) opt - cd lib & $(MAKE) -nologo -f Makefile.gen.nt & $(MAKEREC) opt + cd labltk & $(MAKE) -nologo -f Makefile.gen.nt + cd labltk & $(MAKEREC) opt + cd camltk & $(MAKE) -nologo -f Makefile.gen.nt + cd camltk & $(MAKEREC) opt + cd lib & $(MAKEREC) opt cd jpf & $(MAKEREC) opt + cd frx & $(MAKEREC) opt + cd tkanim & $(MAKEREC) opt -lib: Widgets.src - compiler/tkcompiler - cd lib & $(MAKEREC) +example: examples_labltk/all examples_camltk/all -example: example/all +examples_labltk/all: + cd examples_labltk & $(MAKEREC) all -example/all: - cd example & $(MAKEREC) all +examples_camltk/all: + cd examples_camltk & $(MAKEREC) all install: + cd labltk & $(MAKEREC) install + cd camltk & $(MAKEREC) install cd lib & $(MAKEREC) install cd support & $(MAKEREC) install cd compiler & $(MAKEREC) install cd jpf & $(MAKEREC) install + cd frx & $(MAKEREC) install + cd tkanim & $(MAKEREC) install cd browser & $(MAKEREC) install installopt: + cd labltk & $(MAKEREC) installopt + cd camltk & $(MAKEREC) installopt cd lib & $(MAKEREC) installopt cd jpf & $(MAKEREC) installopt + cd frx & $(MAKEREC) installopt + cd tkanim & $(MAKEREC) installopt partialclean clean: for %d in ($(SUBDIRS)) do (cd %d & $(MAKEREC) clean & cd ..) diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README index 102b0fd82..cb9b8b8ab 100644 --- a/otherlibs/labltk/README +++ b/otherlibs/labltk/README @@ -1,25 +1,152 @@ -LablTk41 is a library for interfacing Objective Labl with the scripting -language Tcl/Tk (all versions since 7.5/4.1, but no betas). +INTRODUCTION +============ +mlTk is a library for interfacing Objective Caml with the scripting +language Tcl/Tk (all versions since 8.0.3, but no betas). In addition to the basic interface with Tcl/Tk, this package contains - * the LablBrowser code editor / library browser written by Jacques + * the OCamlBrowser code editor / library browser written by Jacques Garrigue. * the "jpf" library, written by Jun P. Furuse; it contains a "file selector" and "balloon help" support - + * the "frx" library, written by Francois Rouaix + * the "tkanim" library, which supports animated gif loading/display + +mlTk = CamlTk + LablTk +====================== +There existed two parallel Tcl/Tk interfaces for O'Caml, CamlTk and LablTk. + +CamlTk uses classical features only, therefore it is easy to understand for +the beginners of ML. It makes many conservative O'Caml gurus also happy. +LablTk, on the other hand, uses rather newer features of O'Caml, the labeled +optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk +script flavor, but provides more powerful typing than CamlTk at the same time +(i.e. less run time type checking of widgets). +Until now, these two interfaces have been distributed and maintained +independently. -REQUIREMENTS: +mlTk unifies these libraries into one. Since mlTk provides the both API's, +both CamlTk and LablTk users can compile their applications with mlTk, +just with little fixes. + +REQUIREMENTS +============ You must have already installed - * Objective Label 2.02 Summer edition - http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/ + * Objective Caml source, version 3.04+8 or later - * Tcl7.5/Tk4.1 through Tcl/Tk8.2 + * Tcl/Tk 8.0.3 or later http://www.scriptics.com/ or various mirrors PLATFORMS: Essentially any Unix/X Window System platform. We have tested releases on Linux (ELF x86), FreeBSD (x86), SunOS4.1.x (sparc), DEC -OSF/1 V4.0 (alpha), DGUX SVR4 (m88k). We have not attempted to -compile this package on Windows. +OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin). + +INSTALLATION +============ + +0. Check-out the O'Caml CVS source code tree. + +1. Compile O'Caml (= make world). If you want, also make opt. + +2. Untar this mlTk distribution in the otherlibs directory, just like + the labltk source tree. + +3. change directory to otherlibs/mltk, and make (and make opt) + +4. To install the library, make install (and make installopt) + +To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser +requires some modules of O'Caml. If you are not interested in camlbrowser, +you can compile mlTk without the O'Caml source tree, but you have to modify +support/Makefile.common. + + +Compile your CamlTk/LablTk applications with mlTk +================================================= + +* General + +The names of the additional libraries libjpf and libfrx are changed +to jpflib and frxlib respectively, to avoid the library name space confusion. + +* LablTk users + +Just change the occurrences of labltk in your Makefiles to mltk +(i.e. -I +labltk => -I +mltk, labltk.cma => mltk.cma, and so on) +Since the API functions are 100% compatible, you need not to change +your .ml files. + +* CamlTk users + + - Makefiles : apply the same modification explained above for LablTk users. + + - open Camltk : The API modules and functions are stored in the modules + Camltk. Therefore you need to replace the module name Tk to Camltk. + For example, open Tk => open Camltk. + + open Camltk (* instead of open Tk *) + + let t = openTk ();; + let b = Button.create t [];; + + - You may also need to open the Camltk module explicitly, when your + original module source contain no open Tk phrase. Widget and the other + Tcl/Tk related types are now under Camltk. (e.g. Widget.widget is now + Camltk.Widget.widget) Add open Camltk at the beginning of .mli files, + if these types are used: + + open Camltk (* added for compiling under mlTk *) + + val create_progress_bar : Widget.widget -> Widget.widget + + - Eta expansion to flush optional arguments at registering callbacks. + Functions with the _displayof suffix are unified with their non-displayof + versions, using optional labeled arguments. For example, Bell.ring + had/have the following types: + + before: Bell.ring : unit -> unit + now: Bell.ring : ?displayof:Camltk.widget -> unit -> unit + + If you use these functions as callbacks directly like Command Bell.ring, + you need eta-expansions to flush these new optional arguments: + + Button.create w [Command Bell.ring] + + => Button.create w [Command (fun () -> Bell.ring ())] + +Use the both API's at the same time +=================================== +It is possible to use the both API's in one program. If you want to use +a widget library written in the different API from you use, you need to +do it. (It will be confusing, but easier than porting the library itself +from one to the other API.) + +For the users who mainly use LablTk API, CamlTk API is available +in the modules start with 'C'. For example, the source file of +the CamlTk button widget functions is CButton (and exported also as +Camltk.Button). + +For the users who mainly use CamlTk API, LablTk API modules are exported +inside Labltk module. For example, LablTk's Button module can be also +accessible as Labltk.Button. + +In CamlTk, we have only one widget type, [widget]. This type is equivalent +to the LablTk's type [any widget]. Therefore, if you want to apply CamlTk +functions to LablTk widget, you can use [coe] function to coerce it to +[any widget]. + +To do the converse, the "widget-typers" are available inside the module Labltk. +For example, to recover the type of a button widget, use Labltk.button. +These widget-typers checks the types of widgets at run-time. If the widget +type is different from the context type, a run-time exception is raised. + + open Tk (* open LablTk API *) + + let t = openTk ();; (* t is LablTk widget, toplevel widget *) + (* CButton.create takes [any widget]; [t] must be coerced to the type. *) + let caml_b = CButton.create (coe t) [];; + (* caml_b is [any widget], must be explicitly typed as [button widget], + when it is used with LablTk API functions *) + let b = Labltk.button caml_b in (* recover the type [button widget] *) + ... -See the INSTALL file for installation instructions. diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src index d1c7ad1bd..458c5eaa2 100644 --- a/otherlibs/labltk/Widgets.src +++ b/otherlibs/labltk/Widgets.src @@ -1,24 +1,35 @@ -############## Standard Tk4.1 Widgets and functions ############## +%%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%% type Widget external -# cget will probably never be implemented with verifications +% cget will probably never be implemented with verifications function (string) cgets [widget; "cget"; string] -# another version with some hack is +% another version with some hack is type options_constrs external function (string) cget [widget; "cget"; options_constrs] -# constructors of type options_constrs are of the form C<c> -# where <c> is an option constructor (e.g. CBackground) +% constructors of type options_constrs are of the form C<c> +% where <c> is an option constructor (e.g. CBackground) -##### Some types for standard options of widgets +%%%%% Some types for standard options of widgets type Anchor { NW ["nw"] N ["n"] NE ["ne"] W ["w"] Center ["center"] E ["e"] SW ["sw"] S ["s"] SE ["se"] } -type Bitmap external # builtin_GetBitmap.ml -type Cursor external # builtin_GetCursor.ml -type Color external # builtin_GetCursor.ml +type Bitmap external % builtin_GetBitmap.ml +type Cursor external % builtin_GetCursor.ml +type Color external % builtin_GetCursor.ml + +##ifdef CAMLTK + +type ImageBitmap { + BitmapImage [string] + } +type ImagePhoto { + PhotoImage [string] + } + +##else variant type ImageBitmap { Bitmap [string] @@ -31,6 +42,8 @@ variant type Image { Photo [string] } +##endif + type Justification { Justify_Left ["left"] Justify_Center ["center"] @@ -50,95 +63,101 @@ type Relief { Groove ["groove"] } -type TextVariable external # textvariable.ml -type Units external # builtin_GetPixel.ml +type TextVariable external % textvariable.ml +type Units external % builtin_GetPixel.ml -##### The standard options, as defined in man page options(n) -##### The subtype is never used +%%%%% The standard options, as defined in man page options(n) +%%%%% The subtype is never used subtype option(standard) { ActiveBackground ["-activebackground"; Color] - ActiveBorderWidth ["-activeborderwidth"; int] + ActiveBorderWidth ["-activeborderwidth"; Units/int] ActiveForeground ["-activeforeground"; Color] Anchor ["-anchor"; Anchor] Background ["-background"; Color] Bitmap ["-bitmap"; Bitmap] - BorderWidth ["-borderwidth"; int] + BorderWidth ["-borderwidth"; Units/int] Cursor ["-cursor"; Cursor] DisabledForeground ["-disabledforeground"; Color] ExportSelection ["-exportselection"; bool] Font ["-font"; string] Foreground ["-foreground"; Color] - Geometry ["-geometry"; string] # Too variable to encode +% Geometry is not one of standard options... + Geometry ["-geometry"; string] % Too variable to encode HighlightBackground ["-highlightbackground"; Color] HighlightColor ["-highlightcolor"; Color] - HighlightThickness ["-highlightthickness"; int] + HighlightThickness ["-highlightthickness"; Units/int] +##ifdef CAMLTK + % images are split, to do additionnal static typing + ImageBitmap (ImageBitmap) ["-image"; ImageBitmap] + ImagePhoto (ImagePhoto) ["-image"; ImagePhoto] +##else Image ["-image"; Image] -# it is old # images are split, to do additionnal static typing -# ImageBitmap (ImageBitmap) ["-image"; ImageBitmap] -# ImagePhoto (ImagePhoto) ["-image"; ImagePhoto] +##endif InsertBackground ["-insertbackground"; Color] - InsertBorderWidth ["-insertborderwidth"; int] - InsertOffTime ["-insertofftime"; int] # Positive only - InsertOnTime ["-insertontime"; int] # Idem - InsertWidth ["-insertwidth"; int] + InsertBorderWidth ["-insertborderwidth"; Units/int] + InsertOffTime ["-insertofftime"; int] % Positive only + InsertOnTime ["-insertontime"; int] % Idem + InsertWidth ["-insertwidth"; Units/int] Jump ["-jump"; bool] Justify ["-justify"; Justification] Orient ["-orient"; Orientation] - PadX ["-padx"; int] - PadY ["-pady"; int] + PadX ["-padx"; Units/int] + PadY ["-pady"; Units/int] Relief ["-relief"; Relief] RepeatDelay ["-repeatdelay"; int] RepeatInterval ["-repeatinterval"; int] SelectBackground ["-selectbackground"; Color] - SelectBorderWidth ["-selectborderwidth"; int] + SelectBorderWidth ["-selectborderwidth"; Units/int] SelectForeground ["-selectforeground"; Color] SetGrid ["-setgrid"; bool] - # incomplete description of TakeFocus + % incomplete description of TakeFocus TakeFocus ["-takefocus"; bool] Text ["-text"; string] TextVariable ["-textvariable"; TextVariable] TroughColor ["-troughcolor"; Color] UnderlinedChar ["-underline"; int] - WrapLength ["-wraplength"; int] - # Major incompatibility with Tk3.6 where it was function(int,int,int,int) + WrapLength ["-wraplength"; Units/int] XScrollCommand ["-xscrollcommand"; function(first:float, last:float)] YScrollCommand ["-yscrollcommand"; function(first:float, last:float)] } -#### Some other common types -type Index external # builtin_index.ml -type sequence ScrollValue external # builtin_ScrollValue.ml -# type sequence ScrollValue { -# MoveTo ["moveto"; float] -# ScrollUnit ["scroll"; int; "unit"] -# ScrollPage ["scroll"; int; "page"] -# } +%%%% Some other common types +type Index external % builtin_index.ml +type sequence ScrollValue external % builtin_ScrollValue.ml +% type sequence ScrollValue { +% MoveTo ["moveto"; float] +% ScrollUnit ["scroll"; int; "unit"] +% ScrollPage ["scroll"; int; "page"] +% } -##### bell(n) +%%%%% bell(n) module Bell { +##ifdef CAMLTK + function () ring ["bell"; ?displayof:["-displayof"; widget]] + function () ring_displayof ["bell"; "-displayof" ; displayof: widget] +##else function () ring ["bell"; ?displayof:["-displayof"; widget]] -# function () ring ["bell"] -# function () ring_displayof ["bell"; "-displayof" ; displayof: widget] +##endif } -##### bind(n) -# builtin_bind.ml +%%%%% bind(n) +% builtin_bind.ml -##### bindtags(n) -#type Bindings { -# TagBindings [string] -# WidgetBindings [widget] -# } +%%%%% bindtags(n) +%type Bindings { +% TagBindings [string] +% WidgetBindings [widget] +% } type Bindings external function () bindtags ["bindtags"; widget; [bindings: Bindings list]] function (Bindings list) bindtags_get ["bindtags"; widget] -##### bitmap(n) +%%%%% bitmap(n) subtype option(bitmapimage) { Background Data ["-data"; string] @@ -150,15 +169,19 @@ subtype option(bitmapimage) { module Imagebitmap { function (ImageBitmap) create ["image"; "create"; "bitmap"; ?name:[ImageBitmap]; option(bitmapimage) list] - function () configure [ImageBitmap; "configure"; option(bitmapimage) list] - function (string) configure_get [ImageBitmap; "configure"] - # Functions inherited from the "image" TK class +##ifdef CAMLTK + function (ImageBitmap) create_named ["image"; "create"; "bitmap"; ImageBitmap; option(bitmapimage) list] +##endif function () delete ["image"; "delete"; ImageBitmap] function (int) height ["image"; "height"; ImageBitmap] function (int) width ["image"; "width"; ImageBitmap] + function () configure [ImageBitmap; "configure"; option(bitmapimage) list] + function (string) configure_get [ImageBitmap; "configure"] + % Functions inherited from the "image" TK class } -##### button(n) +%%%%% button(n) + type State { Normal ["normal"] Active ["active"] @@ -166,7 +189,7 @@ type State { } widget button { - # Standard options + % Standard options option ActiveBackground option ActiveForeground option Anchor @@ -180,9 +203,12 @@ widget button { option HighlightBackground option HighlightColor option HighlightThickness +##ifdef CAMLTK + option ImageBitmap + option ImagePhoto +##else option Image -# option ImageBitmap -# option ImagePhoto +##endif option Justify option PadX option PadY @@ -192,11 +218,12 @@ widget button { option TextVariable option UnderlinedChar option WrapLength - # Widget specific options + % Widget specific options option Command ["-command"; function ()] - option Height ["-height"; int] + option Default ["-default"; State] + option Height ["-height"; Units/int] option State ["-state"; State] - option Width ["-width"; int] + option Width ["-width"; Units/int] function () configure [widget(button); "configure"; option(button) list] function (string) configure_get [widget(button); "configure"] @@ -205,26 +232,26 @@ widget button { } -###### canvas(n) -# Item ids and tags +%%%%%% canvas(n) +% Item ids and tags type TagOrId { Tag [string] Id [int] } -# Indices: defined internally -# subtype Index(canvas) { -# Number End Insert SelFirst SelLast AtXY -# } +% Indices: defined internally +% subtype Index(canvas) { +% Number End Insert SelFirst SelLast AtXY +% } type SearchSpec { Above ["above"; TagOrId] All ["all"] Below ["below"; TagOrId] - Closest ["closest"; int; int] - ClosestHalo (Closesthalo) ["closest"; int; int; int] - ClosestHaloStart (Closesthalostart) ["closest"; int; int; int; TagOrId] - Enclosed ["enclosed"; int;int;int;int] + Closest ["closest"; Units/int; Units/int] + ClosestHalo (Closesthalo) ["closest"; Units/int; Units/int; Units/int] + ClosestHaloStart (Closesthalostart) ["closest"; Units/int; Units/int; Units/int; TagOrId] + Enclosed ["enclosed"; Units/int;Units/int;Units/int;Units/int] Overlapping ["overlapping"; int;int;int;int] Withtag ["withtag"; TagOrId] } @@ -236,25 +263,25 @@ type ColorMode { } subtype option(postscript) { - # Cannot support this without array variables - # Colormap ["-colormap"; TextVariable] + % Cannot support this without array variables + % Colormap ["-colormap"; TextVariable] Colormode ["-colormode"; ColorMode] File ["-file"; string] - # Fontmap ["-fontmap"; TextVariable] + % Fontmap ["-fontmap"; TextVariable] Height PageAnchor ["-pageanchor"; Anchor] - PageHeight ["-pageheight"; int] - PageWidth ["-pagewidth"; int] - PageX ["-pagex"; int] - PageY ["-pagey"; int] + PageHeight ["-pageheight"; Units/int] + PageWidth ["-pagewidth"; Units/int] + PageX ["-pagex"; Units/int] + PageY ["-pagey"; Units/int] Rotate ["-rotate"; bool] Width - X ["-x"; int] - Y ["-y"; int] + X ["-x"; Units/int] + Y ["-y"; Units/int] } -# Arc item configuration +% Arc item configuration type ArcStyle { Arc ["arc"] Chord ["chord"] @@ -263,18 +290,19 @@ type ArcStyle { subtype option(arc) { Extent ["-extent"; float] - # Fill is used by packer + Dash ["-dash"; string] + % Fill is used by packer FillColor ["-fill"; Color] Outline ["-outline"; Color] OutlineStipple ["-outlinestipple"; Bitmap] Start ["-start"; float] Stipple ["-stipple"; Bitmap] ArcStyle ["-style"; ArcStyle] - Tags ["-tags"; [string list]] + Tags ["-tags"; [TagOrId/string list]] Width } -# Bitmap item configuration +% Bitmap item configuration subtype option(bitmap) { Anchor Background @@ -283,16 +311,19 @@ subtype option(bitmap) { Tags } -# Image item configuration +% Image item configuration subtype option(image) { Anchor +##ifdef CAMLTK + ImagePhoto + ImageBitmap +##else Image -# ImagePhoto -# ImageBitmap +##endif Tags } -# Line item configuration +% Line item configuration type ArrowStyle { Arrow_None ["none"] Arrow_First ["first"] @@ -314,8 +345,9 @@ type JoinStyle { subtype option(line) { ArrowStyle ["-arrow"; ArrowStyle] - ArrowShape ["-arrowshape"; [int; int; int]] + ArrowShape ["-arrowshape"; [Units/int; Units/int; Units/int]] CapStyle ["-capstyle"; CapStyle] + Dash FillColor JoinStyle ["-joinstyle"; JoinStyle] Smooth ["-smooth"; bool] @@ -325,35 +357,36 @@ subtype option(line) { Width } -# Oval item configuration +% Oval item configuration subtype option(oval) { - FillColor Outline Stipple Tags Width + Dash FillColor Outline Stipple Tags Width } -# Polygon item configuration +% Polygon item configuration subtype option(polygon) { - FillColor Outline Smooth SplineSteps + Dash FillColor Outline Smooth SplineSteps Stipple Tags Width } -# Rectangle item configuration +% Rectangle item configuration subtype option(rectangle) { - FillColor Outline Stipple Tags Width + Dash FillColor Outline Stipple Tags Width } -# Text item configuration +% Text item configuration subtype option(canvastext) { Anchor FillColor Font Justify Stipple Tags Text Width } -# Window item configuration +% Window item configuration subtype option(window) { Anchor Height Tags Width Window ["-window"; widget] + Dash } -# Types of items +% Types of items type CanvasItem { Arc_item ["arc"] Bitmap_item ["bitmap"] @@ -368,7 +401,7 @@ type CanvasItem { } widget canvas { - # Standard options + % Standard options option Background option BorderWidth option Cursor @@ -387,51 +420,71 @@ widget canvas { option TakeFocus option XScrollCommand option YScrollCommand - # Widget specific options + % Widget specific options option CloseEnough ["-closeenough"; float] option Confine ["-confine"; bool] - option Height ["-height"; int] - option ScrollRegion ["-scrollregion"; [int;int;int;int]] - option Width ["-width"; int] - option XScrollIncrement ["-xscrollincrement"; int] - option YScrollIncrement ["-yscrollincrement"; int] + option Height ["-height"; Units/int] + option ScrollRegion ["-scrollregion"; [Units/int;Units/int;Units/int;Units/int]] + option Width ["-width"; Units/int] + option XScrollIncrement ["-xscrollincrement"; Units/int] + option YScrollIncrement ["-yscrollincrement"; Units/int] - function () addtag [widget(canvas); "addtag"; tag: string; specs: SearchSpec list] # Tag only - # bbox not fully supported. should be builtin because of ambiguous result - # will raise protocol__TkError if no items match TagOrId + function () addtag [widget(canvas); "addtag"; tag: TagOrId/string; specs: SearchSpec list] % Tag only + % bbox not fully supported. should be builtin because of ambiguous result + % will raise Protocol.TkError if no items match TagOrId function (int,int,int,int) bbox [widget(canvas); "bbox"; TagOrId list] external bind "builtin/canvas_bind" +##ifdef CAMLTK + function (float) canvasx [widget(canvas); "canvasx"; ?spacing:[Units]; Units] + function (float) canvasy [widget(canvas); "canvasy"; ?spacing:[Units]; Units] + function (float) canvasx_grid [widget(canvas); "canvasx"; Units; Units] + function (float) canvasy_grid [widget(canvas); "canvasy"; Units; Units] +##else function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]] function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]] +##endif function () configure [widget(canvas); "configure"; option(canvas) list] function (string) configure_get [widget(canvas); "configure"] - # TODO: check result + % TODO: check result function (float list) coords_get [widget(canvas); "coords"; TagOrId] +##ifdef CAMLTK + function () coords_set [widget(canvas); "coords"; TagOrId; xys: Units list] +##else function () coords_set [widget(canvas); "coords"; TagOrId; xys: {int, int} list] - # create variations (see below) +##endif + % create variations (see below) function () dchars [widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)] function () delete [widget(canvas); "delete"; TagOrId list] - function () dtag [widget(canvas); "dtag"; TagOrId; tag: string] + function () dtag [widget(canvas); "dtag"; TagOrId; tag: TagOrId/string] function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list] - # focus variations + % focus variations function () focus_reset [widget(canvas); "focus"; ""] function (TagOrId) focus_get [widget(canvas); "focus"] function () focus [widget(canvas); "focus"; TagOrId] - function (string list) gettags [widget(canvas); "gettags"; TagOrId] + function (TagOrId/string list) gettags [widget(canvas); "gettags"; TagOrId] function () icursor [widget(canvas); "icursor"; TagOrId; index: Index(canvas)] function (int) index [widget(canvas); "index"; TagOrId; index: Index(canvas)] function () insert [widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string] + % itemcget, itemconfigure are defined later function () lower [widget(canvas); "lower"; TagOrId; ?below: [TagOrId]] - function () move [widget(canvas); "move"; TagOrId; x: int; y: int] +##ifdef CAMLTK + function () lower_below [widget(canvas); "lower"; TagOrId; TagOrId] + function () lower_bot [widget(canvas); "lower"; TagOrId] +##endif + function () move [widget(canvas); "move"; TagOrId; x: Units/int; y: Units/int] unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list] - # We use raise... with Module name + % We use raise with Module name function () raise [widget(canvas); "raise"; TagOrId; ?above:[TagOrId]] - function () scale [widget(canvas); "scale"; TagOrId; xorigin: int; yorigin: int; xscale: float; yscale: float] - # For scan, use x:int and y:int since common usage is with mouse coordinates +##ifdef CAMLTK + function () raise_above [widget(canvas); "raise"; TagOrId; TagOrId] + function () raise_top [widget(canvas); "raise"; TagOrId] +##endif + function () scale [widget(canvas); "scale"; TagOrId; xorigin: Units/int; yorigin: Units/int; xscale: float; yscale: float] + % For scan, use x:int and y:int since common usage is with mouse coordinates function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int] function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int] - # select variations + % select variations function () select_adjust [widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)] function () select_clear [widget(canvas); "select"; "clear"] function () select_from [widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)] @@ -444,16 +497,21 @@ widget canvas { function () xview [widget(canvas); "xview"; scroll: ScrollValue] function () yview [widget(canvas); "yview"; scroll: ScrollValue] - # create and configure variations - function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: int; y1: int; x2: int; y2: int; option(arc) list] - function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: int; y: int; option(bitmap) list] - function (TagOrId) create_image [widget(canvas); "create"; "image"; x: int; y: int; option(image) list] + % create and configure variations + function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(arc) list] + function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units/int; y: Units/int; option(bitmap) list] + function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units/int; y: Units/int; option(image) list] +##ifdef CAMLTK + function (TagOrId) create_line [widget(canvas); "create"; "line"; Units list; option(line) list] + function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; Units list; option(polygon) list] +##else function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: {int, int} list; option(line) list] - function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: int; y1: int; x2: int; y2: int; option(oval) list] function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: {int, int} list; option(polygon) list] - function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: int; y1: int; x2: int; y2: int; option(rectangle) list] - function (TagOrId) create_text [widget(canvas); "create"; "text"; x: int; y: int; option(canvastext) list] - function (TagOrId) create_window [widget(canvas); "create"; "window"; x: int; y: int; option(window) list] +##endif + function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(oval) list] + function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(rectangle) list] + function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units/int; y: Units/int; option(canvastext) list] + function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units/int; y: Units/int; option(window) list] function (string) itemconfigure_get [widget(canvas); "itemconfigure"; TagOrId] @@ -469,9 +527,9 @@ widget canvas { } -##### checkbutton(n) +%%%%% checkbutton(n) widget checkbutton { - # Standard options + % Standard options option ActiveBackground option ActiveForeground option Anchor @@ -485,9 +543,12 @@ widget checkbutton { option HighlightBackground option HighlightColor option HighlightThickness +##ifdef CAMLTK + option ImageBitmap + option ImagePhoto +##else option Image -# option ImageBitmap -# option ImagePhoto +##endif option Justify option PadX option PadY @@ -497,16 +558,19 @@ widget checkbutton { option TextVariable option UnderlinedChar option WrapLength - # Widget specific options + % Widget specific options option Command option Height option IndicatorOn ["-indicatoron"; bool] option OffValue ["-offvalue"; string] option OnValue ["-onvalue"; string] option SelectColor ["-selectcolor"; Color] +##ifdef CAMLTK + option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap] + option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto] +##else option SelectImage ["-selectimage"; Image] -# option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap] -# option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto] +##endif option State option Variable ["-variable"; TextVariable] option Width @@ -520,43 +584,41 @@ widget checkbutton { function () toggle [widget(checkbutton); "toggle"] } -##### clipboard(n) -subtype icccm(clipboard_clear) { - DisplayOf ["-displayof"; widget] - } - +%%%%% clipboard(n) subtype icccm(clipboard_append) { - DisplayOf ["-displayof"; widget] ICCCMFormat ["-format"; string] ICCCMType ["-type"; string] } module Clipboard { - function () clear ["clipboard"; "clear"; icccm(clipboard_clear) list] - function () append ["clipboard"; "append"; icccm(clipboard_append) list; "--"; data: string] + function () clear ["clipboard"; "clear"; ?displayof:["-displayof"; widget]] + function () append ["clipboard"; "append"; ?displayof:["-displayof"; widget]; icccm(clipboard_append) list; "--"; data: string] } -##### destroy(n) +%%%%% destroy(n) function () destroy ["destroy"; widget] -##### tk_dialog(n) +%%%%% tk_dialog(n) module Dialog { external create "builtin/dialog" } -##### entry(n) -# Defined internally -# subtype Index(entry) { -# Number End Insert SelFirst SelLast At AnchorPoint -# } +%%%%% entry(n) +% Defined internally +% subtype Index(entry) { +% Number End Insert SelFirst SelLast At AnchorPoint +% } +##ifndef CAMLTK +% Only for Labltk. InputState is unified as State in Camltk type InputState { Normal ["normal"] Disabled ["disabled"] } +##endif widget entry { - # Standard options + % Standard options option Background option BorderWidth option Cursor @@ -580,11 +642,16 @@ widget entry { option TextVariable option XScrollCommand - # Widget specific options + % Widget specific options option Show ["-show"; char] +##ifdef CAMLTK + option State +##else option EntryState ["-state"; InputState] +##endif option TextWidth (Textwidth) ["-width"; int] + function (int,int,int,int) bbox [widget(entry); "bbox"; Index(entry)] function () configure [widget(entry); "configure"; option(entry) list] function (string) configure_get [widget(entry); "configure"] function () delete_single [widget(entry); "delete"; index: Index(entry)] @@ -595,7 +662,7 @@ widget entry { function () insert [widget(entry); "insert"; index: Index(entry); text: string] function () scan_mark [widget(entry); "scan"; "mark"; x: int] function () scan_dragto [widget(entry); "scan"; "dragto"; x: int] - # selection variation + % selection variation function () selection_adjust [widget(entry); "selection"; "adjust"; index: Index(entry)] function () selection_clear [widget(entry); "selection"; "clear"] function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)] @@ -603,34 +670,104 @@ widget entry { function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)] function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)] + function (float,float) xview_get [widget(entry); "xview"] function () xview [widget(entry); "xview"; scroll: ScrollValue] function () xview_index [widget(entry); "xview"; index: Index(entry)] function (float, float) xview_get [widget(entry); "xview"] } -##### focus(n) -##### tk_focusNext(n) +%%%%% focus(n) +%%%%% tk_focusNext(n) module Focus { - unsafe function (widget) get ["focus"] - function () set ["focus"; widget] + unsafe function (widget) get ["focus"; ?displayof:["-displayof"; widget]] unsafe function (widget) displayof ["focus"; "-displayof"; widget] - function () force ["focus"; "-force"; widget] + function () set ["focus"; widget] + function () force ["focus"; "-force"; widget] unsafe function (widget) lastfor ["focus"; "-lastfor"; widget] unsafe function (widget) next ["tk_focusNext"; widget] unsafe function (widget) prev ["tk_focusPrev"; widget] - function () follows_mouse ["tk_focusFollowsMouse"] + function () follows_mouse ["tk_focusFollowsMouse"] +} + +type font external % builtin/builtin_font.ml + +type weight { + Weight_Normal(Normal) ["normal"] + Weight_Bold(Bold) ["bold"] +} + +type slant { + Slant_Roman(Roman) ["roman"] + Slant_Italic(Italic) ["italic"] } +type fontMetrics { + Ascent ["-ascent"] + Descent ["-descent"] + Linespace ["-linespace"] + Fixed ["-fixed"] +} + +subtype options(font) { + Font_Family ["-family"; string] + Font_Size ["-size"; int] + Font_Weight ["-weight"; weight] + Font_Slant ["-slant"; slant] + Font_Underline ["-underline"; bool] + Font_Overstrike ["-overstrike"; bool] +% later, JP only +% Charset ["-charset"; string] +%% Beware of the order of Compound ! Put it as the first option +% Compound ["-compound"; [font list]] +% Copy ["-copy"; string] +} + +module Font { + function (string) actual ["font"; "actual"; font; + ?displayof:["-displayof"; widget]; + options(font) list] +##ifdef CAMLTK + function (string) actual_displayof ["font"; "actual"; font; + "-displayof"; widget; + options(font) list] +##endif + function () configure ["font"; "configure"; font; options(font) list] + function (font) create ["font"; "create"; options(font) list] + function () delete ["font"; "delete"; font] + function (string list) families ["font"; "families"; + ?displayof:["-displayof"; widget]] +##ifdef CAMLTK + function (string list) families_displayof ["font"; "families"; + "-displayof"; widget] +##endif + function (int) measure ["font"; "measure"; font; string; + ?displayof:["-displayof"; widget]] +##ifdef CAMLTK + function (int) measure_displayof ["font"; "measure"; font; + "-displayof"; widget; string ] +##endif + function (int) metrics ["font"; "metrics"; font; + ?displayof:["-displayof"; widget]; + fontMetrics ] +##ifdef CAMLTK + function (int) metrics_displayof ["font"; "metrics"; font; + "-displayof"; widget; + fontMetrics ] +##endif + function (string list) names ["font"; "names"] +% JP +% function () failsafe ["font"; "failsafe"; string] +} -##### frame(n) +%%%%% frame(n) type Colormap { NewColormap (New) ["new"] WidgetColormap (Widget) [widget] } -# Visual classes are: directcolor, grayscale, greyscale, pseudocolor, -# staticcolor, staticgray, staticgrey, truecolor +% Visual classes are: directcolor, grayscale, greyscale, pseudocolor, +% staticcolor, staticgray, staticgrey, truecolor type Visual { ClassVisual (Clas) [[string; int]] DefaultVisual ["default"] @@ -640,7 +777,7 @@ type Visual { } widget frame { - # Standard options + % Standard options option BorderWidth option Cursor option HighlightBackground @@ -649,22 +786,27 @@ widget frame { option Relief option TakeFocus - # Widget specific options + % Widget specific options option Background +##ifdef CAMLTK + option Class ["-class"; string] +##else option Clas ["-class"; string] +##endif option Colormap ["-colormap"; Colormap] + option Container ["-container"; bool] option Height option Visual ["-visual"; Visual] option Width - # Class and Colormap and Visual cannot be changed + % Class and Colormap and Visual cannot be changed function () configure [widget(frame); "configure"; option(frame) list] function (string) configure_get [widget(frame); "configure"] } -##### grab(n) +%%%%% grab(n) type GrabStatus { GrabNone ["none"] GrabLocal ["local"] @@ -672,26 +814,32 @@ type GrabStatus { } type GrabGlobal external module Grab { - function () set ["grab"; ?global:[GrabGlobal]; widget] -# function () set_global ["grab"; "-global"; widget] + function () set ["grab"; "set"; ?global:[GrabGlobal]; widget] +##ifdef CAMLTK + function () set_global ["grab"; "set"; "-global"; widget] +##endif unsafe function (widget list) current ["grab"; "current"; ?displayof:[widget]] -# unsafe function (widget list) current ["grab"; "current"; widget] -# unsafe function (widget list) all_current ["grab"; "current"] +##ifdef CAMLTK + % all_current is now current. + % The old current is now current_of + unsafe function (widget list) current_of ["grab"; "current"; widget] +##endif function () release ["grab"; "release"; widget] function (GrabStatus) status ["grab"; "status"; widget] } subtype option(rowcolumnconfigure) { - Minsize ["-minsize"; int] + Minsize ["-minsize"; Units/int] Weight ["-weight"; float] + Pad ["-pad"; Units/int] } subtype option(grid) { Column ["-column"; int] ColumnSpan ["-columnspan"; int] In(Inside) ["-in"; widget] - IPadX ["-ipadx"; int] - IPadY ["-ipady"; int] + IPadX ["-ipadx"; Units/int] + IPadY ["-ipady"; Units/int] PadX PadY Row ["-row"; int] @@ -699,11 +847,13 @@ subtype option(grid) { Sticky ["-sticky"; string] } -# Same as pack +% Same as pack function () grid ["grid"; widget list; option(grid) list] module Grid { - function (int,int,int,int) bbox ["grid"; "bbox"; widget; int; int] + function (int,int,int,int) bbox ["grid"; "bbox"; widget] + function (int,int,int,int) bbox_cell ["grid"; "bbox"; widget; column: int; row: int] + function (int,int,int,int) bbox_span ["grid"; "bbox"; widget; column1: int; row1: int; column2: int; row2: int] function () column_configure ["grid"; "columnconfigure"; widget; int; option(rowcolumnconfigure) list] @@ -711,38 +861,36 @@ module Grid { function (string) column_configure_get ["grid"; "columnconfigure"; widget; int] function () forget ["grid"; "forget"; widget list] - ## info returns only a string + %% info returns only a string function (string) info ["grid"; "info"; widget] - ## TODO: check result values - function (int,int) location ["grid"; "location"; widget; x:int; y:int] + %% TODO: check result values + function (int,int) location ["grid"; "location"; widget; x:Units/int; y:Units/int] function (bool) propagate_get ["grid"; "propagate"; widget] function () propagate_set ["grid"; "propagate"; widget; bool] function () row_configure ["grid"; "rowconfigure"; widget; int; option(rowcolumnconfigure) list] - function (string) row_configure_get - ["grid"; "rowconfigure"; widget; int] + function (string) row_configure_get ["grid"; "rowconfigure"; widget; int] function (int,int) size ["grid"; "size"; widget] +##ifdef CAMLTK function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] -# function (widget list) all_slaves ["grid"; "slaves"; widget] -# function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int] -# function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int] + function (widget list) row_slaves ["grid"; "slaves"; widget; "-row"; int] + function (widget list) column_slaves ["grid"; "slaves"; widget; "-column"; int] +##else + function (widget list) slaves ["grid"; "slaves"; widget; ?column:["-column"; int]; ?row:["-row"; int]] +##endif } +%%%%% image(n) +%%%%% cf Imagephoto and Imagebitmap +% Some functions on images are implemented in Imagephoto or Imagebitmap. +module Image { + external names "builtin/image" +} - - - - -##### image(n) -##### cf bitmap(n) and photo(n) -# Some functions on images are not implemented -# names, types - - -##### label(n) +%%%%% label(n) widget label { - # Standard options + % Standard options option Anchor option Background option Bitmap @@ -753,9 +901,12 @@ widget label { option HighlightBackground option HighlightColor option HighlightThickness +##ifdef CAMLTK + option ImageBitmap + option ImagePhoto +##else option Image -# option ImageBitmap -# option ImagePhoto +##endif option Justify option PadX option PadY @@ -766,9 +917,9 @@ widget label { option UnderlinedChar option WrapLength - # Widget specific options + % Widget specific options option Height - # use according to label contents + % use according to label contents option Width option TextWidth @@ -777,12 +928,12 @@ widget label { } -##### listbox(n) +%%%%% listbox(n) -# Defined internally -# subtype Index(listbox) { -# Number Active AnchorPoint End AtXY -#} +% Defined internally +% subtype Index(listbox) { +% Number Active AnchorPoint End AtXY +%} type SelectModeType { Single ["single"] @@ -793,13 +944,14 @@ type SelectModeType { widget listbox { - # Standard options + % Standard options option Background option BorderWidth option Cursor option ExportSelection - option Foreground option Font + option Foreground + % Height is TextHeight option HighlightBackground option HighlightColor option HighlightThickness @@ -809,9 +961,10 @@ widget listbox { option SelectForeground option SetGrid option TakeFocus + % Width is TextWidth option XScrollCommand option YScrollCommand - # Widget specific options + % Widget specific options option TextHeight ["-height"; int] option TextWidth option SelectMode ["-selectmode"; SelectModeType] @@ -844,18 +997,19 @@ widget listbox { function () yview [widget(listbox); "yview"; scroll: ScrollValue] } -##### lower(n) +%%%%% lower(n) function () lower_window ["lower"; widget; ?below:[widget]] -#function () lower_window ["lower"; widget] -#function () lower_window_below ["lower"; widget; below: widget] +##ifdef CAMLTK +function () lower_window_below ["lower"; widget; below: widget] +##endif -##### menu(n) -##### tk_popup(n) -# defined internally -# subtype Index(menu) { -# Number Active End Last None At Pattern -# } +%%%%% menu(n) +%%%%% tk_popup(n) +% defined internally +% subtype Index(menu) { +% Number Active End Last None At Pattern +% } type MenuItem { Cascade_Item ["cascade"] @@ -866,66 +1020,104 @@ type MenuItem { TearOff_Item ["tearoff"] } -# notused as a subtype. just for cleaning up the rest. +% notused as a subtype. just for cleaning up the rest. subtype option(menuentry) { ActiveBackground ActiveForeground Accelerator ["-accelerator"; string] Background Bitmap + ColumnBreak ["-columnbreak"; bool] Command Font Foreground + HideMargin ["-hidemargin"; bool] +##ifdef CAMLTK + ImageBitmap + ImagePhoto +##else Image +##endif IndicatorOn Label ["-label"; string] Menu ["-menu"; widget(menu)] OffValue OnValue SelectColor +##ifdef CAMLTK + SelectImageBitmap + SelectImagePhoto +##else SelectImage +##endif State UnderlinedChar Value ["-value"; string] Variable } -# Options for cascade entry +% Options for cascade entry subtype option(menucascade) { ActiveBackground ActiveForeground Accelerator - Background Bitmap Command Font Foreground - Image Label Menu State UnderlinedChar + Background Bitmap ColumnBreak Command Font Foreground + HideMargin +##ifdef CAMLTK + ImageBitmap ImagePhoto +##else + Image +##endif + IndicatorOn Label Menu State UnderlinedChar } -# Options for radiobutton entry +% Options for radiobutton entry subtype option(menuradio) { ActiveBackground ActiveForeground Accelerator - Background Bitmap Command Font Foreground - Image IndicatorOn Label - SelectColor SelectImage + Background Bitmap ColumnBreak Command Font Foreground +##ifdef CAMLTK + ImageBitmap ImagePhoto SelectImageBitmap SelectImagePhoto +##else + Image SelectImage +##endif + IndicatorOn Label SelectColor State UnderlinedChar Value Variable } -# Options for checkbutton entry +% Options for checkbutton entry subtype option(menucheck) { ActiveBackground ActiveForeground Accelerator - Background Bitmap Command Font Foreground - Image IndicatorOn Label - OffValue OnValue SelectColor SelectImage + Background Bitmap ColumnBreak Command Font Foreground +##ifdef CAMLTK + ImageBitmap SelectImageBitmap ImagePhoto SelectImagePhoto +##else + Image SelectImage +##endif + IndicatorOn Label + OffValue OnValue SelectColor State UnderlinedChar Variable } -# Options for command entry +% Options for command entry subtype option(menucommand) { ActiveBackground ActiveForeground Accelerator - Background Bitmap Command Font Foreground - Image Label State UnderlinedChar + Background Bitmap ColumnBreak Command Font Foreground +##ifdef CAMLTK + ImageBitmap ImagePhoto +##else + Image +##endif + Label State UnderlinedChar } -# Separators and tearoffs don't have options +type menuType { + Menu_Menubar ["menubar"] + Menu_Tearoff ["tearoff"] + Menu_Normal ["normal"] +} + +% Separators and tearoffs don't have options widget menu { - # Standard options + % Standard options option ActiveBackground option ActiveBorderWidth option ActiveForeground @@ -937,21 +1129,25 @@ widget menu { option Foreground option Relief option TakeFocus - # Widget specific options + % Widget specific options option PostCommand ["-postcommand"; function()] option SelectColor option TearOff ["-tearoff"; bool] + option TearOffCommand ["-tearoffcommand"; function(menu: widget(any), tornoff: widget(any)) ] + option MenuTitle ["-title"; string] + option MenuType ["-type"; menuType] function () activate [widget(menu); "activate"; index: Index(menu)] - # add variations + % add variations function () add_cascade [widget(menu); "add"; "cascade"; option(menucascade) list] function () add_checkbutton [widget(menu); "add"; "checkbutton"; option(menucheck) list] function () add_command [widget(menu); "add"; "command"; option(menucommand) list] function () add_radiobutton [widget(menu); "add"; "radiobutton"; option(menuradio) list] function () add_separator [widget(menu); "add"; "separator"] + % not for user: function clone [widget(menu); "clone"; ???; menuType] function () configure [widget(menu); "configure"; option(menu) list] function (string) configure_get [widget(menu); "configure"] - # beware of possible callback leak when deleting menu entries + % beware of possible callback leak when deleting menu entries function () delete [widget(menu); "delete"; first: Index(menu); last: Index(menu)] function () configure_cascade [widget(menu); "entryconfigure"; Index(menu); option(menucascade) list] function () configure_checkbutton [widget(menu); "entryconfigure"; Index(menu); option(menucheck) list] @@ -967,21 +1163,29 @@ widget menu { function (string) invoke [widget(menu); "invoke"; index: Index(menu)] function () post [widget(menu); "post"; x: int; y: int] function () postcascade [widget(menu); "postcascade"; index: Index(menu)] - # can't use type of course + % can't use type of course function (MenuItem) typeof [widget(menu); "type"; index: Index(menu)] function () unpost [widget(menu); "unpost"] function (int) yposition [widget(menu); "yposition"; index: Index(menu)] function () popup ["tk_popup"; widget(menu); x: int; y: int; ?entry:[Index(menu)]] -# function () popup ["tk_popup"; widget(menu); x: int; y: int] -# function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)] +##ifdef CAMLTK + function () popup_entry ["tk_popup"; widget(menu); x: int; y: int; index: Index(menu)] +##endif } -##### menubutton(n) +%%%%% menubutton(n) + +type menubuttonDirection { + Dir_Above ["above"] + Dir_Below ["below"] + Dir_Left ["left"] + Dir_Right ["right"] +} widget menubutton { - # Standard options + % Standard options option ActiveBackground option ActiveForeground option Anchor @@ -995,9 +1199,12 @@ widget menubutton { option HighlightBackground option HighlightColor option HighlightThickness +##ifdef CAMLTK + option ImageBitmap + option ImagePhoto +##else option Image -# option ImageBitmap -# option ImagePhoto +##endif option Justify option PadX option PadY @@ -1007,7 +1214,8 @@ widget menubutton { option TextVariable option UnderlinedChar option WrapLength - # Widget specific options + % Widget specific options + option Direction ["-direction"; menubuttonDirection ] option Height option IndicatorOn option Menu ["-menu"; widget(menu)] @@ -1021,9 +1229,9 @@ widget menubutton { -##### message(n) +%%%%% message(n) widget message { - # Standard options + % Standard options option Anchor option Background option BorderWidth @@ -1039,7 +1247,7 @@ widget message { option TakeFocus option Text option TextVariable - # Widget specific options + % Widget specific options option Aspect ["-aspect"; int] option Justify option Width @@ -1049,7 +1257,7 @@ widget message { } -##### option(n) +%%%%% option(n) type OptionPriority { WidgetDefault ["widgetDefault"] StartupFile ["startupFile"] @@ -1058,6 +1266,22 @@ type OptionPriority { Priority [int] } +##ifdef CAMLTK + +module Option { + unsafe function () add ["option"; "add"; string; string; OptionPriority] + function () clear ["option"; "clear"] + function (string) get ["option"; "get"; widget; string; string] + unsafe function () readfile ["option"; "readfile"; string; OptionPriority] + } +%% Resource is now superseded by Option +module Resource { + unsafe function () add ["option"; "add"; string; string; OptionPriority] + function () clear ["option"; "clear"] + function (string) get ["option"; "get"; widget; string; string] + unsafe function () readfile ["option"; "readfile"; string; OptionPriority] + } +##else module Option { unsafe function () add ["option"; "add"; path: string; string; ?priority:[OptionPriority]] @@ -1066,14 +1290,15 @@ module Option { unsafe function () readfile ["option"; "readfile"; string; ?priority:[OptionPriority]] } +##endif -##### tk_optionMenu(n) +%%%%% tk_optionMenu(n) module Optionmenu { external create "builtin/optionmenu" } -##### pack(n) +%%%%% pack(n) type Side { Side_Left ["left"] Side_Right ["right"] @@ -1095,8 +1320,8 @@ subtype option(pack) { Expand ["-expand"; bool] Fill ["-fill"; FillMode] In(Inside) ["-in"; widget] - IPadX ["-ipadx"; int] - IPadY ["-ipady"; int] + IPadX ["-ipadx"; Units/int] + IPadY ["-ipady"; Units/int] PadX PadY Side ["-side"; Side] @@ -1107,12 +1332,13 @@ function () pack ["pack"; widget list; option(pack) list] module Pack { function () configure ["pack"; "configure"; widget list; option(pack) list] function () forget ["pack"; "forget"; widget list] + function (string) info ["pack"; "info"; widget] function (bool) propagate_get ["pack"; "propagate"; widget] function () propagate_set ["pack"; "propagate"; widget; bool] function (widget list) slaves ["pack"; "slaves"; widget] } -subtype TkPalette(any) { # Not sophisticated... +subtype TkPalette(any) { % Not sophisticated... PaletteActiveBackground ["activeBackground"; Color] PaletteActiveForeground ["activeForeground"; Color] PaletteBackground ["background"; Color] @@ -1127,18 +1353,19 @@ subtype TkPalette(any) { # Not sophisticated... PaletteTroughColor ["troughColor"; Color] } -##### tk_setPalette(n) -#### can't simply encode general form of tk_setPalette +%%%%% tk_setPalette(n) +%%%% can't simply encode general form of tk_setPalette module Palette { function () set_background ["tk_setPalette"; Color] function () set ["tk_setPalette"; TkPalette(any) list] function () bisque ["tk_bisque"] } -##### photo(n) -type PaletteType external # builtin_palette.ml +%%%%% photo(n) +type PaletteType external % builtin_palette.ml subtype option(photoimage) { + % Channel ["-channel"; file_descr] % removed in 8.3 ? Data Format ["-format"; string] File @@ -1172,25 +1399,32 @@ subtype photo(write) { } module Imagephoto { - function (ImagePhoto) create ["image"; "create"; "photo"; option(photoimage) list] + function (ImagePhoto) create ["image"; "create"; "photo"; ?name:[ImagePhoto]; option(photoimage) list] +##ifdef CAMLTK + function (ImagePhoto) create_named ["image"; "create"; "photo"; ImagePhoto; option(photoimage) list] +##endif + function () delete ["image"; "delete"; ImagePhoto] + function (int) height ["image"; "height"; ImagePhoto] + function (int) width ["image"; "width"; ImagePhoto] + +%name +%type + function () blank [ImagePhoto; "blank"] function () configure [ImagePhoto; "configure"; option(photoimage) list] function (string) configure_get [ImagePhoto; "configure"] function () copy [ImagePhoto; "copy"; src: ImagePhoto; photo(copy) list] function (int, int, int) get [ImagePhoto; "get"; x: int; y: int] -# can't express nested lists ? -# function () put [ImagePhoto; "put"; [[Color list] list]; photo(put) list] +% it is buggy ? can't express nested lists ? +% function () put [ImagePhoto; "put"; [[Color list] list]; photo(put)] function () read [ImagePhoto; "read"; file: string; photo(read) list] function () redither [ImagePhoto; "redither"] - function () write [ImagePhoto; "write"; photo(write) list] - # Functions inherited from the "image" TK class - function () delete ["image"; "delete"; ImagePhoto] - function (int) height ["image"; "height"; ImagePhoto] - function (int) width ["image"; "width"; ImagePhoto] + function () write [ImagePhoto; "write"; file: string; photo(write) list] + % Functions inherited from the "image" TK class } -##### place(n) +%%%%% place(n) type BorderMode { Inside ["inside"] Outside ["outside"] @@ -1221,10 +1455,10 @@ module Place { } -##### radiobutton(n) +%%%%% radiobutton(n) widget radiobutton { - # Standard options + % Standard options option ActiveBackground option ActiveForeground option Anchor @@ -1238,9 +1472,12 @@ widget radiobutton { option HighlightBackground option HighlightColor option HighlightThickness +##ifdef CAMLTK + option ImageBitmap + option ImagePhoto +##else option Image -# option ImageBitmap -# option ImagePhoto +##endif option Justify option PadX option PadY @@ -1251,14 +1488,17 @@ widget radiobutton { option UnderlinedChar option WrapLength - # Widget specific options + % Widget specific options option Command option Height option IndicatorOn option SelectColor +##ifdef CAMLTK + option SelectImageBitmap + option SelectImagePhoto +##else option SelectImage -# option SelectImageBitmap -# option SelectImagePhoto +##endif option State option Value option Variable @@ -1273,24 +1513,33 @@ widget radiobutton { } -##### raise(n) -# We cannot use raise !! +%%%%% raise(n) +% We cannot use raise !! function () raise_window ["raise"; widget; ?above:[widget]] -#function () raise_window ["raise"; widget] -#function () raise_window_above ["raise"; widget; above: widget] - - -##### scale(n) -## shared with scrollbars +##ifdef CAMLTK +function () raise_window_above ["raise"; widget; widget] +##endif + +%%%%% scale(n) +%% shared with scrollbars +##ifdef CAMLTK +subtype WidgetElement(scale) { + Slider ["slider"] + Trough1 ["trough1"] + Trough2 ["trough2"] + Beyond [""] + } +##else type ScaleElement { Slider ["slider"] Trough1 ["trough1"] Trough2 ["trough2"] Beyond [""] } +##endif widget scale { - # Standard options + % Standard options option ActiveBackground option Background option BorderWidth @@ -1307,32 +1556,48 @@ widget scale { option TakeFocus option TroughColor - # Widget specific options + % Widget specific options option BigIncrement ["-bigincrement"; float] option ScaleCommand ["-command"; function (float)] option Digits ["-digits"; int] option From(Min) ["-from"; float] option Label ["-label"; string] - option Length ["-length"; int] + option Length ["-length"; Units/int] option Resolution ["-resolution"; float] option ShowValue ["-showvalue"; bool] - option SliderLength ["-sliderlength"; int] + option SliderLength ["-sliderlength"; Units/int] option State option TickInterval ["-tickinterval"; float] option To(Max) ["-to"; float] option Variable option Width +##ifdef CAMLTK + function (int,int) coords [widget(scale); "coords"] + function (int,int) coords_at [widget(scale); "coords"; at: float] +##else + function (int,int) coords [widget(scale); "coords"; ?at: [float]] +##endif function () configure [widget(scale); "configure"; option(scale) list] function (string) configure_get [widget(scale); "configure"] function (float) get [widget(scale); "get"] function (float) get_xy [widget(scale); "get"; x: int; y: int] - function (ScaleElement) identify [widget(scale); x: int; y: int] + function (WidgetElement/ScaleElement) identify [widget(scale); x: int; y: int] function () set [widget(scale); "set"; float] } -##### scrollbar(n) +%%%%% scrollbar(n) +##ifdef CAMLTK +subtype WidgetElement(scrollbar) { + Arrow1 ["arrow1"] + Trough1 + Trough2 + Slider + Arrow2 ["arrow2"] + Beyond + } +##else type ScrollbarElement { Arrow1 ["arrow1"] Trough1 ["through1"] @@ -1341,9 +1606,10 @@ type ScrollbarElement { Arrow2 ["arrow2"] Beyond [""] } +##endif widget scrollbar { - # Standard options + % Standard options option ActiveBackground option Background option BorderWidth @@ -1358,30 +1624,34 @@ widget scrollbar { option RepeatInterval option TakeFocus option TroughColor - # Widget specific options + % Widget specific options option ActiveRelief ["-activerelief"; Relief] option ScrollCommand ["-command"; function(scroll: ScrollValue)] - option ElementBorderWidth ["-elementborderwidth"; int] + option ElementBorderWidth ["-elementborderwidth"; Units/int] option Width +##ifdef CAMLTK + function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)] +##else function () activate [widget(scrollbar); "activate"; element: ScrollbarElement] - function (ScrollbarElement) activate_get [widget(scrollbar); "activate"] +##endif + function (WidgetElement/ScrollbarElement) activate_get [widget(scrollbar); "activate"] function () configure [widget(scrollbar); "configure"; option(scrollbar) list] function (string) configure_get [widget(scrollbar); "configure"] function (float) delta [widget(scrollbar); "delta"; x: int; y: int] function (float) fraction [widget(scrollbar); "fraction"; x: int; y: int] function (float, float) get [widget(scrollbar); "get"] - function (int, int, int, int) old_get [widget(scrollbar); "get"] - function (ScrollbarElement) identify [widget(scrollbar); "identify"; x: int; y: int] + function (int,int,int,int) old_get [widget(scrollbar); "get"] + function (WidgetElement/ScrollbarElement) identify [widget(scale); "identify"; int; int] function () set [widget(scrollbar); "set"; first: float; last: float] function () old_set [widget(scrollbar); "set"; total:int; window:int; first:int; last:int] } -##### selection(n) +%%%%% selection(n) subtype icccm(selection_clear) { - DisplayOf + DisplayOf ["-displayof"; widget] Selection ["-selection"; string] } @@ -1397,7 +1667,8 @@ subtype icccm(selection_ownset) { } subtype icccm(selection_handle) { - Selection ICCCMType + Selection + ICCCMType ICCCMFormat ["-format"; string] } @@ -1405,16 +1676,24 @@ module Selection { function () clear ["selection"; "clear"; icccm(selection_clear) list] function (string) get ["selection"; "get"; icccm(selection_get) list] - # function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)] + % function () handle_set ["selection"; "handle"; icccm(selection_handle) list; widget; function(int,int)] external handle_set "builtin/selection_handle_set" unsafe function (widget) own_get ["selection"; "own"; icccm(selection_clear) list] - # builtin - # function () own_set ["selection"; "own"; widget; icccm(selection_ownset) list] + % builtin + % function () own_set ["selection"; "own"; widget; icccm(selection_ownset) list] external own_set "builtin/selection_own_set" } -##### text(n) +%%%%% send(n) +type SendOption { + SendDisplayOf ["-displayof"; widget] % DisplayOf is used for icccm ! + SendAsync ["-async"] +} + +unsafe function () send ["send"; SendOption list; "--"; app: string; command: string list] + +%%%%% text(n) type TextIndex external type TextTag external @@ -1422,10 +1701,10 @@ type TextMark external type TabType { - TabLeft [int; "left"] - TabRight [int; "right"] - TabCenter [int; "center"] - TabNumeric [int; "numeric"] + TabLeft [Units/int; "left"] + TabRight [Units/int; "right"] + TabCenter [Units/int; "center"] + TabNumeric [Units/int; "numeric"] } type WrapMode { @@ -1443,7 +1722,6 @@ type Comparison { NEQ (Neq) ["!="] } - type MarkDirection { Mark_Left ["left"] Mark_Right ["right"] @@ -1458,7 +1736,12 @@ type AlignType { subtype option(embeddedi) { Align ["-align"; AlignType] +##ifdef CAMLTK + ImageBitmap + ImagePhoto +##else Image +##endif Name ["-name"; string] PadX PadY @@ -1481,8 +1764,17 @@ type TextSearch { Count ["-count"; TextVariable] } +type text_dump { + DumpAll ["-all"] + DumpCommand ["-command"; function (key: string, value: string, index: string)] + DumpMark ["-mark"] + DumpTag ["-tag"] + DumpText ["-text"] + DumpWindow ["-window"] + } + widget text { - # Standard options + % Standard options option Background option BorderWidth option Cursor @@ -1508,12 +1800,16 @@ widget text { option XScrollCommand option YScrollCommand - # Widget specific options + % Widget specific options option TextHeight - option Spacing1 ["-spacing1"; int] - option Spacing2 ["-spacing2"; int] - option Spacing3 ["-spacing3"; int] + option Spacing1 ["-spacing1"; Units/int] + option Spacing2 ["-spacing2"; Units/int] + option Spacing3 ["-spacing3"; Units/int] +##ifdef CAMLTK + option State +##else option EntryState +##endif option Tabs ["-tabs"; [TabType list]] option TextWidth option Wrap ["-wrap"; WrapMode] @@ -1526,6 +1822,11 @@ widget text { function () delete [widget(text); "delete"; start: TextIndex; stop: TextIndex] function () delete_char [widget(text); "delete"; index: TextIndex] function (int, int, int, int, int) dlineinfo [widget(text); "dlineinfo"; index: TextIndex] + + % require result parser + function (string list) dump [widget(text); "dump"; text_dump list; start: TextIndex; stop: TextIndex] + function (string list) dump_char [widget(text); "dump"; text_dump list; index: TextIndex] + function (string) get [widget(text); "get"; start: TextIndex; stop: TextIndex] function (string) get_char [widget(text); "get"; index: TextIndex] function () image_configure @@ -1536,48 +1837,81 @@ widget text { [widget(text); "image"; "create"; option(embeddedi) list] function (string list) image_names [widget(text); "image"; "names"] function (Index(text) as "[>`Linechar of int * int]") index [widget(text); "index"; index: TextIndex] +##ifdef CAMLTK + function () insert [widget(text); "insert"; index: TextIndex; text: string; [TextTag list]] +##else function () insert [widget(text); "insert"; index: TextIndex; text: string; ?tags: [TextTag list]] - # Mark +##endif + % Mark function () mark_gravity_set [widget(text); "mark"; "gravity"; mark: TextMark; direction: MarkDirection] function (MarkDirection) mark_gravity_get [widget(text); "mark"; "gravity"; mark: TextMark] function (TextMark list) mark_names [widget(text); "mark"; "names"] + function (TextMark) mark_next [widget(text); "mark"; "next"; index: TextIndex] + function (TextMark) mark_previous [widget(text); "mark"; "previous"; index: TextIndex] function () mark_set [widget(text); "mark"; "set"; mark: TextMark; index: TextIndex] function () mark_unset [widget(text); "mark"; "unset"; marks: TextMark list] - # Scan + % Scan function () scan_mark [widget(text); "scan"; "mark"; x: int; y: int] function () scan_dragto [widget(text); "scan"; "dragto"; x: int; y: int] +##ifdef CAMLTK + function (Index) search [widget(text); "search"; TextSearch list; "--"; string; TextIndex; TextIndex] +##else function (Index(text) as "[>`Linechar of int * int]") search [widget(text); "search"; switches: TextSearch list; "--"; pattern: string; start: TextIndex; ?stop: [TextIndex]] +##endif function () see [widget(text); "see"; index: TextIndex] - # Tags + % Tags function () tag_add [widget(text); "tag"; "add"; tag: TextTag; start: TextIndex; stop: TextIndex] function () tag_add_char [widget(text); "tag"; "add"; tag: TextTag; index: TextIndex] external tag_bind "builtin/text_tag_bind" function () tag_configure [widget(text); "tag"; "configure"; tag: TextTag; option(texttag) list] function () tag_delete [widget(text); "tag"; "delete"; TextTag list] + function () tag_lower [widget(text); "tag"; "lower"; tag: TextTag; ?below: [TextTag]] -# function () tag_lower_below [widget(text); "tag"; "lower"; tag: TextTag; below: TextTag] -# function () tag_lower_bot [widget(text); "tag"; "lower"; tag: TextTag] +##ifdef CAMLTK + function () tag_lower_below [widget(text); "tag"; "lower"; TextTag; TextTag] + function () tag_lower_bot [widget(text); "tag"; "lower"; TextTag] +##endif + function (TextTag list) tag_names [widget(text); "tag"; "names"; ?index: [TextIndex]] -# function (TextTag list) tag_allnames [widget(text); "tag"; "names"] -# function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; index: TextIndex] +##ifdef CAMLTK + function (TextTag list) tag_allnames [widget(text); "tag"; "names"] + function (TextTag list) tag_indexnames [widget(text); "tag"; "names"; TextIndex] +##endif + +##ifdef CAMLTK + function (Index, Index) tag_nextrange [widget(text); "tag"; "nextrange"; TextTag; start: TextIndex; stop: TextIndex] + function (Index, Index) tag_prevrange [widget(text); "tag"; "prevrange"; TextTag; start: TextIndex; stop: TextIndex] +##else function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_nextrange [widget(text); "tag"; "nextrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] + function (Index(text) as "[>`Linechar of int * int]", Index(text) as "[>`Linechar of int * int]") tag_prevrange [widget(text); "tag"; "prevrange"; tag: TextTag; start: TextIndex; ?stop: [TextIndex]] +##endif + function () tag_raise [widget(text); "tag"; "raise"; tag: TextTag; ?above: [TextTag]] -# function () tag_raise_above [widget(text); "tag"; "raise"; tag: TextTag; above: TextTag] -# function () tag_raise_top [widget(text); "tag"; "raise"; tag: TextTag ] +##ifdef CAMLTK + function () tag_raise_above [widget(text); "tag"; "raise"; TextTag; TextTag] + function () tag_raise_top [widget(text); "tag"; "raise"; TextTag] +##endif + +##ifdef CAMLTK + function (Index list) tag_ranges [widget(text); "tag"; "ranges"; TextTag] +##else function (Index(text) as "[>`Linechar of int * int]" list) tag_ranges [widget(text); "tag"; "ranges"; tag: TextTag] +##endif + function () tag_remove [widget(text); "tag"; "remove"; tag: TextTag; start: TextIndex; stop: TextIndex] function () tag_remove_char [widget(text); "tag"; "remove"; tag: TextTag; index: TextIndex] + function () window_configure [widget(text); "window"; "configure"; tag: TextTag; option(embeddedw) list] function () window_create [widget(text); "window"; "create"; index: TextIndex; option(embeddedw) list] function (widget list) window_names [widget(text); "window"; "names"] - # scrolling + % scrolling function (float,float) xview_get [widget(text); "xview"] function (float,float) yview_get [widget(text); "yview"] function () xview [widget(text); "xview"; scroll: ScrollValue] function () yview [widget(text); "yview"; scroll: ScrollValue] function () yview_index [widget(text); "yview"; index: TextIndex] function () yview_index_pickplace [widget(text); "yview"; "-pickplace"; index: TextIndex] - function () yview_line [widget(text); "yview"; line: int] # obsolete + function () yview_line [widget(text); "yview"; line: int] % obsolete } subtype option(texttag) { @@ -1588,12 +1922,12 @@ subtype option(texttag) { Font Foreground Justify - LMargin1 ["-lmargin1"; int] - LMargin2 ["-lmargin2"; int] - Offset ["-offset"; int] + LMargin1 ["-lmargin1"; Units/int] + LMargin2 ["-lmargin2"; Units/int] + Offset ["-offset"; Units/int] OverStrike ["-overstrike"; bool] Relief - RMargin ["-rmargin"; int] + RMargin ["-rmargin"; Units/int] Spacing1 Spacing2 Spacing3 @@ -1603,11 +1937,22 @@ subtype option(texttag) { } -##### tk(n) -function () appname_set ["tk"; "appname"; string] -function (string) appname_get ["tk"; "appname"] +%%%%% tk(n) +unsafe function () appname_set ["tk"; "appname"; string] +unsafe function (string) appname_get ["tk"; "appname"] +function (float) scaling_get ["tk"; "scaling"; ?displayof:["-displayof"; widget]] +unsafe function () scaling_set ["tk"; "scaling"; ?displayof:["-displayof"; widget]; float] -##### tkwait(n) +%%%%% tk_chooseColor(n) + +subtype option(chooseColor){ + InitialColor ["-initialcolor"; Color] + Parent ["-parent"; widget] + Title ["-title"; string] + } +function (Color) chooseColor ["tk_chooseColor"; option(chooseColor) list] + +%%%%% tkwait(n) module Tkwait { function () variable ["tkwait"; "variable"; TextVariable] function () visibility ["tkwait"; "visibility"; widget] @@ -1615,11 +1960,11 @@ module Tkwait { } -##### toplevel(n) -# This module will be renamed "toplevelw" to avoid collision with -# Caml Light standard toplevel module. +%%%%% toplevel(n) +% This module will be renamed "toplevelw" to avoid collision with +% Caml Light standard toplevel module. widget toplevel { - # Standard options + % Standard options option BorderWidth option Cursor option HighlightBackground @@ -1628,12 +1973,19 @@ widget toplevel { option Relief option TakeFocus - # Widget specific options + % Widget specific options option Background +##ifdef CAMLTK + option Class +##else option Clas +##endif option Colormap + option Container ["-container"; bool] option Height + option Menu option Screen ["-screen"; string] + option Use ["-use"; string] % must be hexadecimal "0x????" option Visual option Width @@ -1642,47 +1994,53 @@ widget toplevel { } -##### update(n) +%%%%% update(n) function () update ["update"] function () update_idletasks ["update"; "idletasks"] -##### winfo(n) +%%%%% winfo(n) type AtomId { AtomId [int] } module Winfo { + unsafe function (AtomId) atom ["winfo"; "atom"; ?displayof:["-displayof"; widget]; string] unsafe function (string) atomname ["winfo"; "atomname"; ?displayof:["-displayof"; widget]; AtomId] -# unsafe function (string) atomname ["winfo"; "atomname"; AtomId] -# unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; displayof: widget; AtomId] +##ifdef CAMLTK + unsafe function (AtomId) atom_displayof ["winfo"; "atom"; "-displayof"; widget; string] + unsafe function (string) atomname_displayof ["winfo"; "atomname"; "-displayof"; widget; AtomId] +##endif function (int) cells ["winfo"; "cells"; widget] function (widget list) children ["winfo"; "children"; widget] function (string) class_name ["winfo"; "class"; widget] function (bool) colormapfull ["winfo"; "colormapfull"; widget] unsafe function (widget) containing ["winfo"; "containing"; ?displayof:["-displayof"; widget]; x: int; y: int] -# unsafe function (widget) containing ["winfo"; "containing"; x: int; y: int] - # addition for applets +##ifdef CAMLTK + unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; widget; int; int] +##endif + % addition for applets external contained "builtin/winfo_contained" -# unsafe function (widget) containing_displayof ["winfo"; "containing"; "-displayof"; displayof: widget; x: int; y: int] function (int) depth ["winfo"; "depth"; widget] function (bool) exists ["winfo"; "exists"; widget] function (float) fpixels ["winfo"; "fpixels"; widget; length: Units] function (string) geometry ["winfo"; "geometry"; widget] function (int) height ["winfo"; "height"; widget] unsafe function (string) id ["winfo"; "id"; widget] - unsafe function (string list) interps_displayof ["winfo"; "interps"; ?displayof:["-displayof"; widget]] -# unsafe function (string list) interps ["winfo"; "interps"] -# unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; displayof:widget] + unsafe function (string list) interps ["winfo"; "interps"; ?displayof:["-displayof"; widget]] +##ifdef CAMLTK + unsafe function (string list) interps_displayof ["winfo"; "interps"; "-displayof"; widget] +##endif function (bool) ismapped ["winfo"; "ismapped"; widget] function (string) manager ["winfo"; "manager"; widget] function (string) name ["winfo"; "name"; widget] - unsafe function (widget) parent ["winfo"; "parent"; widget] # bogus for top + unsafe function (widget) parent ["winfo"; "parent"; widget] % bogus for top unsafe function (widget) pathname ["winfo"; "pathname"; ?displayof:["-displayof"; widget]; string] -# unsafe function (widget) pathname ["winfo"; "pathname"; string] -# unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; displayof: widget; string] +##ifdef CAMLTK + unsafe function (widget) pathname_displayof ["winfo"; "pathname"; "-displayof"; widget; string] +##endif function (int) pixels ["winfo"; "pixels"; widget; length: Units] function (int) pointerx ["winfo"; "pointerx"; widget] function (int) pointery ["winfo"; "pointery"; widget] @@ -1692,20 +2050,21 @@ module Winfo { function (int,int,int) rgb ["winfo"; "rgb"; widget; color: Color] function (int) rootx ["winfo"; "rootx"; widget] function (int) rooty ["winfo"; "rooty"; widget] - function (string) screen ["winfo"; "screen"; widget] + unsafe function (string) screen ["winfo"; "screen"; widget] function (int) screencells ["winfo"; "screencells"; widget] function (int) screendepth ["winfo"; "screendepth"; widget] function (int) screenheight ["winfo"; "screenheight"; widget] - function (int) screenmmdepth ["winfo"; "screenmmdepth"; widget] function (int) screenmmheight ["winfo"; "screenmmheight"; widget] + function (int) screenmmwidth ["winfo"; "screenmmwidth"; widget] function (string) screenvisual ["winfo"; "screenvisual"; widget] function (int) screenwidth ["winfo"; "screenwidth"; widget] unsafe function (string) server ["winfo"; "server"; widget] unsafe function (widget(toplevel)) toplevel ["winfo"; "toplevel"; widget] function (bool) viewable ["winfo"; "viewable"; widget] function (string) visual ["winfo"; "visual"; widget] - # not so - function (string) visualsavailable ["winfo"; "visualsavailable"; widget] + function (int) visualid ["winfo"; "visualid"; widget] + % need special parser + function (string) visualsavailable ["winfo"; "visualsavailable"; widget; ?includeids: [int list]] function (int) vrootheight ["winfo"; "vrootheight"; widget] function (int) vrootwidth ["winfo"; "vrootwidth"; widget] function (int) vrootx ["winfo"; "vrootx"; widget] @@ -1716,7 +2075,7 @@ module Winfo { } -##### wm(n) +%%%%% wm(n) type FocusModel { FocusActive ["active"] @@ -1724,107 +2083,174 @@ type FocusModel { } type WmFrom { - FromUser ["user"] - FromProgram ["program"] + User ["user"] + Program ["program"] } module Wm { -### Aspect - function () aspect_set ["wm"; "aspect"; widget; minnum:int; mindenom:int; maxnum:int; maxdenom:int] - # aspect: problem with empty return - function (int,int,int,int) aspect_get ["wm"; "aspect"; widget] -### WM_CLIENT_MACHINE - function () client_set ["wm"; "client"; widget; name: string] - function (string) client_get ["wm"; "client"; widget] -### WM_COLORMAP_WINDOWS +%%% Aspect + function () aspect_set ["wm"; "aspect"; widget(toplevel); minnum:int; mindenom:int; maxnum:int; maxdenom:int] + % aspect: problem with empty return + function (int,int,int,int) aspect_get ["wm"; "aspect"; widget(toplevel)] +%%% WM_CLIENT_MACHINE + function () client_set ["wm"; "client"; widget(toplevel); name: string] + function (string) client_get ["wm"; "client"; widget(toplevel)] +%%% WM_COLORMAP_WINDOWS function () colormapwindows_set - ["wm"; "colormapwindows"; widget; [windows: widget list]] + ["wm"; "colormapwindows"; widget(toplevel); [windows: widget list]] unsafe function (widget list) colormapwindows_get - ["wm"; "colormapwindows"; widget] -### WM_COMMAND - function () command_clear ["wm"; "command"; widget; ""] - function () command_set ["wm"; "command"; widget; [string list]] - function (string list) command_get ["wm"; "command"; widget] - - function () deiconify ["wm"; "deiconify"; widget] - -### Focus model - function () focusmodel_set ["wm"; "focusmodel"; widget; FocusModel] - function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget] - - function (string) frame ["wm"; "frame"; widget] - -### Geometry - function () geometry_set ["wm"; "geometry"; widget; string] - function (string) geometry_get ["wm"; "geometry"; widget] - -### Grid - function () grid_clear ["wm"; "grid"; widget; ""; ""; ""; ""] - function () grid_set ["wm"; "grid"; widget; basewidth: int; baseheight: int; widthinc: int; heightinc: int] - function (int,int,int,int) grid_get ["wm"; "grid"; widget] - -### Groups - function () group_clear ["wm"; "group"; widget; ""] - function () group_set ["wm"; "group"; widget; leader: widget] - unsafe function (widget) group_get ["wm"; "group"; widget] -### Icon bitmap - function () iconbitmap_clear ["wm"; "iconbitmap"; widget; ""] - function () iconbitmap_set ["wm"; "iconbitmap"; widget; Bitmap] - function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget] - - function () iconify ["wm"; "iconify"; widget] - -### Icon mask - function () iconmask_clear ["wm"; "iconmask"; widget; ""] - function () iconmask_set ["wm"; "iconmask"; widget; Bitmap] - function (Bitmap) iconmask_get ["wm"; "iconmask"; widget] - -### Icon name - function () iconname_set ["wm"; "iconname"; widget; string] - function (string) iconname_get ["wm"; "iconname"; widget] -### Icon position - function () iconposition_clear ["wm"; "iconposition"; widget; ""; ""] - function () iconposition_set ["wm"; "iconposition"; widget; x: int; y: int] - function (int,int) iconposition_get ["wm"; "iconposition"; widget] -### Icon window - function () iconwindow_clear ["wm"; "iconwindow"; widget; ""] - function () iconwindow_set ["wm"; "iconwindow"; widget; icon: widget] - unsafe function (widget) iconwindow_get ["wm"; "iconwindow"; widget] - -### Sizes - function () maxsize_set ["wm"; "maxsize"; widget; width: int; height: int] - function (int,int) maxsize_get ["wm"; "maxsize"; widget] - function () minsize_set ["wm"; "minsize"; widget; width: int; height: int] - function (int,int) minsize_get ["wm"; "minsize"; widget] -### Override - function () overrideredirect_set ["wm"; "overrideredirect"; widget; bool] - function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget] -### Position - function () positionfrom_clear ["wm"; "positionfrom"; widget; ""] - function () positionfrom_set ["wm"; "positionfrom"; widget; WmFrom] - function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget] -### Protocols - function () protocol_set ["wm"; "protocol"; widget; name: string; command: function()] - function () protocol_clear ["wm"; "protocol"; widget; name: string; ""] - function (string list) protocols ["wm"; "protocol"; widget] -### Resize + ["wm"; "colormapwindows"; widget(toplevel)] +%%% WM_COMMAND + function () command_clear ["wm"; "command"; widget(toplevel); ""] + function () command_set ["wm"; "command"; widget(toplevel); [string list]] + function (string list) command_get ["wm"; "command"; widget(toplevel)] + + function () deiconify ["wm"; "deiconify"; widget(toplevel)] + +%%% Focus model + function () focusmodel_set ["wm"; "focusmodel"; widget(toplevel); FocusModel] + function (FocusModel) focusmodel_get ["wm"; "focusmodel"; widget(toplevel)] + + function (string) frame ["wm"; "frame"; widget(toplevel)] + +%%% Geometry + function () geometry_set ["wm"; "geometry"; widget(toplevel); string] + function (string) geometry_get ["wm"; "geometry"; widget(toplevel)] + +%%% Grid + function () grid_clear ["wm"; "grid"; widget(toplevel); ""; ""; ""; ""] + function () grid_set ["wm"; "grid"; widget(toplevel); basewidth: int; baseheight: int; widthinc: int; heightinc: int] + function (int,int,int,int) grid_get ["wm"; "grid"; widget(toplevel)] + +%%% Groups + function () group_clear ["wm"; "group"; widget(toplevel); ""] + function () group_set ["wm"; "group"; widget(toplevel); leader: widget] + unsafe function (widget) group_get ["wm"; "group"; widget(toplevel)] +%%% Icon bitmap + function () iconbitmap_clear ["wm"; "iconbitmap"; widget(toplevel); ""] + function () iconbitmap_set ["wm"; "iconbitmap"; widget(toplevel); Bitmap] + function (Bitmap) iconbitmap_get ["wm"; "iconbitmap"; widget(toplevel)] + + function () iconify ["wm"; "iconify"; widget(toplevel)] + +%%% Icon mask + function () iconmask_clear ["wm"; "iconmask"; widget(toplevel); ""] + function () iconmask_set ["wm"; "iconmask"; widget(toplevel); Bitmap] + function (Bitmap) iconmask_get ["wm"; "iconmask"; widget(toplevel)] + +%%% Icon name + function () iconname_set ["wm"; "iconname"; widget(toplevel); string] + function (string) iconname_get ["wm"; "iconname"; widget(toplevel)] +%%% Icon position + function () iconposition_clear ["wm"; "iconposition"; widget(toplevel); ""; ""] + function () iconposition_set ["wm"; "iconposition"; widget(toplevel); x: int; y: int] + function (int,int) iconposition_get ["wm"; "iconposition"; widget(toplevel)] +%%% Icon window + function () iconwindow_clear ["wm"; "iconwindow"; widget(toplevel); ""] + function () iconwindow_set ["wm"; "iconwindow"; widget(toplevel); icon: widget(toplevel)] + unsafe function (widget(toplevel)) iconwindow_get ["wm"; "iconwindow"; widget(toplevel)] + +%%% Sizes + function () maxsize_set ["wm"; "maxsize"; widget(toplevel); width: int; height: int] + function (int,int) maxsize_get ["wm"; "maxsize"; widget(toplevel)] + function () minsize_set ["wm"; "minsize"; widget(toplevel); width: int; height: int] + function (int,int) minsize_get ["wm"; "minsize"; widget(toplevel)] +%%% Override + unsafe function () overrideredirect_set ["wm"; "overrideredirect"; widget(toplevel); bool] + function (bool) overrideredirect_get ["wm"; "overrideredirect"; widget(toplevel)] +%%% Position + function () positionfrom_clear ["wm"; "positionfrom"; widget(toplevel); ""] + function () positionfrom_set ["wm"; "positionfrom"; widget(toplevel); WmFrom] + function (WmFrom) positionfrom_get ["wm"; "positionfrom"; widget(toplevel)] +%%% Protocols + function () protocol_set ["wm"; "protocol"; widget(toplevel); name: string; command: function()] + function () protocol_clear ["wm"; "protocol"; widget(toplevel); name: string; ""] + function (string list) protocols ["wm"; "protocol"; widget(toplevel)] +%%% Resize function () resizable_set ["wm"; "resizable"; widget(toplevel); width: bool; height: bool] function (bool, bool) resizable_get ["wm"; "resizable"; widget(toplevel)] -### Sizefrom - function () sizefrom_clear ["wm"; "sizefrom"; widget; ""] - function () sizefrom_set ["wm"; "sizefrom"; widget; WmFrom] - function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget] +%%% Sizefrom + function () sizefrom_clear ["wm"; "sizefrom"; widget(toplevel); ""] + function () sizefrom_set ["wm"; "sizefrom"; widget(toplevel); WmFrom] + function (WmFrom) sizefrom_get ["wm"; "sizefrom"; widget(toplevel)] + + function (string) state ["wm"; "state"; widget(toplevel)] + +%%% Title + function (string) title_get ["wm"; "title"; widget(toplevel)] + function () title_set ["wm"; "title"; widget(toplevel); string] +%%% Transient + function () transient_clear ["wm"; "transient"; widget(toplevel); ""] + function () transient_set ["wm"; "transient"; widget(toplevel); master: widget] + unsafe function (widget) transient_get ["wm"; "transient"; widget(toplevel)] - function (string) state ["wm"; "state"; widget] + function () withdraw ["wm"; "withdraw"; widget(toplevel)] -### Title - function (string) title_get ["wm"; "title"; widget] - function () title_set ["wm"; "title"; widget; string] -### Transient - function () transient_clear ["wm"; "transient"; widget; ""] - function () transient_set ["wm"; "transient"; widget; master: widget(toplevel)] - unsafe function (widget(toplevel)) transient_get ["wm"; "transient"; widget] +} + +%%%%% tk_getOpenFile(n) (since version 8.0) +type FilePattern external + +subtype option(getFile) { + DefaultExtension ["-defaultextension"; string] + FileTypes ["-filetypes"; [FilePattern list]] + InitialDir ["-initialdir"; string] + InitialFile ["-initialfile"; string] + Parent ["-parent"; widget] + Title ["-title"; string] +} + +function (string) getOpenFile ["tk_getOpenFile"; option(getFile) list] +function (string) getSaveFile ["tk_getSaveFile"; option(getFile) list] - function () withdraw ["wm"; "withdraw"; widget] +%%%%% tk_messageBox +type MessageIcon { + Error ["error"] + Info ["info"] + Question ["question"] + Warning ["warning"] +} +type MessageType { + AbortRetryIgnore ["abortretryignore"] + Ok ["ok"] + OkCancel ["okcancel"] + RetryCancel ["retrycancel"] + YesNo ["yesno"] + YesNoCancel ["yesnocancel"] +} +subtype option(messageBox) { + MessageDefault ["-default"; string] + MessageIcon ["-icon"; MessageIcon] + Message ["-message"; string] + Parent + Title + MessageType ["-type"; MessageType] +} +function (string) messageBox ["tk_messageBox"; option(messageBox) list] + +module Tkvars { + function (string) library ["$tk_library"] + function (string) patchLevel ["$tk_patchLevel"] + function (bool) strictMotif ["$tk_strictMotif"] + function () set_strictMotif ["set"; "tk_strictMotif"; bool] + function (string) version ["$tk_version"] } + +% Direct API calls, non Tcl-based modules + +module Pixmap { + external create "builtin/rawimg" + } + +%%% encodings : require if you want write your application international + +module Encoding { + function (string) convertfrom ["encoding"; "convertfrom"; + ?encoding: [string]; string] + function (string) convertto ["encoding"; "convertto"; + ?encoding: [string]; string] + function (string list) names ["encoding"; "names"] + function () system_set ["encoding"; "system"; string] + function (string) system_get ["encoding"; "system"] +} diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile index 547d10e88..97aafd41c 100644 --- a/otherlibs/labltk/browser/Makefile +++ b/otherlibs/labltk/browser/Makefile @@ -1,6 +1,6 @@ include ../support/Makefile.common -LABLTKLIB=-I ../lib -I ../support +LABLTKLIB=-I ../labltk -I ../lib -I ../support OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) @@ -20,22 +20,22 @@ JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ .SUFFIXES: .ml .mli .cmo .cmi .cmx .ml.cmo: - $(LABLCOMP) $(INCLUDES) $< + $(CAMLCOMP) $(INCLUDES) $< .mli.cmi: - $(LABLCOMP) $(INCLUDES) $< + $(CAMLCOMP) $(INCLUDES) $< all: ocamlbrowser$(EXE) ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \ - ../support/liblabltk41.a - $(LABLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ + ../support/lib$(LIBNAME).a + $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ $(DLLPATH) \ $(TOPDIR)/toplevel/toplevellib.cma \ - unix.cma str.cma labltk.cma jglib.cma $(OBJ) + unix.cma str.cma $(LIBNAME).cma jglib.cma $(OBJ) jglib.cma: $(JG) - $(LABLCOMP) -a -o jglib.cma $(JG) + $(CAMLCOMP) -a -o jglib.cma $(JG) #help.ml: help.txt # printf 'let text = "' > $@ @@ -50,7 +50,7 @@ clean: rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig depend: - $(LABLDEP) *.ml *.mli > .depend + $(CAMLDEP) *.ml *.mli > .depend dummy.mli: rm -f $@ diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt index caa8f1176..43b3828b2 100644 --- a/otherlibs/labltk/browser/Makefile.nt +++ b/otherlibs/labltk/browser/Makefile.nt @@ -1,6 +1,6 @@ !include ..\support\Makefile.common.nt -LABLTKLIB=-I ../lib -I ../support +LABLTKLIB=-I ../labltk -I ../lib -I ../support OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) @@ -21,35 +21,35 @@ JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ .SUFFIXES: .ml .mli .cmo .cmi .cmx .ml.cmo: - $(LABLCOMP) $(INCLUDES) $< + $(CAMLCOMP) $(INCLUDES) $< .mli.cmi: - $(LABLCOMP) $(INCLUDES) $< + $(CAMLCOMP) $(INCLUDES) $< -.c.obj: +y.c.obj: $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< all: ocamlbrowser.exe ocamlbrowser.exe: $(TOPDIR)/toplevel/toplevellib.cma \ - ..\support\liblabltk41.lib + ..\support\lib$(LIBNAME).lib ocamlbrowser.exe: jglib.cma $(OBJ) winmain.obj - $(LABLC) -o ocamlbrowser.exe -custom $(INCLUDES) \ + $(CAMLC) -o ocamlbrowser.exe -custom $(INCLUDES) \ $(TOPDIR)/toplevel/toplevellib.cma \ - unix.cma threads.cma str.cma labltk.cma jglib.cma $(OBJ) \ + unix.cma threads.cma str.cma $(LIBNAME).cma jglib.cma $(OBJ) \ winmain.obj -cclib "/subsystem:windows" jglib.cma: $(JG) - $(LABLCOMP) -a -o jglib.cma $(JG) + $(CAMLCOMP) -a -o jglib.cma $(JG) install: if exist ocamlbrowser.exe cp ocamlbrowser.exe $(BINDIR) clean: - rm -f *.cm? ocamlbrowser dummy.mli *~ *.orig + rm -f *.cm? ocamlbrowser.exe dummy.mli *~ *.orig *.obj *.pdb depend: - $(LABLDEP) *.ml *.mli > .depend + $(CAMLDEP) *.ml *.mli > .depend dummy.mli: cp dummyWin.mli dummy.mli diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 4302ad002..5e45718fe 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -255,7 +255,7 @@ let filter_modules () = Hashtbl.remove shown_modules key) shown_modules let add_shown_module path ~widgets = - Hashtbl'.add shown_modules ~key:path ~data:widgets + Hashtbl.add shown_modules path widgets let find_shown_module path = try filter_modules (); diff --git a/otherlibs/labltk/builtin/builtin_FilePattern.ml b/otherlibs/labltk/builtin/builtin_FilePattern.ml new file mode 100644 index 000000000..f7dd1d60e --- /dev/null +++ b/otherlibs/labltk/builtin/builtin_FilePattern.ml @@ -0,0 +1,20 @@ +(* File patterns *) +(* type *) +type filePattern = { + typename : string; + extensions : string list; + mactypes : string list + } +(* /type *) + +let cCAMLtoTKfilePattern fp = + let typename = TkQuote (TkToken fp.typename) in + let extensions = + TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.extensions)) in + let mactypes = + match fp.mactypes with + | [] -> [] + | [s] -> [TkToken s] + | _ -> [TkQuote (TkTokenList (List.map (fun x -> TkToken x) fp.mactypes))] + in + TkQuote (TkTokenList (typename :: extensions :: mactypes)) diff --git a/otherlibs/labltk/builtin/builtin_GetBitmap.ml b/otherlibs/labltk/builtin/builtin_GetBitmap.ml index 060d77d32..bf02d20f8 100644 --- a/otherlibs/labltk/builtin/builtin_GetBitmap.ml +++ b/otherlibs/labltk/builtin/builtin_GetBitmap.ml @@ -1,8 +1,22 @@ (* Tk_GetBitmap emulation *) + +##ifdef CAMLTK + +(* type *) +type bitmap = + | BitmapFile of string (* path of file *) + | Predefined of string (* bitmap name *) +;; +(* /type *) + +##else + (* type *) type bitmap = [ | `File of string (* path of file *) | `Predefined of string (* bitmap name *) ] +;; (* /type *) +##endif diff --git a/otherlibs/labltk/builtin/builtin_GetCursor.ml b/otherlibs/labltk/builtin/builtin_GetCursor.ml index 543fbc19c..4e7d61872 100644 --- a/otherlibs/labltk/builtin/builtin_GetCursor.ml +++ b/otherlibs/labltk/builtin/builtin_GetCursor.ml @@ -1,4 +1,21 @@ (* Color *) + +##ifdef CAMLTK + +(* type *) +type color = + | NamedColor of string + | Black (* tk keyword: black *) + | White (* tk keyword: white *) + | Red (* tk keyword: red *) + | Green (* tk keyword: green *) + | Blue (* tk keyword: blue *) + | Yellow (* tk keyword: yellow *) +;; +(* /type *) + +##else + (* type *) type color = [ | `Color of string @@ -9,8 +26,25 @@ type color = [ | `Blue (* tk keyword: blue *) | `Yellow (* tk keyword: yellow *) ] +;; (* /type *) +##endif + +##ifdef CAMLTK + +(* type *) +type cursor = + | XCursor of string + | XCursorFg of string * color + | XCursortFgBg of string * color * color + | CursorFileFg of string * color + | CursorMaskFile of string * string * color * color +;; +(* /type *) + +##else + (* Tk_GetCursor emulation *) (* type *) type cursor = [ @@ -20,5 +54,8 @@ type cursor = [ | `Cursorfilefg of string * color | `Cursormaskfile of string * string * color * color ] +;; (* /type *) +##endif + diff --git a/otherlibs/labltk/builtin/builtin_GetPixel.ml b/otherlibs/labltk/builtin/builtin_GetPixel.ml index 017893470..772a2c284 100644 --- a/otherlibs/labltk/builtin/builtin_GetPixel.ml +++ b/otherlibs/labltk/builtin/builtin_GetPixel.ml @@ -1,4 +1,19 @@ (* Tk_GetPixels emulation *) + +##ifdef CAMLTK + +(* type *) +type units = + | Pixels of int (* specified as floating-point, but inconvenient *) + | Centimeters of float + | Inches of float + | Millimeters of float + | PrinterPoint of float +;; +(* /type *) + +##else + (* type *) type units = [ | `Pix of int @@ -7,5 +22,7 @@ type units = [ | `Mm of float | `Pt of float ] +;; (* /type *) +##endif diff --git a/otherlibs/labltk/builtin/builtin_ScrollValue.ml b/otherlibs/labltk/builtin/builtin_ScrollValue.ml index 250fd2eda..20869c6da 100644 --- a/otherlibs/labltk/builtin/builtin_ScrollValue.ml +++ b/otherlibs/labltk/builtin/builtin_ScrollValue.ml @@ -1,8 +1,22 @@ +##ifdef CAMLTK + +(* type *) +type scrollValue = + | ScrollPage of int (* tk option: scroll <int> page *) + | ScrollUnit of int (* tk option: scroll <int> unit *) + | MoveTo of float (* tk option: moveto <float> *) +;; +(* /type *) + +##else + (* type *) type scrollValue = [ | `Page of int (* tk option: scroll <int> page *) | `Unit of int (* tk option: scroll <int> unit *) | `Moveto of float (* tk option: moveto <float> *) ] +;; (* /type *) +##endif diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml index e7c738dec..4f6d59598 100644 --- a/otherlibs/labltk/builtin/builtin_bind.ml +++ b/otherlibs/labltk/builtin/builtin_bind.ml @@ -1,9 +1,246 @@ -open Widget +##ifdef CAMLTK + +open Widget;; + +(* Events and bindings *) +(* Builtin types *) +(* type *) +type xEvent = + | Activate + | ButtonPress (* also Button, but we omit it *) + | ButtonPressDetail of int + | ButtonRelease + | ButtonReleaseDetail of int + | Circulate + | ColorMap (* not Colormap, avoiding confusion between the Colormap option *) + | Configure + | Deactivate + | Destroy + | Enter + | Expose + | FocusIn + | FocusOut + | Gravity + | KeyPress (* also Key, but we omit it *) + | KeyPressDetail of string (* /usr/include/X11/keysymdef.h *) + | KeyRelease + | KeyReleaseDetail of string + | Leave + | Map + | Motion + | Property + | Reparent + | Unmap + | Visibility + | Virtual of string (* Virtual event. Must be without modifiers *) +;; +(* /type *) + +(* type *) +type modifier = + | Control + | Shift + | Lock + | Button1 + | Button2 + | Button3 + | Button4 + | Button5 + | Double + | Triple + | Mod1 + | Mod2 + | Mod3 + | Mod4 + | Mod5 + | Meta + | Alt +;; +(* /type *) + +(* Event structure, passed to bounded functions *) + +(* type *) +type eventInfo = + { + (* %# : event serial number is unsupported *) + mutable ev_Above : int; (* tk: %a *) + mutable ev_ButtonNumber : int; (* tk: %b *) + mutable ev_Count : int; (* tk: %c *) + mutable ev_Detail : string; (* tk: %d *) + mutable ev_Focus : bool; (* tk: %f *) + mutable ev_Height : int; (* tk: %h *) + mutable ev_KeyCode : int; (* tk: %k *) + mutable ev_Mode : string; (* tk: %m *) + mutable ev_OverrideRedirect : bool; (* tk: %o *) + mutable ev_Place : string; (* tk: %p *) + mutable ev_State : string; (* tk: %s *) + mutable ev_Time : int; (* tk: %t *) + mutable ev_Width : int; (* tk: %w *) + mutable ev_MouseX : int; (* tk: %x *) + mutable ev_MouseY : int; (* tk: %y *) + mutable ev_Char : string; (* tk: %A *) + mutable ev_BorderWidth : int; (* tk: %B *) + mutable ev_SendEvent : bool; (* tk: %E *) + mutable ev_KeySymString : string; (* tk: %K *) + mutable ev_KeySymInt : int; (* tk: %N *) + mutable ev_RootWindow : int; (* tk: %R *) + mutable ev_SubWindow : int; (* tk: %S *) + mutable ev_Type : int; (* tk: %T *) + mutable ev_Widget : widget; (* tk: %W *) + mutable ev_RootX : int; (* tk: %X *) + mutable ev_RootY : int (* tk: %Y *) + } +;; +(* /type *) + + +(* To avoid collision with other constructors (Width, State), + use Ev_ prefix *) +(* type *) +type eventField = + | Ev_Above + | Ev_ButtonNumber + | Ev_Count + | Ev_Detail + | Ev_Focus + | Ev_Height + | Ev_KeyCode + | Ev_Mode + | Ev_OverrideRedirect + | Ev_Place + | Ev_State + | Ev_Time + | Ev_Width + | Ev_MouseX + | Ev_MouseY + | Ev_Char + | Ev_BorderWidth + | Ev_SendEvent + | Ev_KeySymString + | Ev_KeySymInt + | Ev_RootWindow + | Ev_SubWindow + | Ev_Type + | Ev_Widget + | Ev_RootX + | Ev_RootY +;; +(* /type *) + +let filleventInfo ev v = function + | Ev_Above -> ev.ev_Above <- int_of_string v + | Ev_ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v + | Ev_Count -> ev.ev_Count <- int_of_string v + | Ev_Detail -> ev.ev_Detail <- v + | Ev_Focus -> ev.ev_Focus <- v = "1" + | Ev_Height -> ev.ev_Height <- int_of_string v + | Ev_KeyCode -> ev.ev_KeyCode <- int_of_string v + | Ev_Mode -> ev.ev_Mode <- v + | Ev_OverrideRedirect -> ev.ev_OverrideRedirect <- v = "1" + | Ev_Place -> ev.ev_Place <- v + | Ev_State -> ev.ev_State <- v + | Ev_Time -> ev.ev_Time <- int_of_string v + | Ev_Width -> ev.ev_Width <- int_of_string v + | Ev_MouseX -> ev.ev_MouseX <- int_of_string v + | Ev_MouseY -> ev.ev_MouseY <- int_of_string v + | Ev_Char -> ev.ev_Char <- v + | Ev_BorderWidth -> ev.ev_BorderWidth <- int_of_string v + | Ev_SendEvent -> ev.ev_SendEvent <- v = "1" + | Ev_KeySymString -> ev.ev_KeySymString <- v + | Ev_KeySymInt -> ev.ev_KeySymInt <- int_of_string v + | Ev_RootWindow -> ev.ev_RootWindow <- int_of_string v + | Ev_SubWindow -> ev.ev_SubWindow <- int_of_string v + | Ev_Type -> ev.ev_Type <- int_of_string v + | Ev_Widget -> ev.ev_Widget <- cTKtoCAMLwidget v + | Ev_RootX -> ev.ev_RootX <- int_of_string v + | Ev_RootY -> ev.ev_RootY <- int_of_string v +;; + +let wrapeventInfo f what = + let ev = { + ev_Above = 0; + ev_ButtonNumber = 0; + ev_Count = 0; + ev_Detail = ""; + ev_Focus = false; + ev_Height = 0; + ev_KeyCode = 0; + ev_Mode = ""; + ev_OverrideRedirect = false; + ev_Place = ""; + ev_State = ""; + ev_Time = 0; + ev_Width = 0; + ev_MouseX = 0; + ev_MouseY = 0; + ev_Char = ""; + ev_BorderWidth = 0; + ev_SendEvent = false; + ev_KeySymString = ""; + ev_KeySymInt = 0; + ev_RootWindow = 0; + ev_SubWindow = 0; + ev_Type = 0; + ev_Widget = Widget.default_toplevel; + ev_RootX = 0; + ev_RootY = 0 } in + function args -> + let l = ref args in + List.iter (function field -> + match !l with + [] -> () + | v::rest -> filleventInfo ev v field; l:=rest) + what; + f ev +;; + +let rec writeeventField = function + | [] -> "" + | field::rest -> + begin + match field with + | Ev_Above -> " %a" + | Ev_ButtonNumber ->" %b" + | Ev_Count -> " %c" + | Ev_Detail -> " %d" + | Ev_Focus -> " %f" + | Ev_Height -> " %h" + | Ev_KeyCode -> " %k" + | Ev_Mode -> " %m" + | Ev_OverrideRedirect -> " %o" + | Ev_Place -> " %p" + | Ev_State -> " %s" + | Ev_Time -> " %t" + | Ev_Width -> " %w" + | Ev_MouseX -> " %x" + | Ev_MouseY -> " %y" + (* Quoting is done by Tk *) + | Ev_Char -> " %A" + | Ev_BorderWidth -> " %B" + | Ev_SendEvent -> " %E" + | Ev_KeySymString -> " %K" + | Ev_KeySymInt -> " %N" + | Ev_RootWindow ->" %R" + | Ev_SubWindow -> " %S" + | Ev_Type -> " %T" + | Ev_Widget ->" %W" + | Ev_RootX -> " %X" + | Ev_RootY -> " %Y" + end + ^ writeeventField rest +;; + +##else + +open Widget;; (* Events and bindings *) (* Builtin types *) + (* type *) type event = [ + | `Activate | `ButtonPress (* also Button, but we omit it *) | `ButtonPressDetail of int | `ButtonRelease @@ -11,6 +248,7 @@ type event = [ | `Circulate | `Colormap | `Configure + | `Deactivate | `Destroy | `Enter | `Expose @@ -28,6 +266,7 @@ type event = [ | `Reparent | `Unmap | `Visibility + | `Virtual of string (* Virtual event. Must be without modifiers *) | `Modified of modifier list * event ] @@ -50,40 +289,42 @@ and modifier = [ | `Meta | `Alt ] +;; (* /type *) (* Event structure, passed to bounded functions *) (* type *) -type eventInfo = - { - mutable ev_Above : int; (* tk: %a *) - mutable ev_ButtonNumber : int; (* tk: %b *) - mutable ev_Count : int; (* tk: %c *) - mutable ev_Detail : string; (* tk: %d *) - mutable ev_Focus : bool; (* tk: %f *) - mutable ev_Height : int; (* tk: %h *) - mutable ev_KeyCode : int; (* tk: %k *) - mutable ev_Mode : string; (* tk: %m *) - mutable ev_OverrideRedirect : bool; (* tk: %o *) - mutable ev_Place : string; (* tk: %p *) - mutable ev_State : string; (* tk: %s *) - mutable ev_Time : int; (* tk: %t *) - mutable ev_Width : int; (* tk: %w *) - mutable ev_MouseX : int; (* tk: %x *) - mutable ev_MouseY : int; (* tk: %y *) - mutable ev_Char : string; (* tk: %A *) - mutable ev_BorderWidth : int; (* tk: %B *) - mutable ev_SendEvent : bool; (* tk: %E *) - mutable ev_KeySymString : string; (* tk: %K *) - mutable ev_KeySymInt : int; (* tk: %N *) - mutable ev_RootWindow : int; (* tk: %R *) - mutable ev_SubWindow : int; (* tk: %S *) - mutable ev_Type : int; (* tk: %T *) - mutable ev_Widget : any widget; (* tk: %W *) - mutable ev_RootX : int; (* tk: %X *) - mutable ev_RootY : int (* tk: %Y *) +type eventInfo = { + (* %# : event serial number is unsupported *) + mutable ev_Above : int; (* tk: %a *) + mutable ev_ButtonNumber : int; (* tk: %b *) + mutable ev_Count : int; (* tk: %c *) + mutable ev_Detail : string; (* tk: %d *) + mutable ev_Focus : bool; (* tk: %f *) + mutable ev_Height : int; (* tk: %h *) + mutable ev_KeyCode : int; (* tk: %k *) + mutable ev_Mode : string; (* tk: %m *) + mutable ev_OverrideRedirect : bool; (* tk: %o *) + mutable ev_Place : string; (* tk: %p *) + mutable ev_State : string; (* tk: %s *) + mutable ev_Time : int; (* tk: %t *) + mutable ev_Width : int; (* tk: %w *) + mutable ev_MouseX : int; (* tk: %x *) + mutable ev_MouseY : int; (* tk: %y *) + mutable ev_Char : string; (* tk: %A *) + mutable ev_BorderWidth : int; (* tk: %B *) + mutable ev_SendEvent : bool; (* tk: %E *) + mutable ev_KeySymString : string; (* tk: %K *) + mutable ev_KeySymInt : int; (* tk: %N *) + mutable ev_RootWindow : int; (* tk: %R *) + mutable ev_SubWindow : int; (* tk: %S *) + mutable ev_Type : int; (* tk: %T *) + mutable ev_Widget : any widget; (* tk: %W *) + mutable ev_RootX : int; (* tk: %X *) + mutable ev_RootY : int (* tk: %Y *) } +;; (* /type *) @@ -118,6 +359,7 @@ type eventField = [ | `RootX | `RootY ] +;; (* /type *) let filleventInfo ev v : eventField -> unit = function @@ -147,6 +389,7 @@ let filleventInfo ev v : eventField -> unit = function | `Widget -> ev.ev_Widget <- cTKtoCAMLwidget v | `RootX -> ev.ev_RootX <- int_of_string v | `RootY -> ev.ev_RootY <- int_of_string v +;; let wrapeventInfo f (what : eventField list) = let ev = { @@ -185,8 +428,7 @@ let wrapeventInfo f (what : eventField list) = | v :: rest -> filleventInfo ev v field; l := rest end; f ev - - +;; let rec writeeventField : eventField list -> string = function | [] -> "" @@ -222,3 +464,6 @@ let rec writeeventField : eventField list -> string = function | `RootY -> " %Y" end ^ writeeventField rest +;; + +##endif diff --git a/otherlibs/labltk/builtin/builtin_bindtags.ml b/otherlibs/labltk/builtin/builtin_bindtags.ml index a775188ee..e94c9668e 100644 --- a/otherlibs/labltk/builtin/builtin_bindtags.ml +++ b/otherlibs/labltk/builtin/builtin_bindtags.ml @@ -1,7 +1,21 @@ +##ifdef CAMLTK + +(* type *) +type bindings = + | TagBindings of string (* tk option: <string> *) + | WidgetBindings of widget (* tk option: <widget> *) +;; +(* /type *) + +##else + (* type *) type bindings = [ | `Tag of string (* tk option: <string> *) | `Widget of any widget (* tk option: <widget> *) ] +;; (* /type *) +##endif + diff --git a/otherlibs/labltk/builtin/builtin_font.ml b/otherlibs/labltk/builtin/builtin_font.ml new file mode 100644 index 000000000..615f937e3 --- /dev/null +++ b/otherlibs/labltk/builtin/builtin_font.ml @@ -0,0 +1,2 @@ +type font = string + diff --git a/otherlibs/labltk/builtin/builtin_index.ml b/otherlibs/labltk/builtin/builtin_index.ml index 750019b1c..3735fc040 100644 --- a/otherlibs/labltk/builtin/builtin_index.ml +++ b/otherlibs/labltk/builtin/builtin_index.ml @@ -4,6 +4,35 @@ listbox *) +##ifdef CAMLTK + +(* A large type for all indices in all widgets *) +(* a bit overkill though *) + +(* type *) +type index = + | Number of int (* no keyword *) + | ActiveElement (* tk keyword: active *) + | End (* tk keyword: end *) + | Last (* tk keyword: last *) + | NoIndex (* tk keyword: none *) + | Insert (* tk keyword: insert *) + | SelFirst (* tk keyword: sel.first *) + | SelLast (* tk keyword: sel.last *) + | At of int (* tk keyword: @n *) + | AtXY of int * int (* tk keyword: @x,y *) + | AnchorPoint (* tk keyword: anchor *) + | Pattern of string (* no keyword *) + | LineChar of int * int (* tk keyword: l.c *) + | Mark of string (* no keyword *) + | TagFirst of string (* tk keyword: tag.first *) + | TagLast of string (* tk keyword: tag.last *) + | Embedded of widget (* no keyword *) +;; +(* /type *) + +##else + type canvas_index = [ | `Num of int | `End @@ -12,6 +41,7 @@ type canvas_index = [ | `Sellast | `Atxy of int * int ] +;; type entry_index = [ | `Num of int @@ -22,6 +52,7 @@ type entry_index = [ | `At of int | `Anchor ] +;; type listbox_index = [ | `Num of int @@ -30,6 +61,7 @@ type listbox_index = [ | `End | `Atxy of int * int ] +;; type menu_index = [ | `Num of int @@ -40,6 +72,7 @@ type menu_index = [ | `At of int | `Pattern of string ] +;; type text_index = [ | `Linechar of int * int @@ -51,6 +84,9 @@ type text_index = [ | `Window of any widget | `Image of string ] +;; + +type linechar_index = int * int;; +type num_index = int;; -type linechar_index = int * int -type num_index = int +##endif diff --git a/otherlibs/labltk/builtin/builtin_palette.ml b/otherlibs/labltk/builtin/builtin_palette.ml index 5c327f9f5..4eab69a0f 100644 --- a/otherlibs/labltk/builtin/builtin_palette.ml +++ b/otherlibs/labltk/builtin/builtin_palette.ml @@ -1,7 +1,20 @@ +##ifdef CAMLTK + +(* type *) +type paletteType = + | GrayShades of int + | RGBShades of int * int * int +;; +(* /type *) + +##else + (* type *) type paletteType = [ | `Gray of int | `Rgb of int * int * int ] +;; (* /type *) +##endif diff --git a/otherlibs/labltk/builtin/builtin_text.ml b/otherlibs/labltk/builtin/builtin_text.ml index f81c7f2fb..d4333dcb5 100644 --- a/otherlibs/labltk/builtin/builtin_text.ml +++ b/otherlibs/labltk/builtin/builtin_text.ml @@ -1,13 +1,35 @@ (* Not a string as such, more like a symbol *) (* type *) -type textMark = string +type textMark = string;; (* /type *) (* type *) -type textTag = string +type textTag = string;; (* /type *) +##ifdef CAMLTK + +(* type *) +type textModifier = + | CharOffset of int (* tk keyword: +/- Xchars *) + | LineOffset of int (* tk keyword: +/- Xlines *) + | LineStart (* tk keyword: linestart *) + | LineEnd (* tk keyword: lineend *) + | WordStart (* tk keyword: wordstart *) + | WordEnd (* tk keyword: wordend *) +;; +(* /type *) + +(* type *) +type textIndex = + | TextIndex of index * textModifier list + | TextIndexNone +;; +(* /type *) + +##else + (* type *) type textModifier = [ | `Char of int (* tk keyword: +/- Xchars *) @@ -17,8 +39,12 @@ type textModifier = [ | `Wordstart (* tk keyword: wordstart *) | `Wordend (* tk keyword: wordend *) ] +;; (* /type *) (* type *) type textIndex = text_index * textModifier list +;; (* /type *) + +##endif diff --git a/otherlibs/labltk/builtin/builtinf_GetPixel.ml b/otherlibs/labltk/builtin/builtinf_GetPixel.ml index 50c434011..7e7c596bc 100644 --- a/otherlibs/labltk/builtin/builtinf_GetPixel.ml +++ b/otherlibs/labltk/builtin/builtinf_GetPixel.ml @@ -1,3 +1,16 @@ +##ifdef CAMLTK + +let pixels units = + let res = + tkEval + [|TkToken"winfo"; + TkToken"pixels"; + cCAMLtoTKwidget widget_any_table default_toplevel; + cCAMLtoTKunits units|] in + int_of_string res + +##else + let pixels units = let res = tkEval @@ -6,3 +19,5 @@ let pixels units = cCAMLtoTKwidget default_toplevel; cCAMLtoTKunits units|] in int_of_string res + +##endif diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml index 33bd10e84..e6b793d6d 100644 --- a/otherlibs/labltk/builtin/builtinf_bind.ml +++ b/otherlibs/labltk/builtin/builtinf_bind.ml @@ -1,3 +1,95 @@ +##ifdef CAMLTK + +(* type *) +type bindAction = + | BindSet of eventField list * (eventInfo -> unit) + | BindSetBreakable of eventField list * (eventInfo -> unit) + | BindRemove + | BindExtend of eventField list * (eventInfo -> unit) +(* /type *) + +(* +FUNCTION + val bind: + widget -> (modifier list * xEvent) list -> bindAction -> unit +/FUNCTION +*) +let bind widget eventsequence action = + tkCommand [| TkToken "bind"; + TkToken (Widget.name widget); + cCAMLtoTKeventSequence eventsequence; + begin match action with + BindRemove -> TkToken "" + | BindSet (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) + in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + | BindSetBreakable (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) + in + TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0") + | BindExtend (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) + in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + end |] +;; + +(* FUNCTION +(* unsafe *) + val bind_class : + string -> (modifier list * xEvent) list -> bindAction -> unit +(* /unsafe *) +/FUNCTION class arg is not constrained *) + +let bind_class clas eventsequence action = + tkCommand [| TkToken "bind"; + TkToken clas; + cCAMLtoTKeventSequence eventsequence; + begin match action with + BindRemove -> TkToken "" + | BindSet (what, f) -> + let cbId = register_callback Widget.dummy + (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + | BindSetBreakable (what, f) -> + let cbId = register_callback Widget.dummy + (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" ) + | BindExtend (what, f) -> + let cbId = register_callback Widget.dummy + (wrapeventInfo f what) in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + end |] +;; + +(* FUNCTION +(* unsafe *) + val bind_tag : + string -> (modifier list * xEvent) list -> bindAction -> unit +(* /unsafe *) +/FUNCTION *) + +let bind_tag = bind_class +;; + +(* +FUNCTION + val break : unit -> unit +/FUNCTION +*) +let break = function () -> + Textvariable.set (Textvariable.coerce "BreakBindingsSequence") "1" +;; + +(* Legacy functions *) +let tag_bind = bind_tag;; +let class_bind = bind_class;; + +##else + let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = []) ?action ?on:widget name = let widget = match widget with None -> Widget.dummy | Some w -> coe w in @@ -19,12 +111,15 @@ let bind_class ~events ?(extend = false) ?(breakable = false) ?(fields = []) TkToken cb end |] +;; let bind ~events ?extend ?breakable ?fields ?action widget = bind_class ~events ?extend ?breakable ?fields ?action ~on:widget (Widget.name widget) +;; let bind_tag = bind_class +;; (* FUNCTION @@ -33,3 +128,6 @@ FUNCTION *) let break = function () -> tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |] +;; + +##endif diff --git a/otherlibs/labltk/builtin/builtini_GetBitmap.ml b/otherlibs/labltk/builtin/builtini_GetBitmap.ml index 0fff321bd..1afa0cd91 100644 --- a/otherlibs/labltk/builtin/builtini_GetBitmap.ml +++ b/otherlibs/labltk/builtin/builtini_GetBitmap.ml @@ -1,10 +1,28 @@ +##ifdef CAMLTK + +let cCAMLtoTKbitmap = function + BitmapFile s -> TkToken ("@" ^ s) +| Predefined s -> TkToken s +;; + +let cTKtoCAMLbitmap s = + if s = "" then Predefined "" + else if String.get s 0 = '@' + then BitmapFile (String.sub s 1 (String.length s - 1)) + else Predefined s +;; + +##else + let cCAMLtoTKbitmap : bitmap -> tkArgs = function | `File s -> TkToken ("@" ^ s) | `Predefined s -> TkToken s +;; let cTKtoCAMLbitmap s = if String.get s 0 = '@' then `File (String.sub s ~pos:1 ~len:(String.length s - 1)) else `Predefined s +;; - +##endif diff --git a/otherlibs/labltk/builtin/builtini_GetCursor.ml b/otherlibs/labltk/builtin/builtini_GetCursor.ml index a1d312db6..b3e1af075 100644 --- a/otherlibs/labltk/builtin/builtini_GetCursor.ml +++ b/otherlibs/labltk/builtin/builtini_GetCursor.ml @@ -1,3 +1,32 @@ +##ifdef CAMLTK + +let cCAMLtoTKcolor = function + NamedColor x -> TkToken x + | Black -> TkToken "black" + | White -> TkToken "white" + | Red -> TkToken "red" + | Green -> TkToken "green" + | Blue -> TkToken "blue" + | Yellow -> TkToken "yellow" +;; + +let cTKtoCAMLcolor = function s -> NamedColor s +;; + +let cCAMLtoTKcursor = function + XCursor s -> TkToken s + | XCursorFg (s,fg) -> + TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg]) + | XCursortFgBg (s,fg,bg) -> + TkQuote(TkTokenList [TkToken s; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) + | CursorFileFg (s,fg) -> + TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) + | CursorMaskFile (s,m,fg,bg) -> + TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) +;; + +##else + let cCAMLtoTKcolor : color -> tkArgs = function | `Color x -> TkToken x | `Black -> TkToken "black" @@ -6,9 +35,10 @@ let cCAMLtoTKcolor : color -> tkArgs = function | `Green -> TkToken "green" | `Blue -> TkToken "blue" | `Yellow -> TkToken "yellow" +;; let cTKtoCAMLcolor = function s -> `Color s - +;; let cCAMLtoTKcursor : cursor -> tkArgs = function | `Xcursor s -> TkToken s @@ -20,5 +50,6 @@ let cCAMLtoTKcursor : cursor -> tkArgs = function TkQuote(TkTokenList [TkToken ("@"^s); cCAMLtoTKcolor fg]) | `Cursormaskfile (s,m,fg,bg) -> TkQuote(TkTokenList [TkToken ("@"^s); TkToken m; cCAMLtoTKcolor fg; cCAMLtoTKcolor bg]) +;; - +##endif diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml index c1ebdb17d..65df3d31a 100644 --- a/otherlibs/labltk/builtin/builtini_GetPixel.ml +++ b/otherlibs/labltk/builtin/builtini_GetPixel.ml @@ -1,9 +1,33 @@ +##ifdef CAMLTK + +let cCAMLtoTKunits = function + Pixels (foo) -> TkToken (string_of_int foo) + | Millimeters (foo) -> TkToken(string_of_float foo^"m") + | Inches (foo) -> TkToken(string_of_float foo^"i") + | PrinterPoint (foo) -> TkToken(string_of_float foo^"p") + | Centimeters (foo) -> TkToken(string_of_float foo^"c") +;; + +let cTKtoCAMLunits str = + let len = String.length str in + let num_part str = String.sub str 0 (len - 1) in + match String.get str (pred len) with + 'c' -> Centimeters (float_of_string (num_part str)) + | 'i' -> Inches (float_of_string (num_part str)) + | 'm' -> Millimeters (float_of_string (num_part str)) + | 'p' -> PrinterPoint (float_of_string (num_part str)) + | _ -> Pixels(int_of_string str) +;; + +##else + let cCAMLtoTKunits : units -> tkArgs = function | `Pix (foo) -> TkToken (string_of_int foo) | `Mm (foo) -> TkToken(string_of_float foo^"m") | `In (foo) -> TkToken(string_of_float foo^"i") | `Pt (foo) -> TkToken(string_of_float foo^"p") | `Cm (foo) -> TkToken(string_of_float foo^"c") +;; let cTKtoCAMLunits str = let len = String.length str in @@ -14,4 +38,6 @@ let cTKtoCAMLunits str = | 'm' -> `Mm (float_of_string (num_part str)) | 'p' -> `Pt (float_of_string (num_part str)) | _ -> `Pix(int_of_string str) +;; +##endif diff --git a/otherlibs/labltk/builtin/builtini_ScrollValue.ml b/otherlibs/labltk/builtin/builtini_ScrollValue.ml index 28110337d..0361238b4 100644 --- a/otherlibs/labltk/builtin/builtini_ScrollValue.ml +++ b/otherlibs/labltk/builtin/builtini_ScrollValue.ml @@ -1,3 +1,27 @@ +##ifdef CAMLTK + +let cCAMLtoTKscrollValue = function + ScrollPage v1 -> + TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] + | ScrollUnit v1 -> + TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] + | MoveTo v1 -> + TkTokenList [TkToken"moveto"; TkToken (string_of_float v1)] +;; + +(* str l -> scrllv -> str l *) +let cTKtoCAMLscrollValue = function + "scroll"::n::"pages"::l -> + ScrollPage (int_of_string n), l + | "scroll"::n::"units"::l -> + ScrollUnit (int_of_string n), l + | "moveto"::f::l -> + MoveTo (float_of_string f), l + | _ -> raise (Invalid_argument "TKtoCAMLscrollValue") +;; + +##else + let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function | `Page v1 -> TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"pages"] @@ -5,6 +29,7 @@ let cCAMLtoTKscrollValue : scrollValue -> tkArgs = function TkTokenList [TkToken"scroll"; TkToken (string_of_int v1); TkToken"units"] | `Moveto v1 -> TkTokenList [TkToken"moveto"; TkToken (string_of_float v1)] +;; (* str l -> scrllv -> str l *) let cTKtoCAMLscrollValue = function @@ -15,3 +40,6 @@ let cTKtoCAMLscrollValue = function | "moveto" :: f :: l -> `Moveto (float_of_string f), l | _ -> raise (Invalid_argument "TKtoCAMLscrollValue") +;; + +##endif diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml index f00182db7..101e26186 100644 --- a/otherlibs/labltk/builtin/builtini_bind.ml +++ b/otherlibs/labltk/builtin/builtini_bind.ml @@ -1,3 +1,74 @@ +##ifdef CAMLTK + +let cCAMLtoTKxEvent = function + | Activate -> "Activate" + | ButtonPress -> "ButtonPress" + | ButtonPressDetail n -> "ButtonPress-"^string_of_int n + | ButtonRelease -> "ButtonRelease" + | ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n + | Circulate -> "Circulate" + | ColorMap -> "Colormap" + | Configure -> "Configure" + | Deactivate -> "Deactivate" + | Destroy -> "Destroy" + | Enter -> "Enter" + | Expose -> "Expose" + | FocusIn -> "FocusIn" + | FocusOut -> "FocusOut" + | Gravity -> "Gravity" + | KeyPress -> "KeyPress" + | KeyPressDetail s -> "KeyPress-"^s + | KeyRelease -> "KeyRelease" + | KeyReleaseDetail s -> "KeyRelease-"^s + | Leave -> "Leave" + | Map -> "Map" + | Motion -> "Motion" + | Property -> "Property" + | Reparent -> "Reparent" + | Unmap -> "Unmap" + | Visibility -> "Visibility" + | Virtual s -> "<"^s^">" +;; + +let cCAMLtoTKmodifier = function + | Control -> "Control-" + | Shift -> "Shift-" + | Lock -> "Lock-" + | Button1 -> "Button1-" + | Button2 -> "Button2-" + | Button3 -> "Button3-" + | Button4 -> "Button4-" + | Button5 -> "Button5-" + | Double -> "Double-" + | Triple -> "Triple-" + | Mod1 -> "Mod1-" + | Mod2 -> "Mod2-" + | Mod3 -> "Mod3-" + | Mod4 -> "Mod4-" + | Mod5 -> "Mod5-" + | Meta -> "Meta-" + | Alt -> "Alt-" +;; + +exception IllegalVirtualEvent + +(* type event = modifier list * xEvent *) +let cCAMLtoTKevent (ml, xe) = + match xe with + | Virtual s -> + if ml = [] then "<<"^s^">>" + else raise IllegalVirtualEvent + | _ -> + "<" ^ (String.concat " " (List.map cCAMLtoTKmodifier ml)) + ^ (cCAMLtoTKxEvent xe) ^ ">" +;; + +(* type eventSequence == (modifier list * xEvent) list *) +let cCAMLtoTKeventSequence l = + TkToken(List.fold_left (^) "" (List.map cCAMLtoTKevent l)) + +##else + let cCAMLtoTKmodifier : modifier -> string = function | `Control -> "Control-" | `Shift -> "Shift-" @@ -16,39 +87,50 @@ let cCAMLtoTKmodifier : modifier -> string = function | `Mod5 -> "Mod5-" | `Meta -> "Meta-" | `Alt -> "Alt-" +;; + +exception IllegalVirtualEvent let cCAMLtoTKevent (ev : event) = + let modified = ref false in let rec convert = function - | `ButtonPress -> "ButtonPress" - | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n - | `ButtonRelease -> "ButtonRelease" - | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n - | `Circulate -> "Circulate" - | `Colormap -> "Colormap" - | `Configure -> "Configure" - | `Destroy -> "Destroy" - | `Enter -> "Enter" - | `Expose -> "Expose" - | `FocusIn -> "FocusIn" - | `FocusOut -> "FocusOut" - | `Gravity -> "Gravity" - | `KeyPress -> "KeyPress" - | `KeyPressDetail s -> "KeyPress-"^s - | `KeyRelease -> "KeyRelease" - | `KeyReleaseDetail s -> "KeyRelease-"^s - | `Leave -> "Leave" - | `Map -> "Map" - | `Motion -> "Motion" - | `Property -> "Property" - | `Reparent -> "Reparent" - | `Unmap -> "Unmap" - | `Visibility -> "Visibility" - | `Modified(ml, ev) -> - String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml) - ^ convert ev + | `Activate -> "Activate" + | `ButtonPress -> "ButtonPress" + | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n + | `ButtonRelease -> "ButtonRelease" + | `ButtonReleaseDetail n -> "ButtonRelease-"^string_of_int n + | `Circulate -> "Circulate" + | `Colormap -> "Colormap" + | `Configure -> "Configure" + | `Deactivate -> "Deactivate" + | `Destroy -> "Destroy" + | `Enter -> "Enter" + | `Expose -> "Expose" + | `FocusIn -> "FocusIn" + | `FocusOut -> "FocusOut" + | `Gravity -> "Gravity" + | `KeyPress -> "KeyPress" + | `KeyPressDetail s -> "KeyPress-"^s + | `KeyRelease -> "KeyRelease" + | `KeyReleaseDetail s -> "KeyRelease-"^s + | `Leave -> "Leave" + | `Map -> "Map" + | `Motion -> "Motion" + | `Property -> "Property" + | `Reparent -> "Reparent" + | `Unmap -> "Unmap" + | `Visibility -> "Visibility" + | `Virtual s -> + if !modified then raise IllegalVirtualEvent else "<"^s^">" + | `Modified(ml, ev) -> + modified := true; + String.concat ~sep:"" (List.map ~f:cCAMLtoTKmodifier ml) + ^ convert ev in "<" ^ convert ev ^ ">" +;; let cCAMLtoTKeventSequence (l : event list) = TkToken(String.concat ~sep:"" (List.map ~f:cCAMLtoTKevent l)) +;; - +##endif diff --git a/otherlibs/labltk/builtin/builtini_bindtags.ml b/otherlibs/labltk/builtin/builtini_bindtags.ml index 9b27563e1..e09734870 100644 --- a/otherlibs/labltk/builtin/builtini_bindtags.ml +++ b/otherlibs/labltk/builtin/builtini_bindtags.ml @@ -1,9 +1,29 @@ +##ifdef CAMLTK + +let cCAMLtoTKbindings = function + | WidgetBindings v1 -> cCAMLtoTKwidget widget_any_table v1 + | TagBindings v1 -> TkToken v1 +;; + +(* this doesn't really belong here *) +let cTKtoCAMLbindings s = + if String.length s > 0 && s.[0] = '.' then + WidgetBindings (cTKtoCAMLwidget s) + else TagBindings s +;; + +##else + let cCAMLtoTKbindings = function | `Widget v1 -> cCAMLtoTKwidget v1 | `Tag v1 -> TkToken v1 +;; (* this doesn't really belong here *) let cTKtoCAMLbindings s = if String.length s > 0 && s.[0] = '.' then `Widget (cTKtoCAMLwidget s) else `Tag s +;; + +##endif diff --git a/otherlibs/labltk/builtin/builtini_font.ml b/otherlibs/labltk/builtin/builtini_font.ml new file mode 100644 index 000000000..521b24d6d --- /dev/null +++ b/otherlibs/labltk/builtin/builtini_font.ml @@ -0,0 +1,3 @@ +let cCAMLtoTKfont (s : font) = TkToken s +let cTKtoCAMLfont (s : font) = s + diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml index 0e48a4b83..9e43c4f76 100644 --- a/otherlibs/labltk/builtin/builtini_index.ml +++ b/otherlibs/labltk/builtin/builtini_index.ml @@ -1,3 +1,97 @@ +##ifdef CAMLTK + +(* sp to avoid being picked up by doc scripts *) + type index_constrs = + CNumber + | CActiveElement + | CEnd + | CLast + | CNoIndex + | CInsert + | CSelFirst + | CSelLast + | CAt + | CAtXY + | CAnchorPoint + | CPattern + | CLineChar + | CMark + | CTagFirst + | CTagLast + | CEmbedded +;; + +let index_any_table = + [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CInsert; CSelFirst; + CSelLast; CAt; CAtXY; CAnchorPoint; CPattern; CLineChar; + CMark; CTagFirst; CTagLast; CEmbedded] +;; + +let index_canvas_table = + [CNumber; CEnd; CInsert; CSelFirst; CSelLast; CAtXY] +;; +let index_entry_table = + [CNumber; CAnchorPoint; CEnd; CInsert; CSelFirst; CSelLast; CAt] +;; +let index_listbox_table = + [CNumber; CActiveElement; CAnchorPoint; CEnd; CAtXY] +;; +let index_menu_table = + [CNumber; CActiveElement; CEnd; CLast; CNoIndex; CAt; CPattern] +;; +let index_text_table = + [CLineChar; CAtXY; CEnd; CMark; CTagFirst; CTagLast; CEmbedded] +;; + +let cCAMLtoTKindex table = function + Number x -> chk_sub "Number" table CNumber; TkToken (string_of_int x) + | ActiveElement -> chk_sub "ActiveElement" table CActiveElement; TkToken "active" + | End -> chk_sub "End" table CEnd; TkToken "end" + | Last -> chk_sub "Last" table CLast; TkToken "last" + | NoIndex -> chk_sub "NoIndex" table CNoIndex; TkToken "none" + | Insert -> chk_sub "Insert" table CInsert; TkToken "insert" + | SelFirst -> chk_sub "SelFirst" table CSelFirst; TkToken "sel.first" + | SelLast -> chk_sub "SelLast" table CSelLast; TkToken "sel.last" + | At n -> chk_sub "At" table CAt; TkToken ("@"^string_of_int n) + | AtXY (x,y) -> chk_sub "AtXY" table CAtXY; + TkToken ("@"^string_of_int x^","^string_of_int y) + | AnchorPoint -> chk_sub "AnchorPoint" table CAnchorPoint; TkToken "anchor" + | Pattern s -> chk_sub "Pattern" table CPattern; TkToken s + | LineChar (l,c) -> chk_sub "LineChar" table CLineChar; + TkToken (string_of_int l^"."^string_of_int c) + | Mark s -> chk_sub "Mark" table CMark; TkToken s + | TagFirst t -> chk_sub "TagFirst" table CTagFirst; + TkToken (t^".first") + | TagLast t -> chk_sub "TagLast" table CTagLast; + TkToken (t^".last") + | Embedded w -> chk_sub "Embedded" table CEmbedded; + cCAMLtoTKwidget widget_any_table w +;; + +let char_index c s = + let rec find i = + if i >= String.length s + then raise Not_found + else if String.get s i = c then i + else find (i+1) in + find 0 +;; + +(* Assume returned values are only numerical and l.c *) +(* .menu index returns none if arg is none, but blast it *) +let cTKtoCAMLindex s = + try + let p = char_index '.' s in + LineChar(int_of_string (String.sub s 0 p), + int_of_string (String.sub s (p+1) (String.length s - p - 1))) + with + Not_found -> + try Number (int_of_string s) + with _ -> raise (Invalid_argument ("TKtoCAMLindex: "^s)) +;; + +##else + let cCAMLtoTKindex (* Don't put explicit typing *) = function | `Num x -> TkToken (string_of_int x) | `Active -> TkToken "active" @@ -17,12 +111,13 @@ let cCAMLtoTKindex (* Don't put explicit typing *) = function | `Taglast t -> TkToken (t ^ ".last") | `Window (w : any widget) -> cCAMLtoTKwidget w | `Image s -> TkToken s +;; -let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs) -let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs) -let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs) -let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs) -let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs) +let cCAMLtoTKcanvas_index = (cCAMLtoTKindex : canvas_index -> tkArgs);; +let cCAMLtoTKentry_index = (cCAMLtoTKindex : entry_index -> tkArgs);; +let cCAMLtoTKlistbox_index = (cCAMLtoTKindex : listbox_index -> tkArgs);; +let cCAMLtoTKmenu_index = (cCAMLtoTKindex : menu_index -> tkArgs);; +let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs);; (* Assume returned values are only numerical and l.c *) @@ -35,8 +130,11 @@ let cTKtoCAMLtext_index s = with Not_found -> raise (Invalid_argument ("TKtoCAMLtext_index: " ^ s)) - +;; let cTKtoCAMLlistbox_index s = try `Num (int_of_string s) with _ -> raise (Invalid_argument ("TKtoCAMLlistbox_index: " ^ s)) +;; + +##endif diff --git a/otherlibs/labltk/builtin/builtini_palette.ml b/otherlibs/labltk/builtin/builtini_palette.ml index 10a6e1dc4..b9529c3fa 100644 --- a/otherlibs/labltk/builtin/builtini_palette.ml +++ b/otherlibs/labltk/builtin/builtini_palette.ml @@ -1,5 +1,19 @@ +##ifdef CAMLTK + +let cCAMLtoTKpaletteType = function + GrayShades (foo) -> TkToken (string_of_int foo) + | RGBShades (r,v,b) -> TkToken (string_of_int r^"/"^ + string_of_int v^"/"^ + string_of_int b) +;; + +##else + let cCAMLtoTKpaletteType : paletteType -> tkArgs = function | `Gray (foo) -> TkToken (string_of_int foo) | `Rgb (r,v,b) -> TkToken (string_of_int r ^ "/" ^ string_of_int v ^ "/" ^ string_of_int b) +;; + +##endif diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml index e27d72edb..966c28a32 100644 --- a/otherlibs/labltk/builtin/builtini_text.ml +++ b/otherlibs/labltk/builtin/builtini_text.ml @@ -1,8 +1,40 @@ -let cCAMLtoTKtextMark x = TkToken x -let cTKtoCAMLtextMark x = x +let cCAMLtoTKtextMark x = TkToken x;; +let cTKtoCAMLtextMark x = x;; -let cCAMLtoTKtextTag x = TkToken x -let cTKtoCAMLtextTag x = x +let cCAMLtoTKtextTag x = TkToken x;; +let cTKtoCAMLtextTag x = x;; + +##ifdef CAMLTK + +(* TextModifiers are never returned by Tk *) +let ppTextModifier = function + CharOffset n -> + if n > 0 then "+" ^ (string_of_int n) ^ "chars" + else if n = 0 then "" + else (string_of_int n) ^ "chars" + | LineOffset n -> + if n > 0 then "+" ^ (string_of_int n) ^ "lines" + else if n = 0 then "" + else (string_of_int n) ^ "lines" + | LineStart -> " linestart" + | LineEnd -> " lineend" + | WordStart -> " wordstart" + | WordEnd -> " wordend" +;; + +let ppTextIndex = function + | TextIndexNone -> "" + | TextIndex (base, ml) -> + match cCAMLtoTKindex index_text_table base with + | TkToken ppbase -> List.fold_left (^) ppbase (List.map ppTextModifier ml) + | _ -> assert false +;; + +let cCAMLtoTKtextIndex i = + TkToken (ppTextIndex i) +;; + +##else (* TextModifiers are never returned by Tk *) let cCAMLtoTKtextIndex (i : textIndex) = @@ -27,4 +59,6 @@ let cCAMLtoTKtextIndex (i : textIndex) = | _ -> assert false in TkToken (ppTextIndex i) +;; +##endif diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml index 1ac0dac2b..c153525de 100644 --- a/otherlibs/labltk/builtin/canvas_bind.ml +++ b/otherlibs/labltk/builtin/canvas_bind.ml @@ -1,3 +1,30 @@ +##ifdef CAMLTK + +let bind widget tag eventsequence action = + tkCommand [| + cCAMLtoTKwidget widget_canvas_table widget; + TkToken "bind"; + cCAMLtoTKtagOrId tag; + cCAMLtoTKeventSequence eventsequence; + begin match action with + | BindRemove -> TkToken "" + | BindSet (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + | BindSetBreakable (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ + set BreakBindingsSequence 0") + | BindExtend (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + end + |] +;; + +##else + let bind ~events ?(extend = false) ?(breakable = false) ?(fields = []) ?action widget tag = @@ -20,3 +47,6 @@ let bind ~events TkToken cb end |] +;; + +##endif diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli index b680c5fac..39ce93e7c 100644 --- a/otherlibs/labltk/builtin/canvas_bind.mli +++ b/otherlibs/labltk/builtin/canvas_bind.mli @@ -1,3 +1,10 @@ +##ifdef CAMLTK + +val bind : widget -> tagOrId -> + (modifier list * xEvent) list -> bindAction -> unit + +##else + val bind : events: event list -> ?extend: bool -> @@ -5,3 +12,5 @@ val bind : ?fields: eventField list -> ?action: (eventInfo -> unit) -> canvas widget -> tagOrId -> unit + +##endif diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml index 84e5274bf..260ec78e1 100644 --- a/otherlibs/labltk/builtin/dialog.ml +++ b/otherlibs/labltk/builtin/dialog.ml @@ -1,3 +1,33 @@ +##ifdef CAMLTK + +let create ?name parent title mesg bitmap def buttons = + let w = Widget.new_atom "toplevel" ~parent ?name in + let res = tkEval [|TkToken"tk_dialog"; + cCAMLtoTKwidget widget_any_table w; + TkToken title; + TkToken mesg; + cCAMLtoTKbitmap bitmap; + TkToken (string_of_int def); + TkTokenList (List.map (function x -> TkToken x) buttons)|] + in + int_of_string res +;; + +let create_named parent name title mesg bitmap def buttons = + let w = Widget.new_atom "toplevel" ~parent ~name in + let res = tkEval [|TkToken"tk_dialog"; + cCAMLtoTKwidget widget_any_table w; + TkToken title; + TkToken mesg; + cCAMLtoTKbitmap bitmap; + TkToken (string_of_int def); + TkTokenList (List.map (function x -> TkToken x) buttons)|] + in + int_of_string res +;; + +##else + let create ~parent ~title ~message ~buttons ?name ?(bitmap = `Predefined "") ?(default = -1) () = let w = Widget.new_atom "toplevel" ?name ~parent in @@ -10,3 +40,6 @@ let create ~parent ~title ~message ~buttons ?name TkTokenList (List.map ~f:(fun x -> TkToken x) buttons)|] in int_of_string res +;; + +##endif diff --git a/otherlibs/labltk/builtin/dialog.mli b/otherlibs/labltk/builtin/dialog.mli index d0f6398c3..debb6ce20 100644 --- a/otherlibs/labltk/builtin/dialog.mli +++ b/otherlibs/labltk/builtin/dialog.mli @@ -1,3 +1,17 @@ +##ifdef CAMLTK + +val create : ?name: string -> + widget -> string -> string -> bitmap -> int -> string list -> int + (* [create ~name parent title message bitmap default button_names] + cf. tk_dialog *) + +val create_named : + widget -> string -> string -> string -> bitmap -> int -> string list -> int + (* [create_named parent name title message bitmap default button_names] + cf. tk_dialog *) + +##else + val create : parent: 'a widget -> title: string -> @@ -6,3 +20,5 @@ val create : ?name: string -> ?bitmap: bitmap -> ?default: int -> unit ->int (* [create title message bitmap default button_names parent] cf. tk_dialog *) + +##endif diff --git a/otherlibs/labltk/builtin/image.ml b/otherlibs/labltk/builtin/image.ml new file mode 100644 index 000000000..ac4c7238a --- /dev/null +++ b/otherlibs/labltk/builtin/image.ml @@ -0,0 +1,33 @@ +##ifdef CAMLTK + +let cTKtoCAMLimage s = + let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in + match res with + | "bitmap" -> ImageBitmap (BitmapImage s) + | "photo" -> ImagePhoto (PhotoImage s) + | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) +;; + +let names () = + let res = tkEval [|TkToken "image"; TkToken "names"|] in + let names = splitlist res in + List.map cTKtoCAMLimage names +;; + +##else + +let cTKtoCAMLimage s = + let res = tkEval [|TkToken "image"; TkToken "type"; TkToken s|] in + match res with + | "bitmap" -> `Bitmap s + | "photo" -> `Photo s + | _ -> raise (TkError ("unknown image type \"" ^ res ^ "\"")) +;; + +let names () = + let res = tkEval [|TkToken "image"; TkToken "names"|] in + let names = splitlist res in + List.map cTKtoCAMLimage names +;; + +##endif diff --git a/otherlibs/labltk/builtin/image.mli b/otherlibs/labltk/builtin/image.mli new file mode 100644 index 000000000..a92a9f8c7 --- /dev/null +++ b/otherlibs/labltk/builtin/image.mli @@ -0,0 +1,9 @@ +##ifdef CAMLTK + +val names : unit -> options list + +##else + +val names : unit -> image list + +##endif diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml index ae2614087..8b738d9d3 100644 --- a/otherlibs/labltk/builtin/optionmenu.ml +++ b/otherlibs/labltk/builtin/optionmenu.ml @@ -1,4 +1,39 @@ -open Protocol +##ifdef CAMLTK + +open Protocol;; +(* Implementation of the tk_optionMenu *) + +let create ?name parent variable values = + let w = Widget.new_atom "menubutton" ~parent ?name in + let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in + let res = + tkEval [|TkToken "tk_optionMenu"; + TkToken (Widget.name w); + cCAMLtoTKtextVariable variable; + TkTokenList (List.map (function x -> TkToken x) values)|] in + if res <> Widget.name mw then + raise (TkError "internal error in Optionmenu.create") + else + w,mw +;; + +let create_named parent name variable values = + let w = Widget.new_atom "menubutton" ~parent ~name in + let mw = Widget.new_atom "menu" ~parent:w ~name: "menu" in + let res = + tkEval [|TkToken "tk_optionMenu"; + TkToken (Widget.name w); + cCAMLtoTKtextVariable variable; + TkTokenList (List.map (function x -> TkToken x) values)|] in + if res <> Widget.name mw then + raise (TkError "internal error in Optionmenu.create") + else + w,mw +;; + +##else + +open Protocol;; (* Implementation of the tk_optionMenu *) let create ~parent ~variable ?name values = @@ -6,11 +41,14 @@ let create ~parent ~variable ?name values = let mw = Widget.new_atom "menu" ~parent:w ~name:"menu" in (* assumes .menu naming *) let res = - tkEval [|TkToken "tk_optionMenu"; - TkToken (Widget.name w); - cCAMLtoTKtextVariable variable; - TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in - if res <> Widget.name mw then - raise (TkError "internal error in Optionmenu.create") - else - w, mw + tkEval [|TkToken "tk_optionMenu"; + TkToken (Widget.name w); + cCAMLtoTKtextVariable variable; + TkTokenList (List.map ~f:(fun x -> TkToken x) values)|] in + if res <> Widget.name mw then + raise (TkError "internal error in Optionmenu.create") + else + w, mw +;; + +##endif diff --git a/otherlibs/labltk/builtin/optionmenu.mli b/otherlibs/labltk/builtin/optionmenu.mli index 46a9051f0..0c6b5c9e1 100644 --- a/otherlibs/labltk/builtin/optionmenu.mli +++ b/otherlibs/labltk/builtin/optionmenu.mli @@ -1,7 +1,21 @@ +##ifdef CAMLTK + (* Support for tk_optionMenu *) -val create: parent:'a widget -> variable:textVariable -> - ?name: string -> string list -> menubutton widget * menu widget - (* [create parent var options] creates a multi-option - menubutton and its associated menu. The option is also stored - in the variable. Both widgets (menubutton and menu) are - returned *) +val create: ?name: string -> + widget -> textVariable -> string list -> widget * widget +(** [create ?name parent var options] creates a multi-option menubutton and + its associated menu. The option is also stored in the variable. + Both widgets (menubutton and menu) are returned. *) + +##else + +(* Support for tk_optionMenu *) +val create: + parent:'a widget -> + variable:textVariable -> + ?name: string -> string list -> menubutton widget * menu widget +(** [create ~parent ~var ~name options] creates a multi-option menubutton + and its associated menu. The option is also stored in the variable. + Both widgets (menubutton and menu) are returned *) + +##endif diff --git a/otherlibs/labltk/builtin/rawimg.ml b/otherlibs/labltk/builtin/rawimg.ml new file mode 100644 index 000000000..6bd0ad283 --- /dev/null +++ b/otherlibs/labltk/builtin/rawimg.ml @@ -0,0 +1,142 @@ +external rawget : string -> string + = "camltk_getimgdata" +external rawset : string -> string -> int -> int -> int -> int -> unit + = "camltk_setimgdata_bytecode" (* all int parameters MUST be positive *) + "camltk_setimgdata_native" + +type t = { + pixmap_width : int; + pixmap_height: int; + pixmap_data: string +} + +type pixel = string (* 3 chars *) + +(* pixmap will be an abstract type *) +let width pix = pix.pixmap_width +let height pix = pix.pixmap_height + + +(* note: invalid size would have been caught by String.create, but we put + * it here for documentation purpose *) +let create w h = + if w < 0 || h < 0 then invalid_arg "invalid size" + else { + pixmap_width = w; + pixmap_height = h; + pixmap_data = String.create (w * h * 3); + } + +(* + * operations on pixmaps + *) +let unsafe_copy pix_from pix_to = + String.unsafe_blit pix_from.pixmap_data 0 + pix_to.pixmap_data 0 + (String.length pix_from.pixmap_data) + +(* We check only the length. w,h might be different... *) +let copy pix_from pix_to = + let l = String.length pix_from.pixmap_data in + if l <> String.length pix_to.pixmap_data then + raise (Invalid_argument "copy: incompatible length") + else unsafe_copy pix_from pix_to + + +(* Pixel operations *) +let unsafe_get_pixel pixmap x y = + let pos = (y * pixmap.pixmap_width + x) * 3 in + let r = String.create 3 in + String.unsafe_blit pixmap.pixmap_data pos r 0 3; + r + +let unsafe_set_pixel pixmap x y pixel = + let pos = (y * pixmap.pixmap_width + x) * 3 in + String.unsafe_blit pixel 0 pixmap.pixmap_data pos 3 + +(* To get safe operations, we can either check x,y wrt [0,w[ and [0,h[ + or rely on blit checking. We choose the first for clarity. + *) +let get_pixel pix x y = + if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height + then invalid_arg "invalid pixel" + else unsafe_get_pixel pix x y + +(* same check (pixel being abstract, it must be of good size *) +let set_pixel pix x y pixel = + if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height + then invalid_arg "invalid pixel" + else unsafe_set_pixel pix x y pixel + +(* black as default_color, if at all needed *) +let default_color = "\000\000\000" + +(* Char.chr does range checking *) +let pixel r g b = + let s = String.create 3 in + s.[0] <- Char.chr r; + s.[1] <- Char.chr g; + s.[2] <- Char.chr b; + s + +##ifdef CAMLTK + +(* create pixmap from an existing image *) +let get photo = + match photo with + | PhotoImage s -> { + pixmap_width = CImagephoto.width photo; + pixmap_height = CImagephoto.height photo; + pixmap_data = rawget s; + } + +(* copy a full pixmap into an image *) +let set photo pix = + match photo with + | PhotoImage s -> + rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height + +(* general blit of pixmap into image *) +let blit photo pix x y w h = + if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" + else match photo with + | PhotoImage s -> + rawset s pix.pixmap_data x y w h + +(* get from a file *) +let from_file filename = + let img = CImagephoto.create [File filename] in + let pix = get img in + CImagephoto.delete img; + pix + +##else + +(* create pixmap from an existing image *) +let get photo = + match photo with + | `Photo s -> { + pixmap_width = Imagephoto.width photo; + pixmap_height = Imagephoto.height photo; + pixmap_data = rawget s; + } + +(* copy a full pixmap into an image *) +let set photo pix = + match photo with + | `Photo s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height + +(* general blit of pixmap into image *) +let blit photo pix x y w h = + if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument" + else match photo with + | `Photo s -> rawset s pix.pixmap_data x y w h + +(* get from a file *) +let from_file filename = + let img = Imagephoto.create ~file: filename () in + let pix = get img in + Imagephoto.delete img; + pix + +##endif diff --git a/otherlibs/labltk/builtin/rawimg.mli b/otherlibs/labltk/builtin/rawimg.mli new file mode 100644 index 000000000..1bb120f64 --- /dev/null +++ b/otherlibs/labltk/builtin/rawimg.mli @@ -0,0 +1,44 @@ +(* + * Minimal pixmap support + *) + +type t +type pixel + +val width : t -> int + (* [width pixmap] *) +val height : t -> int + (* [height pixmap] *) + +val create : int -> int -> t + (* [create width height] *) +val get : imagePhoto -> t + (* [get img] *) +val set : imagePhoto -> t -> unit + (* [set img pixmap] *) +val blit : imagePhoto -> t -> int -> int -> int -> int -> unit + (* [blit img pixmap x y w h] (all ints must be non-negative) *) +val from_file : string -> t + (* [from_file filename] *) + +val copy : t -> t -> unit + (* [copy src dst] *) + +(* + * Pixel operations + *) +val get_pixel : t -> int -> int -> pixel + (* [get_pixel pixmap x y] *) +val set_pixel : t -> int -> int -> pixel -> unit + (* [set_pixel pixmap x y pixel] *) +val default_color : pixel + +val pixel : int -> int -> int -> pixel + (* [pixel r g b] (r,g,b must be in [0..255]) *) + +(*-*) +(* unsafe *) +val unsafe_copy : t -> t -> unit +val unsafe_get_pixel : t -> int -> int -> pixel +val unsafe_set_pixel : t -> int -> int -> pixel -> unit +(* /unsafe *) diff --git a/otherlibs/labltk/builtin/report.ml b/otherlibs/labltk/builtin/report.ml index 72a8848c4..852b4c141 100644 --- a/otherlibs/labltk/builtin/report.ml +++ b/otherlibs/labltk/builtin/report.ml @@ -1,12 +1,17 @@ (* Report globals from protocol *) -let openTk = openTk -and closeTk = closeTk -and mainLoop = mainLoop -and register = register +let opentk = Protocol.opentk +let keywords = Protocol.keywords +let opentk_with_args = Protocol.opentk_with_args +let openTk = Protocol.openTk +let openTkClass = Protocol.openTkClass +let openTkDisplayClass = Protocol.openTkDisplayClass +let closeTk = Protocol.closeTk +let mainLoop = Protocol.mainLoop +let register = Protocol.register (* From support *) -let may = may -let maycons = maycons +let may = Support.may +let maycons = Support.maycons (* From widget *) -let coe = coe +let coe = Widget.coe diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml index d46a90f13..946f25424 100644 --- a/otherlibs/labltk/builtin/selection_handle_set.ml +++ b/otherlibs/labltk/builtin/selection_handle_set.ml @@ -1,16 +1,41 @@ +##ifdef CAMLTK + +(* The function *must* use tkreturn *) +let handle_set opts w cmd = + tkCommand [| + TkToken"selection"; + TkToken"handle"; + TkTokenList + (List.map + (function x -> cCAMLtoTKicccm w icccm_selection_handle_table x) + opts); + cCAMLtoTKwidget widget_any_table w; + let id = register_callback w (function args -> + let (a1,args) = int_of_string (List.hd args), List.tl args in + let (a2,args) = int_of_string (List.hd args), List.tl args in + cmd a1 a2) in + TkToken ("camlcb "^id) + |] +;; + +##else + (* The function *must* use tkreturn *) let handle_set ~command = selection_handle_icccm_optionals (fun opts w -> - tkCommand [|TkToken"selection"; - TkToken"handle"; - TkTokenList opts; - cCAMLtoTKwidget w; - let id = register_callback w ~callback: - begin fun args -> - let pos = int_of_string (List.hd args) in - let len = int_of_string (List.nth args 1) in - tkreturn (command ~pos ~len) - end - in TkToken ("camlcb " ^ id) - |]) + tkCommand [| + TkToken"selection"; + TkToken"handle"; + TkTokenList opts; + cCAMLtoTKwidget w; + let id = register_callback w ~callback: + begin fun args -> + let pos = int_of_string (List.hd args) in + let len = int_of_string (List.nth args 1) in + tkreturn (command ~pos ~len) + end + in TkToken ("camlcb " ^ id) + |]) +;; +##endif diff --git a/otherlibs/labltk/builtin/selection_handle_set.mli b/otherlibs/labltk/builtin/selection_handle_set.mli index c053bdc34..66ae6b734 100644 --- a/otherlibs/labltk/builtin/selection_handle_set.mli +++ b/otherlibs/labltk/builtin/selection_handle_set.mli @@ -1,4 +1,13 @@ +##ifdef CAMLTK + +val handle_set : icccm list -> widget -> (int -> int -> unit) -> unit +(** tk invocation: selection handle <icccm list> <widget> <command> *) + +##else + val handle_set : command: (pos:int -> len:int -> string) -> ?format: string -> ?selection:string -> ?typ: string -> 'a widget -> unit -(* tk invocation: selection handle <icccm list> <widget> <command> *) +(** tk invocation: selection handle <icccm list> <widget> <command> *) + +##endif diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml index 8e64177ef..011abef84 100644 --- a/otherlibs/labltk/builtin/selection_own_set.ml +++ b/otherlibs/labltk/builtin/selection_own_set.ml @@ -1,8 +1,29 @@ +##ifdef CAMLTK + +(* builtin to handle callback association to widget *) +let own_set v1 v2 = + tkCommand [| + TkToken"selection"; + TkToken"own"; + TkTokenList + (List.map + (function x -> cCAMLtoTKicccm v2 icccm_selection_ownset_table x) + v1); + cCAMLtoTKwidget widget_any_table v2 + |] +;; + +##else + (* builtin to handle callback association to widget *) let own_set ?command = -selection_ownset_icccm_optionals ?command (fun opts w -> -tkCommand [|TkToken"selection"; - TkToken"own"; - TkTokenList opts; - cCAMLtoTKwidget w|]) + selection_ownset_icccm_optionals ?command (fun opts w -> + tkCommand [| + TkToken"selection"; + TkToken"own"; + TkTokenList opts; + cCAMLtoTKwidget w + |]) +;; +##endif diff --git a/otherlibs/labltk/builtin/selection_own_set.mli b/otherlibs/labltk/builtin/selection_own_set.mli index d05450903..95b3de363 100644 --- a/otherlibs/labltk/builtin/selection_own_set.mli +++ b/otherlibs/labltk/builtin/selection_own_set.mli @@ -1,3 +1,12 @@ +##ifdef CAMLTK + +val own_set : icccm list -> widget -> unit +(** tk invocation: selection own <icccm list> <widget> *) + +##else + val own_set : ?command:(unit->unit) -> ?selection:string -> 'a widget -> unit -(* tk invocation: selection own <icccm list> <widget> *) +(** tk invocation: selection own <icccm list> <widget> *) + +##endif diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml index f9539b22e..e07fbaf20 100644 --- a/otherlibs/labltk/builtin/text_tag_bind.ml +++ b/otherlibs/labltk/builtin/text_tag_bind.ml @@ -1,23 +1,55 @@ +##ifdef CAMLTK + +let tag_bind widget tag eventsequence action = + check_class widget widget_text_table; + tkCommand [| + cCAMLtoTKwidget widget_text_table widget; + TkToken "tag"; + TkToken "bind"; + cCAMLtoTKtextTag tag; + cCAMLtoTKeventSequence eventsequence; + begin match action with + | BindRemove -> TkToken "" + | BindSet (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what)) + | BindSetBreakable (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("camlcb " ^ cbId ^ (writeeventField what) ^ + " ; if { $BreakBindingsSequence == 1 } then { break ;} ; \ + set BreakBindingsSequence 0") + | BindExtend (what, f) -> + let cbId = register_callback widget (wrapeventInfo f what) in + TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) + end + |] +;; + +##else + let tag_bind ~tag ~events ?(extend = false) ?(breakable = false) ?(fields = []) ?action widget = - tkCommand - [| cCAMLtoTKwidget widget; - TkToken "tag"; - TkToken "bind"; - cCAMLtoTKtextTag tag; - cCAMLtoTKeventSequence events; - begin match action with - | None -> TkToken "" - | Some f -> - let cbId = - register_callback widget ~callback: (wrapeventInfo f fields) in - let cb = if extend then "+camlcb " else "camlcb " in - let cb = cb ^ cbId ^ writeeventField fields in - let cb = - if breakable then - cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" - ^ " ; set BreakBindingsSequence 0" - else cb in - TkToken cb - end - |] + tkCommand [| + cCAMLtoTKwidget widget; + TkToken "tag"; + TkToken "bind"; + cCAMLtoTKtextTag tag; + cCAMLtoTKeventSequence events; + begin match action with + | None -> TkToken "" + | Some f -> + let cbId = + register_callback widget ~callback: (wrapeventInfo f fields) in + let cb = if extend then "+camlcb " else "camlcb " in + let cb = cb ^ cbId ^ writeeventField fields in + let cb = + if breakable then + cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" + ^ " ; set BreakBindingsSequence 0" + else cb in + TkToken cb + end + |] +;; + +##endif diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli index 40b969926..1f334a796 100644 --- a/otherlibs/labltk/builtin/text_tag_bind.mli +++ b/otherlibs/labltk/builtin/text_tag_bind.mli @@ -1,4 +1,13 @@ +##ifdef CAMLTK + +val tag_bind: + widget -> textTag -> (modifier list * xEvent) list -> bindAction -> unit + +##else + val tag_bind : tag: string -> events: event list -> ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> ?action: (eventInfo -> unit) -> text widget -> unit + +##endif diff --git a/otherlibs/labltk/builtin/winfo_contained.ml b/otherlibs/labltk/builtin/winfo_contained.ml index 768f1015e..f1fb3735c 100644 --- a/otherlibs/labltk/builtin/winfo_contained.ml +++ b/otherlibs/labltk/builtin/winfo_contained.ml @@ -1,2 +1,13 @@ +##ifdef CAMLTK + +let contained x y w = + w = containing x y +;; + +##else + let contained ~x ~y w = forget_type w = containing ~x ~y () +;; + +##endif diff --git a/otherlibs/labltk/builtin/winfo_contained.mli b/otherlibs/labltk/builtin/winfo_contained.mli index 0baf36ebd..41cc57c0f 100644 --- a/otherlibs/labltk/builtin/winfo_contained.mli +++ b/otherlibs/labltk/builtin/winfo_contained.mli @@ -1,2 +1,11 @@ +##ifdef CAMLTK + +val contained : int -> int -> widget -> bool +(** [contained x y w] returns true if (x,y) is in w *) + +##else + val contained : x:int -> y:int -> 'a widget -> bool -(* [contained x y w] returns true if (x,y) is in w *) +(** [contained x y w] returns true if (x,y) is in w *) + +##endif diff --git a/otherlibs/labltk/camltk/.cvsignore b/otherlibs/labltk/camltk/.cvsignore new file mode 100644 index 000000000..585067641 --- /dev/null +++ b/otherlibs/labltk/camltk/.cvsignore @@ -0,0 +1,3 @@ +*.ml *.mli labltktop labltk +modules +.depend diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile new file mode 100644 index 000000000..6477627ae --- /dev/null +++ b/otherlibs/labltk/camltk/Makefile @@ -0,0 +1,47 @@ +include ../support/Makefile.common + +COMPFLAGS= -I ../support + +TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo + +all: camltkobjs + +opt: camltkobjsx + +include ./modules + +CAMLTKOBJS= $(CWIDGETOBJS) cTk.cmo camltk.cmo +CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) + +camltkobjs: $(CAMLTKOBJS) + +camltkobjsx: $(CAMLTKOBJSX) + +# All .{ml,mli} files are generated in this directory +clean: + rm -f *.cm* *.ml *.mli *.o *.a + $(MAKE) -f Makefile.gen clean + +install: $(CAMLTKOBJS) + if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR) + chmod 644 $(INSTALLDIR)/*.cmi + +installopt: $(CAMLTKOBJSX) + @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(CAMLTKOBJSX) $(INSTALLDIR) + chmod 644 $(INSTALLDIR)/*.cmx + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +include .depend diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen new file mode 100644 index 000000000..990627183 --- /dev/null +++ b/otherlibs/labltk/camltk/Makefile.gen @@ -0,0 +1,43 @@ +include ../support/Makefile.common + +all: cTk.ml camltk.ml .depend + +_tkgen.ml: ../Widgets.src ../compiler/tkcompiler + cd ..; ../../boot/ocamlrun compiler/tkcompiler -camltk -outdir camltk + +cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml + (echo '##define CAMLTK'; \ + echo 'include Camltkwrap'; \ + echo 'open Widget'; \ + echo 'open Protocol'; \ + echo 'open Textvariable'; \ + echo ; \ + cat ../builtin/report.ml; \ + echo ; \ + cat ../builtin/builtin_*.ml; \ + echo ; \ + cat _tkgen.ml; \ + echo ; \ + echo ; \ + echo 'module Tkintf = struct'; \ + cat ../builtin/builtini_*.ml; \ + cat _tkigen.ml; \ + echo 'end (* module Tkintf *)'; \ + echo ; \ + echo ; \ + echo 'open Tkintf' ;\ + echo ; \ + echo ; \ + cat ../builtin/builtinf_*.ml; \ + cat _tkfgen.ml; \ + echo ; \ + ) > _cTk.ml + ../../../boot/ocamlrun ../compiler/pp < _cTk.ml > cTk.ml + rm -f _cTk.ml + $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend + +../compiler/pp: + cd ../compiler; $(MAKE) pp + +clean: + rm -f modules .depend diff --git a/otherlibs/labltk/camltk/Makefile.gen.nt b/otherlibs/labltk/camltk/Makefile.gen.nt new file mode 100644 index 000000000..bee2939db --- /dev/null +++ b/otherlibs/labltk/camltk/Makefile.gen.nt @@ -0,0 +1,43 @@ +!include ..\support\Makefile.common.nt + +all: cTk.ml camltk.ml .depend + +_tkgen.ml: ..\Widgets.src ..\compiler\tkcompiler.exe + cd .. & ..\..\boot\ocamlrun compiler/tkcompiler.exe -camltk -outdir camltk + +# dependencies are broken: wouldn't work with gmake 3.77 + +cTk.ml camltk.ml .depend: _tkgen.ml ..\builtin\report.ml ..\compiler\pp.exe #../builtin/builtin_*.ml + type << > _cTk.ml +##define CAMLTK +include Camltkwrap +open Widget +open Protocol +open Textvariable +<< + type ..\builtin\report.ml >> _cTk.ml + type ..\builtin\builtin_*.ml >> _cTk.ml + type _tkgen.ml >> _cTk.ml + type << >> _cTk.ml + + +module Tkintf = struct +<< + type ..\builtin\builtini_*.ml >> _cTk.ml + type _tkigen.ml >> _cTk.ml + type << >> _cTk.ml +end (* module Tkintf *) + + +open Tkintf + + +<< + type ..\builtin\builtinf_*.ml >> _cTk.ml + type _tkfgen.ml >> _cTk.ml + ..\..\..\boot\ocamlrun ..\compiler\pp.exe < _cTk.ml > cTk.ml + rm -f _cTk.ml + $(CAMLDEP) -I ..\support *.mli *.ml > .depend + +clean: + rm -f modules .depend diff --git a/otherlibs/labltk/camltk/Makefile.nt b/otherlibs/labltk/camltk/Makefile.nt new file mode 100644 index 000000000..66988797c --- /dev/null +++ b/otherlibs/labltk/camltk/Makefile.nt @@ -0,0 +1,43 @@ +!include ..\support\Makefile.common.nt + +COMPFLAGS= -I ../support + +all: camltkobjs + +opt: camltkobjsx + +# All .{ml,mli} files are generated in this directory +clean : + rm -f *.cm* *.ml *.mli *.a *.obj + $(MAKE) -f Makefile.gen.nt clean + +!include .\modules + +CAMLTKOBJS = $(WIDGETOBJS) cTk.cmo camltk.cmo +CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) + +camltkobjs: $(CAMLTKOBJS) + +camltkobjsx: $(CAMLTKOBJSX) + +install: $(CAMLTKOBJS) + @if not exist $(INSTALLDIR) mkdir $(INSTALLDIR) + cp *.cmi [a-z]*.mli $(INSTALLDIR) + +installopt: $(CAMLTKOBJSX) + @if not exist $(INSTALLDIR) mkdir $(INSTALLDIR) + cp $(CAMLTKOBJSX) $(INSTALLDIR) + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +!include .depend diff --git a/otherlibs/labltk/compiler/.cvsignore b/otherlibs/labltk/compiler/.cvsignore index 178a0fab7..060114e62 100644 --- a/otherlibs/labltk/compiler/.cvsignore +++ b/otherlibs/labltk/compiler/.cvsignore @@ -3,3 +3,9 @@ parser.output parser.ml parser.mli tkcompiler +pp +copyright.ml +pplex.ml +ppyac.ml +ppyac.output +ppyac.mli diff --git a/otherlibs/labltk/compiler/.depend b/otherlibs/labltk/compiler/.depend index 01a938ff5..d33149e8c 100644 --- a/otherlibs/labltk/compiler/.depend +++ b/otherlibs/labltk/compiler/.depend @@ -1,15 +1,27 @@ -compile.cmo: tables.cmo -compile.cmx: tables.cmx -intf.cmo: compile.cmo tables.cmo -intf.cmx: compile.cmx tables.cmx +pplex.cmi: ppyac.cmi +ppyac.cmi: code.cmi +compile.cmo: code.cmi flags.cmo ppexec.cmo ppparse.cmo tables.cmo +compile.cmx: code.cmi flags.cmx ppexec.cmx ppparse.cmx tables.cmx +intf.cmo: code.cmi compile.cmo flags.cmo ppexec.cmo ppparse.cmo tables.cmo +intf.cmx: code.cmi compile.cmx flags.cmx ppexec.cmx ppparse.cmx tables.cmx lexer.cmo: parser.cmi lexer.cmx: parser.cmx -maincompile.cmo: compile.cmo intf.cmo lexer.cmo parser.cmi printer.cmo \ - tables.cmo tsort.cmo -maincompile.cmx: compile.cmx intf.cmx lexer.cmx parser.cmx printer.cmx \ - tables.cmx tsort.cmx -parser.cmo: tables.cmo parser.cmi -parser.cmx: tables.cmx parser.cmi +maincompile.cmo: code.cmi compile.cmo flags.cmo intf.cmo lexer.cmo parser.cmi \ + ppexec.cmo ppparse.cmo printer.cmo tables.cmo tsort.cmo +maincompile.cmx: code.cmi compile.cmx flags.cmx intf.cmx lexer.cmx parser.cmx \ + ppexec.cmx ppparse.cmx printer.cmx tables.cmx tsort.cmx +parser.cmo: flags.cmo tables.cmo parser.cmi +parser.cmx: flags.cmx tables.cmx parser.cmi +pp.cmo: ppexec.cmo ppparse.cmo +pp.cmx: ppexec.cmx ppparse.cmx +ppexec.cmo: code.cmi +ppexec.cmx: code.cmi +pplex.cmo: ppyac.cmi pplex.cmi +pplex.cmx: ppyac.cmx pplex.cmi +ppparse.cmo: pplex.cmi ppyac.cmi +ppparse.cmx: pplex.cmx ppyac.cmx +ppyac.cmo: code.cmi ppyac.cmi +ppyac.cmx: code.cmi ppyac.cmi printer.cmo: tables.cmo printer.cmx: tables.cmx tables.cmo: tsort.cmo diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile index 302ad2588..a2b845331 100644 --- a/otherlibs/labltk/compiler/Makefile +++ b/otherlibs/labltk/compiler/Makefile @@ -1,36 +1,63 @@ include ../support/Makefile.common -OBJS= ../support/support.cmo tsort.cmo tables.cmo printer.cmo lexer.cmo \ +OBJS= ../support/support.cmo flags.cmo copyright.cmo \ + tsort.cmo tables.cmo printer.cmo lexer.cmo \ + pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ parser.cmo compile.cmo intf.cmo maincompile.cmo -tkcompiler : $(OBJS) - $(LABLC) $(LINKFLAGS) -o tkcompiler $(OBJS) +PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo + +all: tkcompiler$(EXE) pp$(EXE) + +tkcompiler$(EXE) : $(OBJS) + $(CAMLC) -g $(LINKFLAGS) -o tkcompiler$(EXE) $(OBJS) + +pp$(EXE): $(PPOBJS) + $(CAMLC) -g $(LINKFLAGS) -o pp$(EXE) $(PPOBJS) lexer.ml: lexer.mll - $(LABLLEX) lexer.mll + $(CAMLLEX) lexer.mll parser.ml parser.mli: parser.mly - $(LABLYACC) -v parser.mly + $(CAMLYACC) -v parser.mly + +pplex.ml: pplex.mll + $(CAMLLEX) pplex.mll + +pplex.mli: ppyac.cmi + +ppyac.ml ppyac.mli: ppyac.mly + $(CAMLYACC) -v ppyac.mly + +copyright.ml: copyright + (echo "let copyright=\"\\"; \ + cat copyright; \ + echo "\""; \ + echo "let write ~w = w copyright;;") > copyright.ml clean : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler parser.output + rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml + rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output + rm -f tkcompiler$(EXE) pp$(EXE) parser.output scratch : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler + rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler$(EXE) + rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp$(EXE) install: - cp tkcompiler $(LABLTKDIR) + cp tkcompiler$(EXE) $(INSTALLDIR) + cp pp$(EXE) $(INSTALLDIR) .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .mlp .mli.cmi: - $(LABLCOMP) $(COMPFLAGS) -I ../support $< + $(CAMLCOMP) -g $(COMPFLAGS) -I ../support $< .ml.cmo: - $(LABLCOMP) $(COMPFLAGS) -I ../support $< + $(CAMLCOMP) -g $(COMPFLAGS) -I ../support $< -depend: parser.ml parser.mli lexer.ml - $(LABLDEP) *.mli *.ml > .depend +depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli + $(CAMLDEP) *.mli *.ml > .depend include .depend diff --git a/otherlibs/labltk/compiler/Makefile.nt b/otherlibs/labltk/compiler/Makefile.nt index d211c548a..4a18e8ee5 100644 --- a/otherlibs/labltk/compiler/Makefile.nt +++ b/otherlibs/labltk/compiler/Makefile.nt @@ -1,36 +1,68 @@ !include ..\support\Makefile.common.nt -OBJS= ../support/support.cmo tsort.cmo tables.cmo lexer.cmo parser.cmo \ - compile.cmo intf.cmo printer.cmo maincompile.cmo +OBJS= ../support/support.cmo flags.cmo copyright.cmo \ + tsort.cmo tables.cmo printer.cmo lexer.cmo \ + pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ + parser.cmo compile.cmo intf.cmo maincompile.cmo -tkcompiler : $(OBJS) - $(LABLC) $(LINKFLAGS) -o tkcompiler $(OBJS) +PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo + +all: tkcompiler.exe pp.exe + +tkcompiler.exe : $(OBJS) + $(CAMLC) $(LINKFLAGS) -o tkcompiler.exe $(OBJS) + +pp.exe : $(PPOBJS) + $(CAMLC) $(LINKFLAGS) -o pp.exe $(PPOBJS) lexer.ml: lexer.mll - $(LABLLEX) lexer.mll + $(CAMLLEX) lexer.mll parser.ml parser.mli: parser.mly - $(LABLYACC) -v parser.mly + $(CAMLYACC) -v parser.mly + +pplex.ml: pplex.mll + $(CAMLLEX) pplex.mll + +pplex.mli: ppyac.cmi + +ppyac.ml ppyac.mli: ppyac.mly + $(CAMLYACC) -v ppyac.mly + +copyright.ml: copyright + type << > copyright.ml +let copyright=" +<< + type copyright >> copyright.ml + type << >> copyright.ml +" + +let write ~w = w copyright;; +<< clean : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler parser.output + rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml + rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output + rm -f tkcompiler.exe pp.exe parser.output scratch : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler + rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler.exe + rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp.exe install: - cp tkcompiler $(LABLTKDIR) + cp tkcompiler.exe $(INSTALLDIR) + cp pp.exe $(INSTALLDIR) .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .mlp .mli.cmi: - $(LABLCOMP) $(COMPFLAGS) -I ../support $< + $(CAMLCOMP) $(COMPFLAGS) -I ../support $< .ml.cmo: - $(LABLCOMP) $(COMPFLAGS) -I ../support $< + $(CAMLCOMP) $(COMPFLAGS) -I ../support $< -depend: parser.ml parser.mli lexer.ml - $(LABLDEP) *.mli *.ml > .depend +depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli + $(CAMLDEP) *.mli *.ml > .depend !include .depend diff --git a/otherlibs/labltk/compiler/code.mli b/otherlibs/labltk/compiler/code.mli new file mode 100644 index 000000000..6f3e29213 --- /dev/null +++ b/otherlibs/labltk/compiler/code.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +type code = + | Line of string + | Ifdef of bool * string * code list * code list option + | Define of string + | Undef of string +;; diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml index 1b496ec92..78adbcee6 100644 --- a/otherlibs/labltk/compiler/compile.ml +++ b/otherlibs/labltk/compiler/compile.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -27,14 +27,30 @@ let labeloff ~at l = match l with "", t -> t | l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at)) -let labelstring l = +let labltk_labelstring l = if l = "" then l else if l.[0] = '?' then l ^ ":" else "~" ^ l ^ ":" -let typelabel l = +let camltk_labelstring l = + if l = "" then l else + if l.[0] = '?' then l ^ ":" else "" + +let labelstring l = + if !Flags.camltk then camltk_labelstring l + else labltk_labelstring l + +let labltk_typelabel l = if l = "" then l else l ^ ":" +let camltk_typelabel l = + if l = "" then l + else if l.[0] = '?' then l ^ ":" else "" + +let typelabel l = + if !Flags.camltk then camltk_typelabel l + else labltk_typelabel l + let forbidden = [ "class"; "type"; "in"; "from"; "to" ] let nicknames = [ "class", "clas"; @@ -70,8 +86,8 @@ let rec types_of_template = function | TypeArg (l, t) -> [l, t] | ListArg l -> List.flatten (List.map ~f:types_of_template l) | OptionalArgs (l, tl, _) -> - begin - match List.flatten (List.map ~f:types_of_template tl) with + begin + match List.flatten (List.map ~f:types_of_template tl) with ["", t] -> ["?" ^ l, t] | [_, _] -> raise (Failure "0 label required") | _ -> raise (Failure "0 or more than 1 args in for optionals") @@ -92,74 +108,81 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = | String -> "string" (* new *) | List (Subtype (sup, sub)) -> - if return then - sub ^ "_" ^ sup ^ " list" - else - begin - try - let typdef = Hashtbl.find types_table sup in - let fcl = List.assoc sub typdef.subtypes in - let tklabels = List.map ~f:gettklabel fcl in - let l = List.map fcl ~f: - begin fun fc -> - "?" ^ begin let p = gettklabel fc in - if count ~item:p tklabels > 1 then small fc.var_name else p - end - ^ ":" ^ - let l = types_of_template fc.template in - match l with - [] -> "unit" - | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype") - | l -> - "(" ^ String.concat ~sep:"*" - (List.map l - ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype"))) - ^ ")" - end in - String.concat ~sep:" ->\n" l - with - Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1) - end + if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list" + else begin + if return then + sub ^ "_" ^ sup ^ " list" + else begin + try + let typdef = Hashtbl.find types_table sup in + let fcl = List.assoc sub typdef.subtypes in + let tklabels = List.map ~f:gettklabel fcl in + let l = List.map fcl ~f: + begin fun fc -> + "?" ^ begin let p = gettklabel fc in + if count ~item:p tklabels > 1 then small fc.var_name else p + end + ^ ":" ^ + let l = types_of_template fc.template in + match l with + [] -> "unit" + | [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype") + | l -> + "(" ^ String.concat ~sep:"*" + (List.map l + ~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype"))) + ^ ")" + end in + String.concat ~sep:" ->\n" l + with + Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1) + end + end | List ty -> (ppMLtype ty) ^ " list" | Product tyl -> "(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")" | Record tyl -> String.concat ~sep:" * " (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t)) - | Subtype ("widget", sub) -> sub ^ " widget" + | Subtype ("widget", sub) -> + if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget" | UserDefined "widget" -> - if any then "any widget" else - let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) - in - incr counter; - "'" ^ c ^ " widget" + if !Flags.camltk then "widget" + else begin + if any then "any widget" else + let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in + incr counter; + "'" ^ c ^ " widget" + end | UserDefined s -> - (* a bit dirty hack for ImageBitmap and ImagePhoto *) - begin - try - let typdef = Hashtbl.find types_table s in - if typdef.variant then - if return then try - "[>" ^ - String.concat ~sep:"|" - (List.map typdef.constructors ~f: - begin - fun c -> - "`" ^ c.var_name ^ - (match types_of_template c.template with - [] -> "" - | l -> " of " ^ ppMLtype (Product (List.map l - ~f:(labeloff ~at:"ppMLtype UserDefined")))) - end) ^ "]" - with - Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s - else if not def && List.length typdef.constructors > 1 then - "[< " ^ s ^ "]" + if !Flags.camltk then s + else begin + (* a bit dirty hack for ImageBitmap and ImagePhoto *) + try + let typdef = Hashtbl.find types_table s in + if typdef.variant then + if return then try + "[>" ^ + String.concat ~sep:"|" + (List.map typdef.constructors ~f: + begin + fun c -> + "`" ^ c.var_name ^ + (match types_of_template c.template with + [] -> "" + | l -> " of " ^ ppMLtype (Product (List.map l + ~f:(labeloff ~at:"ppMLtype UserDefined")))) + end) ^ "]" + with + Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s + else if not def && List.length typdef.constructors > 1 then + "[< " ^ s ^ "]" + else s else s - else s - with Not_found -> s - end - | Subtype (s, s') -> s' ^ "_" ^ s + with Not_found -> s + end + | Subtype (s, s') -> + if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s | Function (Product tyl) -> raise (Failure "Function (Product tyl) ? ppMLtype") | Function (Record tyl) -> @@ -168,7 +191,9 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) = ^ " -> unit)" | Function ty -> "(" ^ (ppMLtype ty) ^ " -> unit)" - | As (_, s) -> s + | As (t, s) -> + if !Flags.camltk then ppMLtype t + else s in ppMLtype @@ -207,7 +232,7 @@ let write_constructors ~w = function write_constructor ~w x; List.iter l ~f: begin fun x -> - w "\n | "; + w "\n | "; write_constructor ~w x end @@ -229,12 +254,12 @@ let write_variants ~w = function | l -> List.iter l ~f: begin fun x -> - w "\n | "; + w "\n | "; write_variant ~w x end (* Definition of a type *) -let write_type ~intf:w ~impl:w' name ~def:typdef = +let labltk_write_type ~intf:w ~impl:w' name ~def:typdef = (* Only needed if no subtypes, otherwise use optionals *) if typdef.subtypes = [] then begin w "(* Variant type *)\n"; @@ -243,6 +268,54 @@ let write_type ~intf:w ~impl:w' name ~def:typdef = w "\n]\n\n" end +(* CamlTk: List of constructors, for runtime subtyping *) +let write_constructor_set ~w ~sep = function + | [] -> fatal_error "empty type" + | x::l -> + w ("C" ^ x.ml_name); + List.iter l ~f: (function x -> + w sep; + w ("C" ^ x.ml_name)) + +(* CamlTk: Definition of a type *) +let camltk_write_type ~intf:w ~impl:w' name ~def:typdef = + (* Put markers for extraction *) + w "(* type *)\n"; + w ("type " ^ name ^ " =\n"); + w " | "; + write_constructors ~w (sort_components typdef.constructors); + w "\n\n"; + (* Dynamic Subtyping *) + if typdef.subtypes <> [] then begin + (* The set of its constructors *) + if name = "options" then begin + w "(* type *)\n"; + w ("type "^name^"_constrs =\n\t") + end else begin + (* added some prefix to avoid being picked up in documentation *) + w ("(* no doc *) type "^name^"_constrs =\n") + end; + w " | "; + write_constructor_set ~w:w ~sep: "\n | " + (sort_components typdef.constructors); + w "\n\n"; + (* The set of all constructors *) + w' ("let "^name^"_any_table = ["); + write_constructor_set ~w:w' ~sep:"; " + (sort_components typdef.constructors); + w' ("]\n\n"); + (* The subset of constructors for each subtype *) + List.iter ~f:(function (s,l) -> + w' ("let "^name^"_"^s^"_table = ["); + write_constructor_set ~w:w' ~sep:"; " (sort_components l); + w' ("]\n\n")) + typdef.subtypes + end + +let write_type ~intf:w ~impl:w' name ~def:typdef = + (if !Flags.camltk then camltk_write_type else labltk_write_type) + ~intf:w ~impl:w' name ~def:typdef + (************************************************************) (* Converters *) (************************************************************) @@ -257,10 +330,14 @@ let rec converterTKtoCAML ~arg = function | Char -> "String.get " ^ arg ^ " 0" | String -> arg | UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg - | Subtype ("widget", s') -> + | Subtype ("widget", s') when not !Flags.camltk -> String.concat ~sep:" " ["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"] - | Subtype (s, s') -> "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg + | Subtype (s, s') -> + if !Flags.camltk then + "cTKtoCAML" ^ s ^ " " ^ arg + else + "cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg | List ty -> begin match type_parser_arity ty with OneToken -> @@ -322,7 +399,9 @@ let rec wrapper_code ~name ty = end in String.concat ~sep:"" readarg ^ name ^ " " ^ String.concat ~sep:" " - (List.map2 ~f:(fun v (l, _) -> labelstring l ^ v) vnames tyl) + (List.map2 ~f:(fun v (l, _) -> + if !Flags.camltk then v + else labelstring l ^ v) vnames tyl) (* all other types are read in one operation *) | List ty -> @@ -364,16 +443,17 @@ let can_generate_parser constructors = let pp = {zeroary = []; intpar = []; stringpar = []} in if List.for_all constructors ~f: begin fun c -> + let vname = if !Flags.camltk then c.ml_name else c.var_name in match c.template with ListArg [StringArg s] -> - pp.zeroary <- (s, "`" ^ c.var_name) :: + pp.zeroary <- (s, vname) :: pp.zeroary; true | ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] -> if pp.intpar <> [] then false - else (pp.intpar <- ["`" ^ c.var_name]; true) + else (pp.intpar <- [vname]; true) | ListArg [TypeArg(_, String)] -> if pp.stringpar <> [] then false - else (pp.stringpar <- ["`" ^ c.var_name]; true) + else (pp.stringpar <- [vname]; true) | _ -> false end then ParserPieces pp @@ -382,7 +462,46 @@ let can_generate_parser constructors = (* We can generate parsers only for simple types *) (* we should avoid multiple walks *) -let write_TKtoCAML ~w name ~def:typdef = +let labltk_write_TKtoCAML ~w name ~def:typdef = + if typdef.parser_arity = MultipleToken then + prerr_string ("You must write cTKtoCAML" ^ name ^ + " : string list ->" ^ name ^ " * string list\n") + else + let write ~consts ~name = + match can_generate_parser consts with + NoParser -> + prerr_string + ("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n") + | ParserPieces pp -> + w ("let cTKtoCAML" ^ name ^ " n =\n"); + (* First check integer *) + if pp.intpar <> [] then + begin + w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n"); + w (" with _ ->\n") + end; + w (" match n with\n"); + List.iter pp.zeroary ~f: + begin fun (tk, ml) -> + w " | \""; w tk; w "\" -> `"; w ml; w "\n" + end; + let final = if pp.stringpar <> [] then + "n -> `" ^ List.hd pp.stringpar ^ " n" + else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML" + ^ name ^ ": \" ^ s))" + in + w " | "; + w final; + w "\n\n" + in + begin + write ~name ~consts:typdef.constructors; + List.iter typdef.subtypes ~f: begin + fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts + end + end + +let camltk_write_TKtoCAML ~w name ~def:typdef = if typdef.parser_arity = MultipleToken then prerr_string ("You must write cTKtoCAML" ^ name ^ " : string list ->" ^ name ^ " * string list\n") @@ -421,6 +540,10 @@ let write_TKtoCAML ~w name ~def:typdef = end end +let write_TKtoCAML ~w name ~def:typdef = + (if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML) + ~w name ~def: typdef + (******************************) (* Converters *) (******************************) @@ -439,19 +562,43 @@ let rec converterCAMLtoTK ~context_widget argname ty = let name = "cCAMLtoTK" ^ s ^ " " in let args = argname in let args = + if !Flags.camltk then begin + if is_subtyped s then (* unconstraint subtype *) + s ^ "_any_table " ^ args + else args + end else args + in + let args = if requires_widget_context s then context_widget ^ " " ^ args else args in name ^ args | Subtype ("widget", s') -> - let name = "cCAMLtoTKwidget" in - let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in - name ^ args + if !Flags.camltk then + let name = "cCAMLtoTKwidget " in + let args = "widget_"^s'^"_table "^argname in + let args = + if requires_widget_context "widget" then + context_widget^" "^args + else args in + name^args + else begin + let name = "cCAMLtoTKwidget " in + let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in + name ^ args + end | Subtype (s, s') -> - let name = "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " in + let name = + if !Flags.camltk then "cCAMLtoTK" ^ s ^ " " + else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " " + in let args = - if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])" - else argname + if !Flags.camltk then begin + s^"_"^s'^"_table "^argname + end else begin + if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])" + else argname + end in let args = if requires_widget_context s then context_widget ^ " " ^ args @@ -499,15 +646,22 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template = let newvar = ref newvar1 in let rec coderec = function StringArg s -> "TkToken \"" ^ s ^ "\"" - | TypeArg (_, List (Subtype (sup, sub) as ty)) -> - let typdef = Hashtbl.find types_table sup in - let classdef = List.assoc sub typdef.subtypes in - let lbl = gettklabel (List.hd classdef) in - catch_opts := (sub ^ "_" ^ sup, lbl); - newvar := newvar2; - "TkTokenList opts" + | TypeArg (_, List (Subtype (sup, sub) as ty)) when not !Flags.camltk -> + begin try + let typdef = Hashtbl.find types_table sup in + let classdef = List.assoc sub typdef.subtypes in + let lbl = gettklabel (List.hd classdef) in + catch_opts := (sub ^ "_" ^ sup, lbl); + newvar := newvar2; + "TkTokenList opts" + with Not_found -> + raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub)); + end | TypeArg (l, List ty) -> - "TkTokenList (List.map ~f:(function x -> " + (if !Flags.camltk then + "TkTokenList (List.map (function x -> " + else + "TkTokenList (List.map ~f:(function x -> ") ^ converterCAMLtoTK ~context_widget "x" ty ^ ") " ^ !newvar l ^ ")" | TypeArg (l, Function tyarg) -> @@ -549,7 +703,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template = *) (* For each case of a concrete type *) -let write_clause ~w ~context_widget comp = +let labltk_write_clause ~w ~context_widget comp = let warrow () = w " -> " in w "`"; w comp.var_name; @@ -570,9 +724,39 @@ let write_clause ~w ~context_widget comp = end; w code +let camltk_write_clause ~w ~context_widget ~subtype comp = + let warrow () = + w " -> "; + if subtype then + w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ") + in + + w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *) + + let code, variables, variables2, (co, _) = + code_of_template ~context_widget comp.template in + + (* no subtype I think ... *) + if co <> "" then raise (Failure "write_clause subtype ?"); + begin match variables with + | [] -> warrow() + | [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow() + | l -> + w " ( "; + w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l)); + w ")"; + warrow() + end; + w code + +let write_clause ~w ~context_widget ~subtype comp = + if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp + else labltk_write_clause ~w ~context_widget comp + (* The full converter *) let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = let write_one name constrs = + let subtype = typdef.subtypes <> [] in w ("let cCAMLtoTK" ^ name); let context_widget = if typdef.requires_widget_context then begin @@ -580,6 +764,7 @@ let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = end else "dummy" in + if !Flags.camltk && subtype then w " table"; if st then begin w " : "; if typdef.variant then w ("[< " ^ name ^ "]") else w name; @@ -587,32 +772,38 @@ let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name = end; w (" = function"); List.iter constrs - ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget c); + ~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c); w "\n\n\n" in - (* Only needed if no subtypes, otherwise use optionals *) let constrs = typdef.constructors in - if typdef.subtypes == [] then - write_one name constrs - else - List.iter constrs ~f: - begin fun fc -> - let code, vars, _, (co, _) = - code_of_template ~context_widget:"dummy" fc.template in - if co <> "" then fatal_error "optionals in optionals"; - let vars = List.map ~f:snd vars in - w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name); - w " ("; w (String.concat ~sep:", " vars); w ") =\n "; - w code; w "\n\n" - end + if !Flags.camltk then write_one name constrs + else begin + (* Only needed if no subtypes, otherwise use optionals *) + if typdef.subtypes == [] then + write_one name constrs + else + List.iter constrs ~f: + begin fun fc -> + let code, vars, _, (co, _) = + code_of_template ~context_widget:"dummy" fc.template in + if co <> "" then fatal_error "optionals in optionals"; + let vars = List.map ~f:snd vars in + w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name); + w " ("; w (String.concat ~sep:", " vars); w ") =\n "; + w code; w "\n\n" + end + end (* Tcl does not really return "lists". It returns sp separated tokens *) let rec write_result_parsing ~w = function List String -> w "(splitlist res)" | List ty -> - w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) + if !Flags.camltk then + w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) + else + w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty) | Product tyl -> raise (Failure "Product -> record was done. ???") | Record tyl -> (* of course all the labels are "" *) let rnames = varnames ~prefix:"r" (List.length tyl) in @@ -641,7 +832,7 @@ let rec write_result_parsing ~w = function OneToken -> w (converterTKtoCAML ~arg:"res" ty) | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty) -let write_function ~w def = +let labltk_write_function ~w def = w ("let " ^ def.ml_name); (* a bit approximative *) let context_widget = match def.template with @@ -690,8 +881,86 @@ let write_function ~w def = if co <> "" then w ")"; w "\n\n" -let write_create ~w clas = - (w "let create ?name =\n" : unit); +let camltk_write_function ~w def = + w ("let " ^ def.ml_name); + (* a bit approximative *) + let context_widget = match def.template with + ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" + | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" + | _ -> "dummy" in + + let code, variables, variables2, (co, lbl) = + code_of_template ~func:true ~context_widget def.template in + (* Arguments *) + let uv, ov = + let rec replace_args ~u ~o = function + [] -> u, o + | ("", x) :: ls -> + replace_args ~u:(x :: u) ~o ls + | (p, _ as x) :: ls when p.[0] = '?' -> + replace_args ~u ~o:(x :: o) ls + | (_,x) :: ls -> + replace_args ~u:(x::u) ~o ls + in + replace_args ~u:[] ~o:[] (List.rev (variables @ variables2)) + in + let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in + if not has_opts then List.iter uv ~f:(fun x -> w " "; w x); + List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v); + begin + if uv = [] then w " ()" else + if has_opts then List.iter uv ~f:(fun x -> w " "; w x); + w " =\n" + end; + begin match def.result with + | Unit | As (Unit, _) -> w "tkCommand "; w code + | ty -> + w "let res = tkEval "; w code ; w " in \n"; + write_result_parsing ~w ty + end; + w "\n\n" + +(* + w ("let " ^ def.ml_name); + (* a bit approximative *) + let context_widget = match def.template with + ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1" + | ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1" + | _ -> "dummy" in + + let code, variables, variables2, (co, lbl) = + code_of_template ~func:true ~context_widget def.template in + let variables = variables @ variables2 in + (* Arguments *) + begin match variables with + [] -> w " () =\n" + | l -> + let has_normal_argument = ref false in + List.iter (fun (l,x) -> + w " "; + if l <> "" then + if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true + else has_normal_argument := true; + w x) l; + if not !has_normal_argument then w " ()"; + w " =\n" + end; + begin match def.result with + | Unit | As (Unit, _) -> w "tkCommand "; w code + | ty -> + w "let res = tkEval "; w code ; w " in \n"; + write_result_parsing ~w ty + end; + w "\n\n" +*) + +let write_function ~w def = + if !Flags.camltk then camltk_write_function ~w def + else labltk_write_function ~w def +;; + +let labltk_write_create ~w clas = + w ("let create ?name =\n"); w (" " ^ clas ^ "_options_optionals (fun opts parent ->\n"); w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); w " tkCommand [|"; @@ -700,6 +969,28 @@ let write_create ~w clas = w (" TkTokenList opts |];\n"); w (" w)\n\n\n") +let camltk_write_create ~w clas = + w ("let create ?name parent options =\n"); + w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n"); + w " tkCommand [|"; + w ("TkToken \"" ^ clas ^ "\";\n"); + w (" TkToken (Widget.name w);\n"); + w (" TkTokenList (List.map (function x -> "^ + converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); + w (" |];\n"); + w (" w\n\n") + +let camltk_write_named_create ~w clas = + w ("let create_named parent name options =\n"); + w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n"); + w " tkCommand [|"; + w ("TkToken \"" ^ clas ^ "\";\n"); + w (" TkToken (Widget.name w);\n"); + w (" TkTokenList (List.map (function x -> "^ + converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n"); + w (" |];\n"); + w (" w\n\n") + (* Search Path. *) let search_path = ref ["."] @@ -724,19 +1015,21 @@ let write_external ~w def = begin try let realname = find_in_path !search_path (fname ^ ".ml") in let ic = open_in_bin realname in - begin try - while true do - w (input_line ic); - w "\n" - done - with - | End_of_file -> close_in ic - end + try + let code_list = Ppparse.parse_channel ic in + close_in ic; + List.iter (Ppexec.exec (fun _ -> ()) w) + (if !Flags.camltk then + Code.Define "CAMLTK" :: code_list else code_list ); + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with | Not_found -> raise (Compiler_Error ("can't find external file: " ^ fname)) end -| _ -> raise (Compiler_Error "invalid external definition") + | _ -> raise (Compiler_Error "invalid external definition") let write_catch_optionals ~w clas ~def:typdef = if typdef.subtypes = [] then () else diff --git a/otherlibs/labltk/compiler/copyright b/otherlibs/labltk/compiler/copyright new file mode 100644 index 000000000..23dff46dc --- /dev/null +++ b/otherlibs/labltk/compiler/copyright @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) diff --git a/otherlibs/labltk/compiler/flags.ml b/otherlibs/labltk/compiler/flags.ml new file mode 100644 index 000000000..009d5e725 --- /dev/null +++ b/otherlibs/labltk/compiler/flags.ml @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +let camltk = ref false;; diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml index 9e262ede6..e155ec5ee 100644 --- a/otherlibs/labltk/compiler/intf.ml +++ b/otherlibs/labltk/compiler/intf.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -23,7 +23,7 @@ open StdLabels open Tables open Compile -let write_create_p ~w wname = +let labltk_write_create_p ~w wname = w "val create :\n ?name:string ->\n"; begin try @@ -50,13 +50,27 @@ let write_create_p ~w wname = with Not_found -> fatal_error "in write_create_p" end; w (" ->\n 'a widget -> " ^ wname ^ " widget\n"); - w " (* [create p options ?name] creates a new widget with\n"; - w " parent p and new patch component name.\n"; - w " Options are restricted to the widget class subset,\n"; - w " and checked dynamically. *)\n" + w "(** [create ?name parent options...] creates a new widget with\n"; + w " parent [parent] and new patch component [name], if specified. *)\n\n" +;; + +let camltk_write_create_p ~w wname = + w "val create : ?name: string -> widget -> options list -> widget \n"; + w "(** [create ?name parent options] creates a new widget with\n"; + w " parent [parent] and new patch component [name] if specified.\n"; + w " Options are restricted to the widget class subset, and checked\n"; + w " dynamically. *)\n\n" +;; + +let camltk_write_named_create_p ~w wname = + w "val create_named : widget -> string -> options list -> widget \n"; + w "(** [create_named parent name options] creates a new widget with\n"; + w " parent [parent] and new patch component [name].\n"; + w " This function is now obsolete and unified with [create]. *)\n\n"; +;; (* Unsafe: write special comment *) -let write_function_type ~w def = +let labltk_write_function_type ~w def = if not def.safe then w "(* unsafe *)\n"; w "val "; w def.ml_name; w " : "; let us, ls, os = @@ -87,8 +101,69 @@ let write_function_type ~w def = w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) w " \n"; (* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) - if def.safe then w "\n\n" - else w "\n(* /unsafe *)\n\n" + if def.safe then w "\n" + else w "\n(* /unsafe *)\n" + +let camltk_write_function_type ~w def = + if not def.safe then w "(* unsafe *)\n"; + w "val "; w def.ml_name; w " : "; + let us, os = + let tys = types_of_template def.template in + let rec replace_args ~u ~o = function + [] -> u, o + | ("", _ as x)::ls -> + replace_args ~u:(x::u) ~o ls + | (p, _ as x)::ls when p.[0] = '?' -> + replace_args ~u ~o:(x::o) ls + | x::ls -> + replace_args ~u:(x::u) ~o ls + in + replace_args ~u:[] ~o:[] (List.rev tys) + in + let counter = ref 0 in + let params = + if os = [] then us else os @ us in + List.iter params ~f: + begin fun (l, t) -> + if l <> "" then if l.[0] = '?' then w (l ^ ":"); + w (ppMLtype t ~counter); + w " -> " + end; + if us = [] then w "unit -> "; + w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) + w " \n"; +(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *) + if def.safe then w "\n" + else w "\n(* /unsafe *)\n" + +(* + if not def.safe then w "(* unsafe *)\n"; + w "val "; w def.ml_name; w " : "; + let tys = types_of_template def.template in + let counter = ref 0 in + let have_normal_arg = ref false in + List.iter tys ~f: + begin fun (l, t) -> + if l <> "" then + if l.[0] = '?' then w (l^":") + else begin + have_normal_arg := true; + w (" (* " ^ l ^ ":*)") + end + else have_normal_arg := true; + w (ppMLtype t ~counter); + w " -> " + end; + if not !have_normal_arg then w "unit -> "; + w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *) + w " \n"; + if def.safe then w "\n" + else w "\n(* /unsafe *)\n" +*) + +let write_function_type ~w def = + if !Flags.camltk then camltk_write_function_type ~w def + else labltk_write_function_type ~w def let write_external_type ~w def = match def.template with @@ -96,18 +171,19 @@ let write_external_type ~w def = begin try let realname = find_in_path !search_path (fname ^ ".mli") in let ic = open_in_bin realname in - if not def.safe then w "(* unsafe *)\n"; - begin try - while true do - w (input_line ic); - w "\n" - done - with - | End_of_file -> - close_in ic; - if def.safe then w "\n\n" - else w "\n(* /unsafe *)\n\n" - end + try + let code_list = Ppparse.parse_channel ic in + close_in ic; + if not def.safe then w "(* unsafe *)\n"; + List.iter (Ppexec.exec (fun _ -> ()) w) + (if !Flags.camltk then + Code.Define "CAMLTK" :: code_list else code_list ); + if def.safe then w "\n\n" + else w "\n(* /unsafe *)\n\n" + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) with | Not_found -> raise (Compiler_Error ("can't find external file: " ^ fname)) diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll index 7231656d1..5c04dc674 100644 --- a/otherlibs/labltk/compiler/lexer.mll +++ b/otherlibs/labltk/compiler/lexer.mll @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -31,7 +31,7 @@ let current_line = ref 1 let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t) let _ = List.iter - ~f:(fun (str,tok) -> Hashtbl'.add keyword_table ~key:str ~data:tok) + ~f:(fun (str,tok) -> Hashtbl.add keyword_table str tok) [ "int", TYINT; "float", TYFLOAT; @@ -125,7 +125,9 @@ rule main = parse | ";" { SEMICOLON } | ":" {COLON} | "?" {QUESTION} - | "#" { comment lexbuf; main lexbuf } + | "/" {SLASH} + | "%" { comment lexbuf; main lexbuf } + | "##line" { line lexbuf; main lexbuf } | eof { EOF } | _ { raise (Lexical_error("illegal character")) } @@ -157,3 +159,12 @@ and comment = parse | eof { () } | _ { comment lexbuf } +and linenum = parse + | ['0'-'9']+ { + let next_line = int_of_string (Lexing.lexeme lexbuf) in + current_line := next_line - 1 + } + | _ { raise (Lexical_error("illegal ##line directive: no line number"))} + +and line = parse + | [' ' '\t']* { linenum lexbuf } diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml index 6955afb6e..19b770554 100644 --- a/otherlibs/labltk/compiler/maincompile.ml +++ b/otherlibs/labltk/compiler/maincompile.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -30,7 +30,7 @@ let verbose_endline s = if !flag_verbose then prerr_endline s let input_name = ref "Widgets.src" -let output_dir = ref "lib" +let output_dir = ref "" let destfile f = Filename.concat !output_dir f let usage () = @@ -45,14 +45,30 @@ let prerr_error_header () = prerr_string (string_of_int !Lexer.current_line); prerr_string ": " - +(* parse Widget.src config file *) let parse_file filename = let ic = open_in_bin filename in + let lexbuf = + try + let code_list = Ppparse.parse_channel ic in + close_in ic; + let buf = Buffer.create 50000 in + List.iter (Ppexec.exec + (fun l -> Buffer.add_string buf + (Printf.sprintf "##line %d\n" l)) + (Buffer.add_string buf)) + (if !Flags.camltk then Code.Define "CAMLTK" :: code_list + else code_list); + Lexing.from_string (Buffer.contents buf) + with + | Ppparse.Error s -> + close_in ic; + raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s)) + in try - let lexbuf = Lexing.from_channel ic in - while true do - Parser.entry Lexer.main lexbuf - done + while true do + Parser.entry Lexer.main lexbuf + done with Parsing.Parse_error -> close_in ic; @@ -120,44 +136,51 @@ let uniq_clauses = function let c = constr.var_name in if Hashtbl.mem t c then (check_constr constr (Hashtbl.find t c)) - else Hashtbl'.add t ~key:c ~data:constr); + else Hashtbl.add t c constr); elements t;; let option_hack oc = if Hashtbl.mem types_table "options" then let typdef = Hashtbl.find types_table "options" in let hack = - { parser_arity = OneToken; - constructors = - begin - let constrs = - List.map typdef.constructors ~f: - begin fun c -> - { component = Constructor; - ml_name = c.ml_name; - var_name = c.var_name; (* as variants *) - template = - begin match c.template with - ListArg (x :: _) -> x - | _ -> fatal_error "bogus hack" - end; - result = UserDefined "options_constrs"; - safe = true } - end in - uniq_clauses constrs - end; - subtypes = []; - requires_widget_context = false; - variant = false } + { parser_arity = OneToken; + constructors = begin + let constrs = + List.map typdef.constructors ~f: + begin fun c -> + { component = Constructor; + ml_name = (if !Flags.camltk then "C" ^ c.ml_name + else c.ml_name); + var_name = c.var_name; (* as variants *) + template = + begin match c.template with + ListArg (x :: _) -> x + | _ -> fatal_error "bogus hack" + end; + result = UserDefined "options_constrs"; + safe = true } + end in + if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *) + end; + subtypes = []; + requires_widget_context = false; + variant = false } in write_CAMLtoTK ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs" +let realname name = + (* module name fix for camltk *) + if !Flags.camltk then "c" ^ (String.capitalize name) + else name +;; + +(* analize the parsed Widget.src and output source files *) let compile () = - verbose_endline "Creating tkgen.ml ..."; - let oc = open_out_bin (destfile "tkgen.ml") in - let oc' = open_out_bin (destfile "tkigen.ml") in - let oc'' = open_out_bin (destfile "tkfgen.ml") in + verbose_endline "Creating _tkgen.ml ..."; + let oc = open_out_bin (destfile "_tkgen.ml") in + let oc' = open_out_bin (destfile "_tkigen.ml") in + let oc'' = open_out_bin (destfile "_tkfgen.ml") in let sorted_types = Tsort.sort types_order in verbose_endline " writing types ..."; List.iter sorted_types ~f: @@ -175,7 +198,8 @@ let compile () = if List.mem typname !types_returned then write_TKtoCAML ~w:(output_string oc') typname ~def:typdef; verbose_string "CO "; - write_catch_optionals ~w:(output_string oc') typname ~def:typdef; + if not !Flags.camltk then (* only for LablTk *) + write_catch_optionals ~w:(output_string oc') typname ~def:typdef; verbose_endline "." with Not_found -> if not (List.mem_assoc typname !types_external) then @@ -195,32 +219,49 @@ let compile () = close_out oc''; (* Write the interface for public functions *) (* this interface is used only for documentation *) - verbose_endline "Creating tkgen.mli ..."; - let oc = open_out_bin (destfile "tkgen.mli") in + verbose_endline "Creating _tkgen.mli ..."; + let oc = open_out_bin (destfile "_tkgen.mli") in List.iter (sort_components !function_table) ~f:(write_function_type ~w:(output_string oc)); close_out oc; verbose_endline "Creating other ml, mli ..."; let write_module wname wdef = verbose_endline (" "^wname); - let modname = wname in + let modname = realname wname in let oc = open_out_bin (destfile (modname ^ ".ml")) and oc' = open_out_bin (destfile (modname ^ ".mli")) in + Copyright.write ~w:(output_string oc); + Copyright.write ~w:(output_string oc'); begin match wdef.module_type with Widget -> output_string oc' ("(* The "^wname^" widget *)\n") | Family -> output_string oc' ("(* The "^wname^" commands *)\n") end; - output_string oc "open Protocol\n"; List.iter ~f:(fun s -> output_string oc s; output_string oc' s) - [ "open StdLabels\n"; - "open Tk\n"; - "open Tkintf\n"; - "open Widget\n"; - "open Textvariable\n" ]; + begin + if !Flags.camltk then + [ "open CTk\n"; + "open Tkintf\n"; + "open Widget\n"; + "open Textvariable\n\n" ] + else + [ "open StdLabels\n"; + "open Tk\n"; + "open Tkintf\n"; + "open Widget\n"; + "open Textvariable\n\n" ] + end; + output_string oc "open Protocol\n"; begin match wdef.module_type with Widget -> - write_create ~w:(output_string oc) wname; - write_create_p ~w:(output_string oc') wname + if !Flags.camltk then begin + camltk_write_create ~w:(output_string oc) wname; + camltk_write_named_create ~w:(output_string oc) wname; + camltk_write_create_p ~w:(output_string oc') wname; + camltk_write_named_create_p ~w:(output_string oc') wname; + end else begin + labltk_write_create ~w:(output_string oc) wname; + labltk_write_create_p ~w:(output_string oc') wname + end | Family -> () end; List.iter ~f:(write_function ~w:(output_string oc)) @@ -234,24 +275,86 @@ let compile () = close_out oc; close_out oc' in Hashtbl.iter write_module module_table; + + (* wrapper code camltk.ml and labltk.ml *) + if !Flags.camltk then begin + let oc = open_out_bin (destfile "camltk.ml") in + Copyright.write ~w:(output_string oc); + output_string oc +"(** This module Camltk provides the module name spaces of the CamlTk API. + + The users of the CamlTk API should open this module first to access + the types, functions and modules of the CamlTk API easier. + For the documentation of each sub modules such as [Button] and [Toplevel], + refer to its defintion file, [cButton.mli], [cToplevel.mli], etc. + *) + +"; + output_string oc "include CTk\n"; + output_string oc "module Tk = CTk\n"; + Hashtbl.iter (fun name _ -> + let cname = realname name in + output_string oc (Printf.sprintf "module %s = %s;;\n" + (String.capitalize name) + (String.capitalize cname))) module_table; + close_out oc + end else begin + let oc = open_out_bin (destfile "labltk.ml") in + Copyright.write ~w:(output_string oc); + output_string oc +"(** This module Labltk provides the module name spaces of the LablTk API, + useful to call LablTk functions inside CamlTk programs. 100% LablTk users + do not need to use this. *) + +"; + output_string oc "module Widget = Widget;; +module Protocol = Protocol;; +module Textvariable = Textvariable;; +module Fileevent = Fileevent;; +module Timer = Timer;; +"; + Hashtbl.iter (fun name _ -> + let cname = realname name in + output_string oc (Printf.sprintf "module %s = %s;;\n" + (String.capitalize name) + (String.capitalize name))) module_table; + (* widget typer *) + output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n"; + Hashtbl.iter (fun name def -> + match def.module_type with + | Widget -> + output_string oc (Printf.sprintf + "let %s (w : any widget) =\n" name); + output_string oc (Printf.sprintf + " Rawwidget.check_class w widget_%s_table;\n" name); + output_string oc (Printf.sprintf + " (Obj.magic w : %s widget);;\n\n" name); + | _ -> () ) module_table; + close_out oc + end; + (* write the module list for the Makefile *) (* and hack to death until it works *) let oc = open_out_bin (destfile "modules") in - output_string oc "WIDGETOBJS="; + if !Flags.camltk then output_string oc "CWIDGETOBJS=" + else output_string oc "WIDGETOBJS="; Hashtbl.iter (fun name _ -> + let name = realname name in output_string oc name; output_string oc ".cmo ") module_table; output_string oc "\n"; Hashtbl.iter (fun name _ -> + let name = realname name in output_string oc name; output_string oc ".ml ") module_table; - output_string oc ": tkgen.ml\n\n"; + output_string oc ": _tkgen.ml\n\n"; Hashtbl.iter (fun name _ -> + let name = realname name in output_string oc name; output_string oc ".cmo : "; output_string oc name; @@ -261,14 +364,37 @@ let compile () = output_string oc name; output_string oc ".mli\n") module_table; + + (* for camltk.ml wrapper *) + if !Flags.camltk then begin + output_string oc "camltk.cmo : cTk.cmo "; + Hashtbl.iter + (fun name _ -> + let name = realname name in + output_string oc name; + output_string oc ".cmo ") module_table; + output_string oc "\n" + end; + close_out oc let main () = Arg.parse [ "-verbose", Arg.Unit (fun () -> flag_verbose := true), - "Make output verbose" ] + "Make output verbose"; + "-camltk", Arg.Unit (fun () -> Flags.camltk := true), + "Make CamlTk interface"; + "-outdir", Arg.String (fun s -> output_dir := s), + "output directory"; + "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true), + "debug preprocessor" + ] (fun filename -> input_name := filename) "Usage: tkcompiler <source file>" ; + if !output_dir = "" then begin + prerr_endline "specify -outdir option"; + exit 1 + end; try verbose_endline "Parsing..."; parse_file !input_name; diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly index a22f2f4ab..d338a037c 100644 --- a/otherlibs/labltk/compiler/parser.mly +++ b/otherlibs/labltk/compiler/parser.mly @@ -1,3 +1,19 @@ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + /* $Id$ */ %{ @@ -21,6 +37,7 @@ open Tables %token RBRACKET /* "]" */ %token LBRACE /* "{" */ %token RBRACE /* "}" */ +%token SLASH /* "/" */ %token TYINT /* "int" */ %token TYFLOAT /* "float" */ @@ -66,9 +83,15 @@ Type0 : { UserDefined $1 } ; +/* Camltk/Labltk types */ +Type0_5: + | Type0 SLASH Type0 { if !Flags.camltk then $1 else $3 } + | Type0 { $1 } +; + /* with subtypes */ Type1 : - Type0 + Type0_5 { $1 } | TypeName LPAREN IDENT RPAREN { Subtype ($1, $3) } diff --git a/otherlibs/labltk/compiler/pp.ml b/otherlibs/labltk/compiler/pp.ml new file mode 100644 index 000000000..5c46766af --- /dev/null +++ b/otherlibs/labltk/compiler/pp.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +let _ = + try + let code_list = Ppparse.parse_channel stdin in + List.iter (Ppexec.exec (fun _ -> ()) print_string) code_list + with + | Ppparse.Error s -> prerr_endline s; exit 2 +;; diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml new file mode 100644 index 000000000..6754a6521 --- /dev/null +++ b/otherlibs/labltk/compiler/ppexec.ml @@ -0,0 +1,60 @@ +(***********************************************************************) +(* *) +(* 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 Code + +let debug = ref false +let defined = ref [] +let linenum = ref 1 + +let rec nop = function + | Line _ -> incr linenum + | Ifdef (_, _, c1, c2o) -> + List.iter nop c1; + begin match c2o with + | Some c2 -> List.iter nop c2 + | None -> () + end + | _ -> () +;; + +let rec exec lp f = function + | Line line -> + if !debug then + prerr_endline (Printf.sprintf "%03d: %s" !linenum + (String.sub line 0 ((String.length line) - 1))); + f line; incr linenum + | Ifdef (sw, k, c1, c2o) -> + if List.mem k !defined = sw then begin + List.iter (exec lp f) c1; + begin match c2o with + | Some c2 -> List.iter nop c2 + | None -> () + end; + lp !linenum + end else begin + List.iter nop c1; + match c2o with + | Some c2 -> + lp !linenum; + List.iter (exec lp f) c2 + | None -> () + end + | Define k -> defined := k :: !defined + | Undef k -> + defined := List.fold_right (fun k' s -> + if k = k' then s else k' :: s) [] !defined +;; diff --git a/otherlibs/labltk/compiler/pplex.mli b/otherlibs/labltk/compiler/pplex.mli new file mode 100644 index 000000000..4eaa183b2 --- /dev/null +++ b/otherlibs/labltk/compiler/pplex.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +exception Error of string +val token : Lexing.lexbuf -> Ppyac.token diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll new file mode 100644 index 000000000..d68ee4db6 --- /dev/null +++ b/otherlibs/labltk/compiler/pplex.mll @@ -0,0 +1,57 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +{ +open Ppyac +exception Error of string +let linenum = ref 1 +} + +let blank = [' ' '\013' '\009' '\012'] +let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] +let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] +let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] + +rule token = parse + blank + { token lexbuf } +| "##" [' ' '\t']* { directive lexbuf } +| ("#")? [^ '#' '\n']* '\n'? { + begin + let str = Lexing.lexeme lexbuf in + let line = !linenum in + if String.length str <> 0 && str.[String.length str - 1] = '\n' then + begin + incr linenum + end; + OTHER (str) + end + } +| eof { EOF } + +and directive = parse +| "ifdef" [' ' '\t']+ { IFDEF (ident lexbuf)} +| "ifndef" [' ' '\t']+ { IFNDEF (ident lexbuf)} +| "else" { ELSE } +| "endif" { ENDIF } +| "define" [' ' '\t']+* { DEFINE (ident lexbuf)} +| "undef" [' ' '\t']+ { UNDEF (ident lexbuf)} +| _ { raise (Error (Printf.sprintf "unknown directive at line %d" !linenum))} + +and ident = parse +| lowercase identchar* | uppercase identchar* + { Lexing.lexeme lexbuf } +| _ { raise (Error (Printf.sprintf "illegal identifier at line %d" !linenum)) } diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml new file mode 100644 index 000000000..91287d34a --- /dev/null +++ b/otherlibs/labltk/compiler/ppparse.ml @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +exception Error of string + +let parse_channel ic = + let lexbuf = Lexing.from_channel ic in + try + Ppyac.code_list Pplex.token lexbuf + with + | Pplex.Error s -> + let loc_start = Lexing.lexeme_start lexbuf + and loc_end = Lexing.lexeme_end lexbuf + in + raise (Error (Printf.sprintf "parse error at char %d, %d: %s" + loc_start loc_end s)) + | Parsing.Parse_error -> + let loc_start = Lexing.lexeme_start lexbuf + and loc_end = Lexing.lexeme_end lexbuf + in + raise (Error (Printf.sprintf "parse error at char %d, %d" + loc_start loc_end)) +;; diff --git a/otherlibs/labltk/compiler/ppyac.mly b/otherlibs/labltk/compiler/ppyac.mly new file mode 100644 index 000000000..da7ee681f --- /dev/null +++ b/otherlibs/labltk/compiler/ppyac.mly @@ -0,0 +1,52 @@ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +%{ +open Code +%} + +%token <string> IFDEF +%token <string> IFNDEF +%token ELSE +%token ENDIF +%token <string> DEFINE +%token <string> UNDEF +%token <string> OTHER +%token EOF + +/* entry */ + +%start code_list +%type <Code.code list> code_list + +%% + +code_list: + /* empty */ { [] } + | code code_list { $1 :: $2 } +; + +code: + | DEFINE { Define $1 } + | UNDEF { Undef $1 } + | IFDEF code_list ELSE code_list ENDIF { Ifdef (true, $1, $2, Some ($4)) } + | IFNDEF code_list ELSE code_list ENDIF { Ifdef (false, $1, $2, Some ($4)) } + | IFDEF code_list ENDIF { Ifdef (true, $1, $2, None) } + | IFNDEF code_list ENDIF { Ifdef (false, $1, $2, None) } + | OTHER { Line $1 } +; + +%% diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml index e4daa173a..60362d17f 100644 --- a/otherlibs/labltk/compiler/printer.ml +++ b/otherlibs/labltk/compiler/printer.ml @@ -1,16 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Pierre Weis, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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 Tables;; diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml index 77c4f50b4..0d395cdc2 100644 --- a/otherlibs/labltk/compiler/tables.ml +++ b/otherlibs/labltk/compiler/tables.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -56,8 +56,8 @@ type component_type = (* Full definition of a component *) type fullcomponent = { component : component_type; - ml_name : string; (* may be no longer useful *) - var_name : string; + ml_name : string; (* used for camltk *) + var_name : string; (* used just for labltk *) template : template; result : mltype; safe : bool @@ -157,7 +157,7 @@ let new_type typname arity = subtypes = []; requires_widget_context = false; variant = false} in - Hashtbl'.add types_table ~key:typname ~data:typdef; + Hashtbl.add types_table typname typdef; typdef @@ -395,10 +395,11 @@ let enter_widget name components = try List.assoc External sorted_components with Not_found -> [] in - Hashtbl'.add module_table ~key:name - ~data:{module_type = Widget; commands = commands; externals = externals} + Hashtbl.add module_table name + {module_type = Widget; commands = commands; externals = externals} (******************** Functions ********************) + let enter_function comp = enter_component_types comp; function_table := comp :: !function_table @@ -422,5 +423,5 @@ let enter_module name components = try List.assoc External sorted_components with Not_found -> [] in - Hashtbl'.add module_table ~key:name - ~data:{module_type = Family; commands = commands; externals = externals} + Hashtbl.add module_table name + {module_type = Family; commands = commands; externals = externals} diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml index 517d72497..a174fb3da 100644 --- a/otherlibs/labltk/compiler/tsort.ml +++ b/otherlibs/labltk/compiler/tsort.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) diff --git a/otherlibs/labltk/examples_camltk/.cvsignore b/otherlibs/labltk/examples_camltk/.cvsignore new file mode 100644 index 000000000..801812fd3 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/.cvsignore @@ -0,0 +1,8 @@ +addition +eyes +fileinput +fileopen +helloworld +tetris +winskel +mytext diff --git a/otherlibs/labltk/examples_camltk/Makefile b/otherlibs/labltk/examples_camltk/Makefile new file mode 100644 index 000000000..42613054b --- /dev/null +++ b/otherlibs/labltk/examples_camltk/Makefile @@ -0,0 +1,52 @@ +include ../support/Makefile.common + +# We are using the non-installed library ! +COMPFLAGS=-I ../lib -I ../camltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support + + +all: addition$(EXE) helloworld$(EXE) winskel$(EXE) fileinput$(EXE) \ + eyes$(EXE) tetris$(EXE) mytext$(EXE) fileopen$(EXE) + +addition$(EXE): addition.cmo + $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma addition.cmo + +helloworld$(EXE): helloworld.cmo + $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma helloworld.cmo + +winskel$(EXE): winskel.cmo + $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma winskel.cmo + +fileinput$(EXE): fileinput.cmo + $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma fileinput.cmo + +socketinput$(EXE): socketinput.cmo + $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma socketinput.cmo + +eyes$(EXE): eyes.cmo + $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma eyes.cmo + +tetris$(EXE): tetris.cmo + $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma tetris.cmo + +mytext$(EXE): mytext.cmo + $(CAMLC) $(COMPFLAGS) -o $@ unix.cma $(LIBNAME).cma mytext.cmo + +# graph$(EXE): graphics.cmo graphics_test.cmo +# $(CAMLC) -o $@ graphics.cmo graphics_test.cmo +# +# graphics_test.cmo: graphics.cmo + +fileopen$(EXE): fileopen.cmo + $(CAMLC) $(COMPFLAGS) -o $@ $(LIBNAME).cma fileopen.cmo + +clean : + rm -f *.cm? $(EXECS) addition eyes fileinput fileopen helloworld jptest mytext tetris winskel + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_camltk/Makefile.nt b/otherlibs/labltk/examples_camltk/Makefile.nt new file mode 100644 index 000000000..7b6b8f24b --- /dev/null +++ b/otherlibs/labltk/examples_camltk/Makefile.nt @@ -0,0 +1,38 @@ +!include ..\support\Makefile.common.nt + +# We are using the non-installed library ! +COMPFLAGS= -I ../lib -I ../camltk -I ../support +LINKFLAGS= -I ../lib -I ../camltk -I ../support + +# Use pieces of Makefile.config +TKLINKOPT=$(LIBNAME).cma $(TKLIBS) + +all: addition.exe helloworld.exe winskel.exe socketinput.exe + +addition.exe: addition.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ addition.cmo + +helloworld.exe: helloworld.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ helloworld.cmo + +winskel.exe: winskel.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ winskel.cmo + +socketinput.exe: socketinput.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ + -o $@ socketinput.cmo + +clean : + rm -f *.cm? *.exe + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml new file mode 100644 index 000000000..8f9365bdb --- /dev/null +++ b/otherlibs/labltk/examples_camltk/addition.ml @@ -0,0 +1,53 @@ +(***********************************************************************) +(* *) +(* 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 + +let main () = + let top = opentk () in + (* The widgets. They all have "top" as parent widget. *) + let en1 = Entry.create top [TextWidth 6; Relief Sunken] in + let lab1 = Label.create top [Text "plus"] in + let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in + let lab2 = Label.create top [Text "="] in + let result_display = Label.create top [] in + (* References holding values of entry widgets *) + let n1 = ref 0 + and n2 = ref 0 in + (* Refresh result *) + let refresh () = + Label.configure result_display [Text (string_of_int (!n1 + !n2))] in + (* Electric *) + let get_and_refresh (w,r) = + fun _ _ -> + try + r := int_of_string (Entry.get w); + refresh () + with + Failure "int_of_string" -> + Label.configure result_display [Text "error"] + in + (* Set the callbacks *) + Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; + Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; + (* Map the widgets *) + pack [en1;lab1;en2;lab2;result_display] []; + (* Make the window resizable *) + Wm.minsize_set top 1 1; + (* Start interaction (event-driven program) *) + mainLoop () +;; + +let _ = Printexc.catch main () ;; diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml new file mode 100644 index 000000000..5666c69c5 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/eyes.ml @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* The eyes of Caml (CamlTk) *) + +open Camltk;; + +let _ = + let top = opentk () in + + let fw = Frame.create top [] in + 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 = + Canvas.create_oval c + (Pixels (cx - wx)) (Pixels (cy - wy)) + (Pixels (cx + wx)) (Pixels (cy + wy)) + [Outline (NamedColor "black"); Width (Pixels 7); + FillColor (NamedColor "white")] + and o = + Canvas.create_oval c + (Pixels (cx - ewx)) (Pixels (cy - ewy)) + (Pixels (cx + ewx)) (Pixels (cy + ewy)) + [FillColor (NamedColor "black")] in + let curx = ref cx + and cury = ref cy in + bind c [[], Motion] + (BindExtend ([Ev_MouseX; Ev_MouseY], + (fun e -> + let nx, ny = + let xdiff = e.ev_MouseX - cx + and ydiff = e.ev_MouseY - cy in + let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. + (float ydiff /. (float wy *. bnd)) ** 2.0) in + if diff > 1.0 then + truncate ((float xdiff) *. (1.0 /. diff)) + cx, + truncate ((float ydiff) *. (1.0 /. diff)) + cy + else + e.ev_MouseX, e.ev_MouseY + in + Canvas.move c o (Pixels (nx - !curx)) (Pixels (ny - !cury)); + curx := nx; + cury := ny))) + in + create_eye 60 100 30 40 5 6 0.6; + create_eye 140 100 30 40 5 6 0.6; + pack [c] [] + +let _ = Printexc.print mainLoop () + + + + diff --git a/otherlibs/labltk/examples_camltk/fileinput.ml b/otherlibs/labltk/examples_camltk/fileinput.ml new file mode 100644 index 000000000..35e7e8358 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/fileinput.ml @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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 ;; + +let top_w = opentk () ;; +let buffer = String.create 256 ;; +let (fd_in, fd_out) = Unix.pipe () ;; +let text0_w = Text.create top_w [] ;; +let entry0_w = Entry.create top_w [] ;; +let button0_w = Button.create top_w [Text "Quit"; Command (fun _ -> exit 0)] ;; +Fileevent.add_fileinput fd_in (fun _ -> + let n = Unix.read fd_in buffer 0 (String.length buffer) in + let txt = String.sub buffer 0 n in + Text.insert text0_w (TextIndex (End, [])) txt []) ;; +let send _ = + let txt = Entry.get entry0_w ^ "\n" in + Entry.delete_range entry0_w (At 0) End ; + ignore (Unix.write fd_out txt 0 (String.length txt));; + +bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)) ; +pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true] ;; +mainLoop () ;; diff --git a/otherlibs/labltk/examples_camltk/fileopen.ml b/otherlibs/labltk/examples_camltk/fileopen.ml new file mode 100644 index 000000000..b7bd163f3 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/fileopen.ml @@ -0,0 +1,56 @@ +(***********************************************************************) +(* *) +(* 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;; + +let win = opentk();; + +let cvs = Canvas.create win [];; + +let t = Label.create cvs [Text "File name"];; + +let b = + Button.create cvs + [Text "Save"; + Command + (function _ -> + let s = + getSaveFile + [Title "SAVE FILE TEST"; + DefaultExtension ".foo"; + FileTypes [ { typename= "just test"; + extensions= [".foo"; ".test"]; + mactypes= ["FOOO"; "BARR"] } ]; + InitialDir "/tmp"; + InitialFile "hogehoge" ] in + Label.configure t [Text s])];; + +let bb = + Button.create cvs + [Text "Open"; + Command + (function _ -> + let s = getOpenFile [] in + Label.configure t [Text s])];; + +let q = + Button.create cvs + [Text "Quit"; + Command + (function _ -> closeTk (); exit 0)];; + +pack [cvs; q; bb; b; t] [];; + +mainLoop ();; diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml new file mode 100644 index 000000000..b32b515ae --- /dev/null +++ b/otherlibs/labltk/examples_camltk/helloworld.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* 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;; (* Make interface functions available *) + +let top = opentk ();; (* Initialisation of the interface *) +(* top is now the toplevel widget *) + +(* Widget initialisation *) +let b = Button.create top + [Text "foobar"; + Command (function () -> + print_string "foobar"; + print_newline(); + flush stdout)];; +(* b exists but is not yet visible *) + +let q = Button.create top + [Text "quit"; + Command closeTk];; +(* q exists but is not yet visible *) + +pack [b; q][] ;; (* Make b visible *) +mainLoop() ;; (* User interaction*) +(* You can quit this program by deleting its main window *) diff --git a/otherlibs/labltk/examples_camltk/images/CamlBook.gif b/otherlibs/labltk/examples_camltk/images/CamlBook.gif Binary files differnew file mode 100644 index 000000000..fb7e52b10 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/images/CamlBook.gif diff --git a/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif b/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif Binary files differnew file mode 100644 index 000000000..fdd1f078f --- /dev/null +++ b/otherlibs/labltk/examples_camltk/images/Lambda2.back.gif diff --git a/otherlibs/labltk/examples_camltk/images/dojoji.back.gif b/otherlibs/labltk/examples_camltk/images/dojoji.back.gif Binary files differnew file mode 100644 index 000000000..d4e07fdd7 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/images/dojoji.back.gif diff --git a/otherlibs/labltk/examples_camltk/jptest.ml b/otherlibs/labltk/examples_camltk/jptest.ml new file mode 100644 index 000000000..38d9694c3 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/jptest.ml @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* 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 Tk + +let win = opentk();; + +let b = Button.create win [ Text "�������" ];; +let _ = pack [b] [];; + +mainLoop();; diff --git a/otherlibs/labltk/examples_camltk/mytext.ml b/otherlibs/labltk/examples_camltk/mytext.ml new file mode 100644 index 000000000..0695d931a --- /dev/null +++ b/otherlibs/labltk/examples_camltk/mytext.ml @@ -0,0 +1,63 @@ +(***********************************************************************) +(* *) +(* 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 + +let top = opentk () + +let scroll_link sb tx = + Text.configure tx [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb [ScrollCommand (Text.yview tx)] + +let f = Frame.create top [] +let text = Text.create f [] +let scrollbar = Scrollbar.create f [] + +(* kill buffer *) +let buffer = ref "" + +(* Note: for the text widgets, the insertion cursor is + not TextIndex(Insert, []), + but TextIndex(Mark "insert", []) +*) +let insertMark = TextIndex(Mark "insert", []) +let eol_insertMark = TextIndex(Mark "insert", [LineEnd]) + +let kill () = + buffer := + Text.get text insertMark eol_insertMark; + prerr_endline ("Killed: " ^ !buffer); + Text.delete text insertMark eol_insertMark +;; + +let yank () = + Text.insert text insertMark !buffer []; + prerr_endline ("Yanked: " ^ !buffer) +;; + +let _ = + scroll_link scrollbar text; + + pack [text; scrollbar][Side Side_Left; Fill Fill_Y]; + pack [f][]; + + bind text [[Control], KeyPressDetail "y"] + (BindSet ([], fun _ -> yank () )); + bind text [[Control], KeyPressDetail "k"] + (BindSet ([], fun _ -> kill () )); + + mainLoop () +;; + diff --git a/otherlibs/labltk/examples_camltk/socketinput.ml b/otherlibs/labltk/examples_camltk/socketinput.ml new file mode 100644 index 000000000..d23b8fd5e --- /dev/null +++ b/otherlibs/labltk/examples_camltk/socketinput.ml @@ -0,0 +1,43 @@ +(***********************************************************************) +(* *) +(* 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 + +let _ = + let top_w = opentk () in + let text0_w = Text.create top_w [] in + let entry0_w = Entry.create top_w [] in + let button0_w = Button.create top_w + [Text "Quit"; Command (fun _ -> exit 0)] in + let buffer = String.create 256 in + let master_socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.bind master_socket (Unix.ADDR_INET(Unix.inet_addr_any, 6789)); + Unix.listen master_socket 3; + print_string "Please connect to port 6789..."; print_newline(); + let (sock, _) = Unix.accept master_socket in + Fileevent.add_fileinput sock + (fun _ -> + let n = Unix.recv sock buffer 0 (String.length buffer) [] in + let txt = String.sub buffer 0 n in + Text.insert text0_w (TextIndex (End, [])) txt []); + let send _ = + let txt = Entry.get entry0_w ^ "\n" in + Entry.delete_range entry0_w (At 0) End ; + Unix.send sock txt 0 (String.length txt) []; + () in + bind entry0_w [([], KeyPressDetail "Return")] (BindSet ([], send)); + pack [text0_w; entry0_w; button0_w][Side Side_Top; Fill Fill_X; Expand true]; + mainLoop () + diff --git a/otherlibs/labltk/examples_camltk/taddition.ml b/otherlibs/labltk/examples_camltk/taddition.ml new file mode 100644 index 000000000..b4745d6c0 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/taddition.ml @@ -0,0 +1,53 @@ +(***********************************************************************) +(* *) +(* 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 Tk + +let main () = + let top = opentk () in + (* The widgets. They all have "top" as parent widget. *) + let en1 = Entry.create top [TextWidth 6; Relief Sunken] in + let lab1 = Label.create top [Text "plus"] in + let en2 = Entry.create top [TextWidth 6 ; Relief Sunken] in + let lab2 = Label.create top [Text "="] in + let result_display = Label.create top [] in + (* References holding values of entry widgets *) + let n1 = ref 0 + and n2 = ref 0 in + (* Refresh result *) + let refresh () = + Label.configure result_display [Text (string_of_int (!n1 + !n2))] in + (* Electric *) + let get_and_refresh (w,r) = + fun _ _ -> + try + r := int_of_string (Entry.get w); + refresh () + with + Failure "int_of_string" -> + Label.configure result_display [Text "error"] + in + (* Set the callbacks *) + Entry.configure en1 [XScrollCommand (get_and_refresh (en1,n1)) ]; + Entry.configure en2 [XScrollCommand (get_and_refresh (en2,n2)) ]; + (* Map the widgets *) + pack [en1;lab1;en2;lab2;result_display] []; + (* Make the window resizable *) + Wm.minsize_set top 1 1; + (* Start interaction (event-driven program) *) + Threadtk.mainLoop () +;; + +let _ = Printexc.catch main () ;; diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml new file mode 100644 index 000000000..f4239a804 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/tetris.ml @@ -0,0 +1,685 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* A Tetris game for CamlTk *) +(* written by Jun P. Furuse *) + +open Camltk + +exception Done + +type cell = {mutable color : int; + tag : tagOrId * tagOrId * tagOrId} + +type falling_block = { + mutable pattern: int array list; + mutable bcolor: int; + mutable x: int; + mutable y: int; + mutable d: int; + mutable alive: bool +} + +let stop_a_bit = 300 + +let colors = [| + NamedColor "red"; + NamedColor "yellow"; + + NamedColor "blue"; + NamedColor "orange"; + + NamedColor "magenta"; + NamedColor "green"; + + NamedColor "cyan" +|] + +let baseurl = "images/" + +let backgrounds = + List.map (fun s -> baseurl ^ s) + [ "dojoji.back.gif"; + "Lambda2back.gif"; + "CamlBook.gif"; + ] + +(* blocks *) +let block_size = 16 +let cell_border = 2 + +let blocks = [ + [ [|"0000"; + "0000"; + "1111"; + "0000" |]; + + [|"0010"; + "0010"; + "0010"; + "0010" |]; + + [|"0000"; + "0000"; + "1111"; + "0000" |]; + + [|"0010"; + "0010"; + "0010"; + "0010" |] ]; + + [ [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "0111"; + "0100"; + "0000" |]; + + [|"0000"; + "0110"; + "0010"; + "0010" |]; + + [|"0000"; + "0010"; + "1110"; + "0000" |]; + + [|"0100"; + "0100"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "0100"; + "0111"; + "0000" |]; + + [|"0000"; + "0110"; + "0100"; + "0100" |]; + + [|"0000"; + "1110"; + "0010"; + "0000" |]; + + [|"0010"; + "0010"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "1100"; + "0110"; + "0000" |]; + + [|"0010"; + "0110"; + "0100"; + "0000" |]; + + [|"0000"; + "1100"; + "0110"; + "0000" |]; + + [|"0010"; + "0110"; + "0100"; + "0000" |] ]; + + [ [|"0000"; + "0011"; + "0110"; + "0000" |]; + + [|"0100"; + "0110"; + "0010"; + "0000" |]; + + [|"0000"; + "0011"; + "0110"; + "0000" |]; + + [|"0000"; + "0100"; + "0110"; + "0010" |] ]; + + [ [|"0000"; + "0000"; + "1110"; + "0100" |]; + + [|"0000"; + "0100"; + "1100"; + "0100" |]; + + [|"0000"; + "0100"; + "1110"; + "0000" |]; + + [|"0000"; + "0100"; + "0110"; + "0100" |] ] + +] + +let line_empty = int_of_string "0b1110000000000111" +let line_full = int_of_string "0b1111111111111111" + +let decode_block dvec = + let btoi d = int_of_string ("0b"^d) in + Array.map btoi dvec + +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)); + Height (Pixels (block_size * 20)); + BorderWidth (Pixels cell_border); + Relief Sunken; + Background Black] + and r = Frame.create f [] + and r' = Frame.create f [] in + + let nl = Label.create r [Text "Next"; Font "variable"] in + let nc = Canvas.create r [Width (Pixels (block_size * 4)); + Height (Pixels (block_size * 4)); + BorderWidth (Pixels cell_border); + Relief Sunken; + Background Black] in + let scl = Label.create r [Text "Score"; Font "variable"] in + let sc = Label.create r [TextVariable scorev; Font "variable"] in + let lnl = Label.create r [Text "Lines"; Font "variable"] in + let ln = Label.create r [TextVariable linev; Font "variable"] in + let levl = Label.create r [Text "Level"; Font "variable"] in + let lev = Label.create r [TextVariable levv; Font "Variable"] in + let newg = Button.create r [Text "New Game"; Font "variable"] in + let exitg = Button.create r [Text "Quit"; Font "variable"] in + + pack [f] []; + pack [c; r; r'] [Side Side_Left; Fill Fill_Y]; + pack [nl; nc] [Side Side_Top]; + pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top]; + + let cells_src = Array.create 20 (Array.create 10 ()) in + let cells = Array.map (Array.map (fun () -> + {tag= + (let t1, t2, t3 = + Canvas.create_rectangle c + (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) + (Pixels (-9)) (Pixels (-9)) [], + Canvas.create_rectangle c + (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) + (Pixels (-11)) (Pixels (-11)) [], + Canvas.create_rectangle c + (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) + (Pixels (-13)) (Pixels (-13)) [] + in + Canvas.raise_top c t1; + Canvas.raise_top c t2; + Canvas.lower_bot c t3; + t1,t2,t3); + color= 0})) cells_src + in + let nexts_src = Array.create 4 (Array.create 4 ()) in + let nexts = + Array.map (Array.map (fun () -> + {tag= + (let t1, t2, t3 = + Canvas.create_rectangle nc + (Pixels (-block_size - 8)) (Pixels (-block_size - 8)) + (Pixels (-9)) (Pixels (-9)) [], + Canvas.create_rectangle nc + (Pixels (-block_size - 10)) (Pixels (-block_size - 10)) + (Pixels (-11)) (Pixels (-11)) [], + Canvas.create_rectangle nc + (Pixels (-block_size - 12)) (Pixels (-block_size - 12)) + (Pixels (-13)) (Pixels (-13)) [] + in + Canvas.raise_top nc t1; + Canvas.raise_top nc t2; + Canvas.lower_bot nc t3; + t1, t2, t3); + color= 0})) nexts_src in + let game_over () = () + in + [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg, + (c, cells), (nc, nexts), scorev, linev, levv, game_over + +let cell_get (c, cf) x y = + (Array.get (Array.get cf y) x).color + +let cell_set (c, cf) x y col = + let cur = Array.get (Array.get cf y) x in + let t1,t2,t3 = cur.tag in + if cur.color = col then () + else + if cur.color <> 0 && col = 0 then + begin + Canvas.move c t1 + (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) + (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); + Canvas.move c t2 + (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) + (Pixels (- block_size * (y + 1) -10 - cell_border * 2)); + Canvas.move c t3 + (Pixels (- block_size * (x + 1) -10 - cell_border * 2)) + (Pixels (- block_size * (y + 1) -10 - cell_border * 2)) + end + else + begin + Canvas.configure_rectangle c t2 + [FillColor (Array.get colors (col - 1)); + Outline (Array.get colors (col - 1))]; + Canvas.configure_rectangle c t1 + [FillColor Black; + Outline Black]; + Canvas.configure_rectangle c t3 + [FillColor (NamedColor "light gray"); + Outline (NamedColor "light gray")]; + if cur.color = 0 && col <> 0 then + begin + Canvas.move c t1 + (Pixels (block_size * (x+1)+10+ cell_border*2)) + (Pixels (block_size * (y+1)+10+ cell_border*2)); + Canvas.move c t2 + (Pixels (block_size * (x+1)+10+ cell_border*2)) + (Pixels (block_size * (y+1)+10+ cell_border*2)); + Canvas.move c t3 + (Pixels (block_size * (x+1)+10+ cell_border*2)) + (Pixels (block_size * (y+1)+10+ cell_border*2)) + end + end; + cur.color <- col + +let draw_block field col d x y = + for iy = 0 to 3 do + let base = ref 1 in + let xd = Array.get d iy in + for ix = 0 to 3 do + if xd land !base <> 0 then + begin + try cell_set field (ix + x) (iy + y) col with _ -> () + end + else + begin + (* cell_set field (ix + x) (iy + y) 0 *) () + end; + base := !base lsl 1 + done + done + +let timer_ref = (ref None : Timer.t option ref) +(* I know, this should be timer ref, but I'm not sure what should be + the initial value ... *) + +let remove_timer () = + match !timer_ref with + | None -> () + | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) + +let do_after milli f = + timer_ref := Some (Timer.add milli f) + +let copy_block c = + { pattern= !c.pattern; + bcolor= !c.bcolor; + x= !c.x; + y= !c.y; + d= !c.d; + alive= !c.alive } + +let _ = + let top = opentk () in + let lb = Label.create top [] + and fw = Frame.create top [] + in + let set_message s = Label.configure lb [Text s] in + pack [lb; fw] [Side Side_Top]; + let score = ref 0 in + let line = ref 0 in + let level = ref 0 in + let time = ref 1000 in + let blocks = List.map (List.map decode_block) blocks in + let field = Array.create 26 0 in + let widgets, newg, exitg, cell_field, next_field, + scorev, linev, levv, game_over = + init fw in + let canvas = fst cell_field in + + let init_field () = + for i = 0 to 25 do + field.(i) <- line_empty + done; + field.(23) <- line_full; + for i = 0 to 19 do + for j = 0 to 9 do + cell_set cell_field j i 0 + done + done; + for i = 0 to 3 do + for j = 0 to 3 do + cell_set next_field j i 0 + done + done + in + + let draw_falling_block fb = + draw_block cell_field fb.bcolor + (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) + + and erase_falling_block fb = + draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) + in + + let stone fb = + for i=0 to 3 do + let cur = field.(i + fb.y) in + field.(i + fb.y) <- + cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) + done; + for i=0 to 2 do + field.(i) <- line_empty + done + + and clear fb = + let l = ref 0 in + for i = 0 to 3 do + if i + fb.y >= 3 && i + fb.y <= 22 then + if field.(i + fb.y) = line_full then + begin + incr l; + field.(i + fb.y) <- line_empty; + for j = 0 to 9 do + cell_set cell_field j (i + fb.y - 3) 0 + done + end + done; + !l + + and fall_lines () = + let eye = ref 22 (* bottom *) + and cur = ref 22 (* bottom *) + in + try + while !eye >= 3 do + while field.(!eye) = line_empty do + decr eye; + if !eye = 2 then raise Done + done; + field.(!cur) <- field.(!eye); + for j = 0 to 9 do + cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3)) + done; + decr eye; + decr cur + done + with Done -> (); + for i = 3 to !cur do + field.(i) <- line_empty; + for j = 0 to 9 do + cell_set cell_field j (i-3) 0 + done + done + in + + let next = ref 42 (* THE ANSWER *) + and current = + ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} + in + + let draw_next () = + draw_block next_field (!next+1) (List.hd (List.nth blocks !next)) 0 0 + + and erase_next () = + draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 + in + + let set_nextblock () = + current := + { pattern= (List.nth blocks !next); + bcolor= !next+1; + x=6; y= 1; d= 0; alive= true}; + erase_next (); + next := Random.int 7; + draw_next () + in + + let death_check fb = + try + for i=0 to 3 do + let cur = field.(i + fb.y) in + if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 + then raise Done + done; + false + with + Done -> true + in + + let try_to_move m = + if !current.alive then + let sub m = + if death_check m then false + else + begin + erase_falling_block !current; + draw_falling_block m; + current := m; + true + end + in + if sub m then () + else + begin + m.x <- m.x + 1; + if sub m then () + else + begin + m.x <- m.x - 2; + ignore (sub m) + end + end + else () + in + + let image_load = + let i = Canvas.create_image canvas + (Pixels (block_size * 5 + block_size / 2)) + (Pixels (block_size * 10 + block_size / 2)) + [Anchor Center] in + Canvas.lower_bot canvas i; + let img = Imagephoto.create [] in + fun file -> + try + Imagephoto.configure img [File file]; + Canvas.configure_image canvas i [ImagePhoto img] + with + _ -> + begin + Printf.eprintf "%s : No such image...\n" file; + flush stderr + end + in + + let add_score l = + let pline = !line in + if l <> 0 then + begin + line := !line + l; + score := !score + l * l; + set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) + end; + Textvariable.set linev (string_of_int !line); + Textvariable.set scorev (string_of_int !score); + + if !line /10 <> pline /10 then + (* update the background every 10 lines. *) + begin + let num_image = List.length backgrounds - 1 in + let n = !line/10 in + let n = if n > num_image then num_image else n in + let file = List.nth backgrounds n in + image_load file; + (* Future work: We should gain level after an image is put... *) + incr level; + Textvariable.set levv (string_of_int !level) + end + in + + let rec newblock () = + set_message "TETRIS"; + set_nextblock (); + draw_falling_block !current; + if death_check !current then + begin + !current.alive <- false; + set_message "GAME OVER"; + game_over () + end + else + begin + time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); + if !time < 60 - !level * 3 then time := 60 - !level * 3; + do_after stop_a_bit loop + end + + and loop () = + let m = copy_block current in + m.y <- m.y + 1; + if death_check m then + begin + !current.alive <- false; + stone !current; + do_after stop_a_bit (fun () -> + let l = clear !current in + if l > 0 then + do_after stop_a_bit (fun () -> + fall_lines (); + add_score l; + do_after stop_a_bit newblock) + else + newblock ()) + end + else + begin + erase_falling_block !current; + draw_falling_block m; + current := m; + do_after !time loop + end + in + + let bind_game w = + bind w [([], KeyPress)] (BindSet ([Ev_KeySymString], + fun e -> + match e.ev_KeySymString with + | "h" -> + let m = copy_block current in + m.x <- m.x - 1; + try_to_move m + | "j" -> + let m = copy_block current in + m.d <- m.d + 1; + if m.d = List.length m.pattern then m.d <- 0; + try_to_move m + | "k" -> + let m = copy_block current in + m.d <- m.d - 1; + if m.d < 0 then m.d <- List.length m.pattern - 1; + try_to_move m + | "l" -> + let m = copy_block current in + m.x <- m.x + 1; + try_to_move m + | "m" -> + remove_timer (); + loop () + | "space" -> + if !current.alive then + begin + let m = copy_block current + and n = copy_block current in + while + m.y <- m.y + 1; + if death_check m then false + else begin n.y <- m.y; true end + do () done; + erase_falling_block !current; + draw_falling_block n; + current := n; + remove_timer (); + loop () + end + | _ -> () + )) + in + + let game_init () = + (* Game Initialization *) + set_message "Initializing ..."; + remove_timer (); + image_load (List.hd backgrounds); + time := 1000; + score := 0; + line := 0; + level := 1; + add_score 0; + init_field (); + next := Random.int 7; + set_message "Welcome to TETRIS"; + set_nextblock (); + draw_falling_block !current; + do_after !time loop + in + bind_game top; + Button.configure newg [Command game_init]; + Button.configure exitg [Command (fun () -> closeTk (); exit 0)]; + game_init () + +let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_camltk/text.ml b/otherlibs/labltk/examples_camltk/text.ml new file mode 100644 index 000000000..0001ae75a --- /dev/null +++ b/otherlibs/labltk/examples_camltk/text.ml @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* 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 Tk + +let top = opentk () + +let scroll_link sb tx = + Text.configure tx [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb [ScrollCommand (Text.yview tx)] + +let f = Frame.create top [] +let text = Text.create f [] +let scrollbar = Scrollbar.create f [] + +let buffer = ref "" + +let kill () = + buffer := + Text.get text (TextIndex (Insert, [])) + (TextIndex (Insert, [LineEnd])); + Text.delete text (TextIndex (Insert, [])) + (TextIndex (Insert, [LineEnd])) +;; + +let yank () = + Text.insert text (TextIndex (Insert, [])) !buffer [] + +let _ = bind text [[Control], KeyPressDetail "y"] (BindSet ([], fun _ -> + yank () )) +;; +let _ = bind text [[Control], KeyPressDetail "k"] (BindSet ([], fun _ -> + kill () )) +;; + +let _ = + scroll_link scrollbar text; + + pack [text;f][]; + pack [f][]; + mainLoop () +;; + diff --git a/otherlibs/labltk/examples_camltk/winskel.ml b/otherlibs/labltk/examples_camltk/winskel.ml new file mode 100644 index 000000000..2ca1da174 --- /dev/null +++ b/otherlibs/labltk/examples_camltk/winskel.ml @@ -0,0 +1,63 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* This examples is based on Ousterhout's book (fig 16.15) *) +open Camltk + +let main () = + let top = opentk() in + let mbar = Frame.create top [Relief Raised; BorderWidth (Pixels 2)] + and dummy = + Frame.create top [Width (Centimeters 10.); Height (Centimeters 5.)] in + pack [mbar; dummy] [Side Side_Top; Fill Fill_X]; + let file = Menubutton.create mbar [Text "File"; UnderlinedChar 0] + and edit = Menubutton.create mbar [Text "Edit"; UnderlinedChar 0] + and graphics = Menubutton.create mbar [Text "Graphics"; UnderlinedChar 0] + and text = Menubutton.create mbar [Text "Text"; UnderlinedChar 0] + and view = Menubutton.create mbar [Text "View"; UnderlinedChar 0] + and help = Menubutton.create mbar [Text "Help"; UnderlinedChar 0] in + pack [file;edit;graphics;text;view] [Side Side_Left]; + pack [help] [Side Side_Right]; + (* same code as chap16-14 *) + let m = Menu.create text [] in + let bold = Textvariable.create() + and italic = Textvariable.create() + and underline = Textvariable.create() in + Menu.add_checkbutton m [Label "Bold"; Variable bold]; + Menu.add_checkbutton m [Label "Italic"; Variable italic]; + Menu.add_checkbutton m [Label "Underline"; Variable underline]; + Menu.add_separator m; + let font = Textvariable.create() in + Menu.add_radiobutton m [Label "Times"; Variable font; Value "times"]; + Menu.add_radiobutton m [Label "Helvetica"; Variable font; Value "helvetica"] +; + Menu.add_radiobutton m [Label "Courier"; Variable font; Value "courier"]; + Menu.add_separator m; + Menu.add_command m [Label "Insert Bullet"; + Command (function () -> + print_string "Insert Bullet\n"; + flush stdout)]; + Menu.add_command m [Label "Margins and Tags..."; + Command (function () -> + print_string "margins\n"; + flush stdout)]; + Menubutton.configure text [Menu m]; + + mainLoop() + + + +let _ = + Printexc.catch main () diff --git a/otherlibs/labltk/examples_labltk/.cvsignore b/otherlibs/labltk/examples_labltk/.cvsignore new file mode 100644 index 000000000..9b2c11726 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/.cvsignore @@ -0,0 +1,7 @@ +calc +clock +demo +eyes +hello +tetris +lang diff --git a/otherlibs/labltk/examples_labltk/Lambda2.back.gif b/otherlibs/labltk/examples_labltk/Lambda2.back.gif Binary files differnew file mode 100644 index 000000000..fdd1f078f --- /dev/null +++ b/otherlibs/labltk/examples_labltk/Lambda2.back.gif diff --git a/otherlibs/labltk/examples_labltk/Makefile b/otherlibs/labltk/examples_labltk/Makefile new file mode 100644 index 000000000..11e322b70 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/Makefile @@ -0,0 +1,50 @@ +include ../support/Makefile.common + +COMPFLAGS=-I ../lib -I ../labltk -I ../support -I $(OTHERS)/unix -w s -dllpath ../support + +all: hello demo eyes calc clock tetris lang + +opt: hello.opt demo.opt eyes.opt calc.opt clock.opt tetris.opt + +hello: hello.cmo + $(CAMLC) $(COMPFLAGS) -o hello $(LIBNAME).cma hello.cmo + +demo: demo.cmo + $(CAMLC) $(COMPFLAGS) -o demo $(LIBNAME).cma demo.cmo + +eyes: eyes.cmo + $(CAMLC) $(COMPFLAGS) -o eyes $(LIBNAME).cma eyes.cmo + +calc: calc.cmo + $(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo + +clock: clock.cmo + $(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo + +clock.opt: clock.cmx + $(CAMLOPT) $(COMPFLAGS) -o clock.opt \ + $(LIBNAME).cmxa unix.cmxa clock.cmx + +tetris: tetris.cmo + $(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo + +lang: lang.cmo + $(CAMLC) $(COMPFLAGS) -o lang $(LIBNAME).cma lang.cmo + +clean: + rm -f hello demo eyes calc clock tetris lang *.opt *.o *.cm* + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmx .cmo .opt + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +.cmx.opt: + $(CAMLOPT) $(COMPFLAGS) -o $@ $(LIBNAME).cmxa $< diff --git a/otherlibs/labltk/examples_labltk/Makefile.nt b/otherlibs/labltk/examples_labltk/Makefile.nt new file mode 100644 index 000000000..fa58ea492 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/Makefile.nt @@ -0,0 +1,50 @@ +!include ..\support\Makefile.common.nt + +# We are using the non-installed library ! +COMPFLAGS= -I ../lib -I ../labltk -I ../support +LINKFLAGS= -I ../lib -I ../labltk -I ../support + +# Use pieces of Makefile.config +TKLINKOPT=$(LIBNAME).cma $(TKLIBS) + +all: hello.exe demo.exe eyes.exe calc.exe clock.exe tetris.exe lang.exe + +hello.exe: hello.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ hello.cmo + +demo.exe: demo.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ demo.cmo + +eyes.exe: eyes.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ eyes.cmo + +calc.exe: calc.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ calc.cmo + +clock.exe: clock.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) unix.cma \ + -o $@ clock.cmo + +tetris.exe: tetris.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ tetris.cmo + +lang.exe: lang.cmo + $(CAMLC) -custom $(LINKFLAGS) $(TKLINKOPT) \ + -o $@ lang.cmo + +clean : + rm -f *.cm? *.exe + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< diff --git a/otherlibs/labltk/examples_labltk/README b/otherlibs/labltk/examples_labltk/README new file mode 100644 index 000000000..ec0f20de6 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/README @@ -0,0 +1,20 @@ +$Id$ + +Some examples for LablTk. +They are written in classic mode, except testris.ml which uses label +commutation. +You may either compile them here, or just run them as scripts with + labltk example.ml + +hello.ml A very simple example of CamlTk +hello.tcl The same programme in Tcl/Tk + +demo.ml A demonstration using many widget classes + +eyes.ml A "bind" test + +calc.ml A little calculator + +clock.ml An analog clock (uses unix.cma) + +tetris.ml You NEED a game also (uses -labels) diff --git a/otherlibs/labltk/examples_labltk/calc.ml b/otherlibs/labltk/examples_labltk/calc.ml new file mode 100644 index 000000000..4f980bec0 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/calc.ml @@ -0,0 +1,129 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* A simple calculator demonstrating OO programming with O'Labl + and LablTk. + + LablTk itself is not OO, but it is good to wrap complex + structures in objects. Even if the absence of initializers + makes things a little bit awkward. +*) + +open StdLabels +open Tk + +let mem_string ~elt:c s = + try + for i = 0 to String.length s -1 do + if s.[i] = c then raise Exit + done; false + with Exit -> true + +let ops = ['+',(+.); '-',(-.); '*',( *.); '/',(/.)] + +(* The abstract calculator class. + Does not use Tk (only Textvariable) *) + +class calc () = object (calc) + val variable = Textvariable.create () + val mutable x = 0.0 + val mutable op = None + val mutable displaying = true + + method set = Textvariable.set variable + method get = Textvariable.get variable + method insert s = calc#set (calc#get ^ s) + method get_float = float_of_string (calc#get) + + method command s = + if s <> "" then match s.[0] with + '0'..'9' -> + if displaying then (calc#set ""; displaying <- false); + calc#insert s + | '.' -> + if displaying then + (calc#set "0."; displaying <- false) + else + if not (mem_string ~elt:'.' calc#get) then calc#insert s + | '+'|'-'|'*'|'/' as c -> + displaying <- true; + begin match op with + None -> + x <- calc#get_float; + op <- Some (List.assoc c ops) + | Some f -> + x <- f x (calc#get_float); + op <- Some (List.assoc c ops); + calc#set (string_of_float x) + end + | '='|'\n'|'\r' -> + displaying <- true; + begin match op with + None -> () + | Some f -> + x <- f x (calc#get_float); + op <- None; + calc#set (string_of_float x) + end + | 'q' -> closeTk (); exit 0 + | _ -> () +end + +(* Buttons for the calculator *) + +let m = + [|["7";"8";"9";"+"]; + ["4";"5";"6";"-"]; + ["1";"2";"3";"*"]; + ["0";".";"=";"/"]|] + +(* The physical calculator. Inherits from the abstract one *) + +class calculator ~parent = object + inherit calc () as calc + + val label = Label.create ~anchor:`E ~relief:`Sunken ~padx:10 parent + val frame = Frame.create parent + + initializer + let buttons = + Array.map ~f: + (List.map ~f: + (fun text -> + Button.create ~text ~command:(fun () -> calc#command text) frame)) + m + in + Label.configure ~textvariable:variable label; + calc#set "0"; + bind ~events:[`KeyPress] ~fields:[`Char] + ~action:(fun ev -> calc#command ev.ev_Char) + parent; + for i = 0 to Array.length m - 1 do + Grid.configure ~row:i buttons.(i) + done; + pack ~side:`Top ~fill:`X [label]; + pack ~side:`Bottom ~fill:`Both ~expand:true [frame]; +end + +(* Finally start everything *) + +let top = openTk () + +let applet = new calculator ~parent:top + +let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml new file mode 100644 index 000000000..57a59b825 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/clock.ml @@ -0,0 +1,133 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Clock/V, a simple clock. + Reverts every time you push the right button. + Adapted from ASCII/V May 1997 + + Uses Tk and Unix, so you must link with + labltklink unix.cma clock.ml -o clock -cclib -lunix +*) + +open Tk + +(* pi is not a constant! *) +let pi = acos (-1.) + +(* The main class: + * create it with a parent: [new clock parent:top] + * initialize with [#init] +*) + +class clock ~parent = object (self) + + (* Instance variables *) + val canvas = Canvas.create ~width:100 ~height:100 parent + val mutable height = 100 + val mutable width = 100 + val mutable rflag = -1 + + (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) + method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) + method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) + + initializer + (* Create the oval border *) + Canvas.create_oval canvas ~tags:["cadran"] + ~x1:1 ~y1:1 ~x2:(width - 2) ~y2:(height - 2) + ~width:3 ~outline:`Yellow ~fill:`White; + (* Draw the figures *) + self#draw_figures; + (* Create the arrows with dummy position *) + Canvas.create_line canvas + ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] + ~tags:["hours"] ~fill:`Red; + Canvas.create_line canvas + ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] + ~tags:["minutes"] ~fill:`Blue; + Canvas.create_line canvas + ~xys:[self#x 0., self#y 0.; self#x 0., self#y 0.] + ~tags:["seconds"] ~fill:`Black; + (* Setup a timer every second *) + let rec timer () = + self#draw_arrows (Unix.localtime (Unix.time ())); + Timer.add ~ms:1000 ~callback:timer; () + in timer (); + (* Redraw when configured (changes size) *) + bind canvas ~events:[`Configure] ~action: + begin fun _ -> + width <- Winfo.width canvas; + height <- Winfo.height canvas; + self#redraw + end; + (* Change direction with right button *) + bind canvas ~events:[`ButtonPressDetail 3] + ~action:(fun _ -> rflag <- -rflag; self#redraw); + (* Pack, expanding in both directions *) + pack ~fill:`Both ~expand:true [canvas] + + (* Redraw everything *) + method redraw = + Canvas.coords_set canvas (`Tag "cadran") + ~xys:[ 1, 1; width - 2, height - 2 ]; + self#draw_figures; + self#draw_arrows (Unix.localtime (Unix.time ())) + + (* Delete and redraw the figures *) + method draw_figures = + Canvas.delete canvas [`Tag "figures"]; + for i = 1 to 12 do + let angle = float (rflag * i - 3) *. pi /. 6. in + Canvas.create_text canvas + ~x:(self#x (0.8 *. cos angle)) ~y:(self#y (0.8 *. sin angle)) + ~tags:["figures"] + ~text:(string_of_int i) ~font:"variable" + ~anchor:`Center + done + + (* Resize and reposition the arrows *) + method draw_arrows tm = + Canvas.configure_line ~width:(min width height / 40) + canvas (`Tag "hours"); + let hangle = + float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) + *. pi /. 360. in + Canvas.coords_set canvas (`Tag "hours") + ~xys:[ self#x 0., self#y 0.; + self#x (cos hangle /. 2.), self#y (sin hangle /. 2.) ]; + Canvas.configure_line ~width:(min width height / 50) + canvas (`Tag "minutes"); + let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in + Canvas.coords_set canvas (`Tag "minutes") + ~xys:[ self#x 0., self#y 0.; + self#x (cos mangle /. 1.5), self#y (sin mangle /. 1.5) ]; + let sangle = float (rflag * tm.Unix.tm_sec - 15) *. pi /. 30. in + Canvas.coords_set canvas (`Tag "seconds") + ~xys:[ self#x 0., self#y 0.; + self#x (cos sangle /. 1.25), self#y (sin sangle /. 1.25) ] +end + +(* Initialize the Tcl interpreter *) +let top = openTk () + +(* Create a clock on the main window *) +let clock = + new clock ~parent:top + +(* Wait for events *) +let _ = mainLoop () diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml new file mode 100644 index 000000000..2ccc448b1 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/demo.ml @@ -0,0 +1,167 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Some CamlTk4 Demonstration by JPF *) + +(* First, open these modules for convenience *) +open StdLabels +open Tk + +(* Dummy let *) +let _ = + +(* Initialize Tk *) +let top = openTk () in +(* Title setting *) +Wm.title_set top "LablTk demo"; + +(* Base frame *) +let base = Frame.create top in +pack [base]; + +(* Menu bar *) +let bar = Frame.create ~borderwidth:2 ~relief:`Raised base in +pack ~fill:`X [bar]; + + (* Menu and Menubutton *) + let meb = Menubutton.create ~text:"Menu" bar in + let men = Menu.create meb in + Menu.add_command ~label:"Quit" ~command:(fun () -> closeTk (); exit 0) men; + Menubutton.configure ~menu:men meb; + + (* Frames *) + let base2 = Frame.create base in + let left = Frame.create base2 in + let right = Frame.create base2 in + pack [base2]; + pack ~side:`Left [left; right]; + + (* Widgets on left and right *) + + (* Button *) + let but = Button.create ~text:"Welcome to LablTk" left in + + (* Canvas *) + let can = + Canvas.create ~width:100 ~height:100 ~borderwidth:1 ~relief:`Sunken left + in + let oval = Canvas.create_oval ~x1: 10 ~y1: 10 + ~x2: 90 ~y2: 90 + ~fill: `Red + can + in ignore oval; + + (* Check button *) + let che = Checkbutton.create ~text:"Check" left in + + (* Entry *) + let ent = Entry.create ~width:10 left in + + (* Label *) + let lab = Label.create ~text:"Welcome to LablTk" left in + + (* Listbox *) + let lis = Listbox.create left in + Listbox.insert lis ~index:`End ~texts:["This"; "is"; "Listbox"]; + + (* Message *) + let mes = Message.create + ~text: "Hello this is a message widget with very long text, but ..." + left in + + (* Radio buttons *) + let tv = Textvariable.create () in + Textvariable.set tv "One"; + let radf = Frame.create right in + let rads = List.map + ~f:(fun t -> Radiobutton.create ~text:t ~value:t ~variable:tv radf) + ["One"; "Two"; "Three"] in + + (* Scale *) + let sca = Scale.create ~label:"Scale" ~length:100 ~showvalue:true right in + + (* Text and scrollbar *) + let texf = Frame.create right in + + (* Text *) + let tex = Text.create ~width:20 ~height:8 texf in + Text.insert ~index:(`End,[]) ~text:"This is a text widget." tex; + + (* Scrollbar *) + let scr = Scrollbar.create texf in + + (* Text and Scrollbar widget link *) + let scroll_link sb tx = + Text.configure ~yscrollcommand:(Scrollbar.set sb) tx; + Scrollbar.configure ~command:(Text.yview tx) sb in + scroll_link scr tex; + + pack ~side:`Right ~fill:`Y [scr]; + pack ~side:`Left ~fill:`Both ~expand:true [tex]; + + (* Pack them *) + pack ~side:`Left [meb]; + pack [coe but; coe can; coe che; coe ent; coe lab; coe lis; coe mes]; + pack [coe radf; coe sca; coe texf]; + pack rads; + + (* Toplevel *) + let top2 = Toplevel.create top in + Wm.title_set top2 "LablTk demo control"; + let defcol = `Color "#dfdfdf" in + let selcol = `Color "#ffdfdf" in + let buttons = + List.map ~f:(fun (w, t, c, a) -> + let b = Button.create ~text:t ~command:c top2 in + bind ~events:[`Enter] ~action:(fun _ -> a selcol) b; + bind ~events:[`Leave] ~action:(fun _ -> a defcol) b; + b) + [coe bar, "Frame", (fun () -> ()), + (fun background -> Frame.configure ~background bar); + coe meb, "Menubutton", (fun () -> ()), + (fun background -> Menubutton.configure ~background meb); + coe but, "Button", (fun () -> ()), + (fun background -> Button.configure ~background but); + coe can, "Canvas", (fun () -> ()), + (fun background -> Canvas.configure ~background can); + coe che, "CheckButton", (fun () -> ()), + (fun background -> Checkbutton.configure ~background che); + coe ent, "Entry", (fun () -> ()), + (fun background -> Entry.configure ~background ent); + coe lab, "Label", (fun () -> ()), + (fun background -> Label.configure ~background lab); + coe lis, "Listbox", (fun () -> ()), + (fun background -> Listbox.configure ~background lis); + coe mes, "Message", (fun () -> ()), + (fun background -> Message.configure ~background mes); + coe radf, "Radiobox", (fun () -> ()), + (fun background -> + List.iter ~f:(fun b -> Radiobutton.configure ~background b) rads); + coe sca, "Scale", (fun () -> ()), + (fun background -> Scale.configure ~background sca); + coe tex, "Text", (fun () -> ()), + (fun background -> Text.configure ~background tex); + coe scr, "Scrollbar", (fun () -> ()), + (fun background -> Scrollbar.configure ~background scr) + ] + in + pack ~fill:`X buttons; + +(* Main Loop *) +Printexc.print mainLoop () + diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml new file mode 100644 index 000000000..ce62159db --- /dev/null +++ b/otherlibs/labltk/examples_labltk/eyes.ml @@ -0,0 +1,65 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Tk + +let _ = + let top = openTk () in + let fw = Frame.create top in + pack [fw]; + let c = Canvas.create ~width: 200 ~height: 200 fw in + let create_eye cx cy wx wy ewx ewy bnd = + let o2 = Canvas.create_oval + ~x1:(cx - wx) ~y1:(cy - wy) + ~x2:(cx + wx) ~y2:(cy + wy) + ~outline: `Black ~width: 7 + ~fill: `White + c + and o = Canvas.create_oval + ~x1:(cx - ewx) ~y1:(cy - ewy) + ~x2:(cx + ewx) ~y2:(cy + ewy) + ~fill:`Black + c in + let curx = ref cx + and cury = ref cy in + bind ~events:[`Motion] ~extend:true ~fields:[`MouseX; `MouseY] + ~action:(fun e -> + let nx, ny = + let xdiff = e.ev_MouseX - cx + and ydiff = e.ev_MouseY - cy in + let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. + (float ydiff /. (float wy *. bnd)) ** 2.0) in + if diff > 1.0 then + truncate ((float xdiff) *. (1.0 /. diff)) + cx, + truncate ((float ydiff) *. (1.0 /. diff)) + cy + else + e.ev_MouseX, e.ev_MouseY + in + Canvas.move c o ~x: (nx - !curx) ~y: (ny - !cury); + curx := nx; + cury := ny) + c + in + create_eye 60 100 30 40 5 6 0.6; + create_eye 140 100 30 40 5 6 0.6; + pack [c] + +let _ = Printexc.print mainLoop () + + + diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml new file mode 100644 index 000000000..4a89d4806 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/hello.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* LablTk4 Demonstration by JPF *) + +(* First, open this modules for convenience *) +open Tk + +(* initialization of Tk --- the result is a toplevel widget *) +let top = openTk () + +(* create a button on top *) +(* Button.create : use of create function defined in button.ml *) +(* But you shouldn't open Button module for other widget class modules use *) +let b = Button.create ~text: "Hello, LablTk!" top + +(* Lack of toplevel expressions in lsl, you must use dummy let exp. *) +let _ = pack [coe b] + +(* Last, you must call mainLoop *) +(* You can write just let _ = mainLoop () *) +(* But Printexc.print will help you *) +let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/hello.tcl b/otherlibs/labltk/examples_labltk/hello.tcl new file mode 100755 index 000000000..9e9985c15 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/hello.tcl @@ -0,0 +1,5 @@ +#!/usr/local/bin/wish4.0 + +button .hello -text "Hello, TclTk!" + +pack .hello diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml new file mode 100644 index 000000000..53d2d5e51 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/lang.ml @@ -0,0 +1,75 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* language encoding using UTF-8 *) +open Tk + +let top = opentk () + +(* declare Tk that we use utf-8 to communicate *) +(* problem: Text display is highly dependent on your font installation + and configulation. The fonts with no-scale setting are selected + only if the point sizes are exactly same??? +*) +let _ = + Encoding.system_set "utf-8"; + let l = Label.create top ~text: "???" in + pack [l]; + let t = Text.create top in + pack [t]; + + let create_hello lang hello = + let b = Button.create t ~text: lang ~command: (fun () -> + Label.configure l ~text: hello) + in + Text.window_create t ~index: (`End,[]) ~window: b + in + List.iter (fun (lang, hello) -> create_hello lang hello) + ["Amharic(አማርኛ)", "ሠላም"; + "Arabic", "�����������"; + "Croatian (Hrvatski)", "Bog (Bok), Dobar dan"; + "Czech (česky)", "Dobrý den"; + "Danish (Dansk)", "Hej, Goddag"; + "English", "Hello"; + "Esperanto", "Saluton"; + "Estonian", "Tere, Tervist"; + "FORTRAN", "PROGRAM"; + "Finnish (Suomi)", "Hei"; + "French (Français)", "Bonjour, Salut"; + "German (Deutsch Nord)", "Guten Tag"; + "German (Deutsch Süd)", "Grüß Gott"; + "Greek (Ελληνικά)", "Γειά σας"; + "Hebrew", "שלום"; + "Italiano", "Ciao, Buon giorno"; + "Maltese", "Ciao"; + "Nederlands, Vlaams", "Hallo, Hoi, Goedendag"; + "Norwegian (Norsk)", "Hei, God dag"; + "Polish", "Cześć!"; + "Russian (Русский)", "Здравствуйте!"; + "Slovak", "Dobrý deň"; + "Spanish (Español)", "¡Hola!"; + "Swedish (Svenska)", "Hej, Goddag"; + "Thai (�������)", "�������, ������"; + "Tigrigna (ትግርኛ)", "ሰላማት"; + "Turkish (Türkçe)", "Merhaba"; + "Vietnamese (Tiếng Việt)", "Chào bạn"; + "Japanese (日本語)", "こんにちは"; + "Chinese (中文,普通话,汉语)", "你好"; + "Cantonese (粵語,廣東話)", "早晨, 你好"; + "Hangul (한글)", "안녕하세요, 안녕하십니까" ] +;; + +let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml new file mode 100644 index 000000000..a3bcbb1bf --- /dev/null +++ b/otherlibs/labltk/examples_labltk/taquin.ml @@ -0,0 +1,143 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Tk;; + +let d�coupe_image img nx ny = + let l = Imagephoto.width img + and h = Imagephoto.height img in + let tx = l / nx and ty = h / ny in + let pi�ces = ref [] in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + let pi�ce = Imagephoto.create ~width:tx ~height:ty () in + Imagephoto.copy ~src:img + ~src_area:(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty) pi�ce; + pi�ces := pi�ce :: !pi�ces + done + done; + (tx, ty, List.tl !pi�ces);; + +let remplir_taquin c nx ny tx ty pi�ces = + let trou_x = ref (nx - 1) + and trou_y = ref (ny - 1) in + let trou = + Canvas.create_rectangle + ~x1:(!trou_x * tx) ~y1:(!trou_y * ty) ~x2:tx ~y2:ty c in + let taquin = Array.make_matrix nx ny trou in + let p = ref pi�ces in + for x = 0 to nx - 1 do + for y = 0 to ny - 1 do + match !p with + | [] -> () + | pi�ce :: reste -> + taquin.(x).(y) <- + Canvas.create_image + ~x:(x * tx) ~y:(y * ty) + ~image:pi�ce ~anchor:`Nw ~tags:["pi�ce"] c; + p := reste + done + done; + let d�placer x y = + let pi�ce = taquin.(x).(y) in + Canvas.coords_set c pi�ce + ~xys:[!trou_x * tx, !trou_y * ty]; + Canvas.coords_set c trou + ~xys:[x * tx, y * ty; tx, ty]; + taquin.(!trou_x).(!trou_y) <- pi�ce; + taquin.(x).(y) <- trou; + trou_x := x; trou_y := y in + let jouer ei = + let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in + if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1) + || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1) + then d�placer x y in + Canvas.bind ~events:[`ButtonPress] + ~fields:[`MouseX; `MouseY] ~action:jouer c (`Tag "pi�ce");; + +let rec permutation = function + | [] -> [] + | l -> let n = Random.int (List.length l) in + let (�l�ment, reste) = partage l n in + �l�ment :: permutation reste + +and partage l n = + match l with + | [] -> failwith "partage" + | t�te :: reste -> + if n = 0 then (t�te, reste) else + let (�l�ment, reste') = partage reste (n - 1) in + (�l�ment, t�te :: reste');; + +let create_filled_text parent lines = + let lnum = List.length lines + and lwidth = + List.fold_right + (fun line max -> + let l = String.length line in + if l > max then l else max) + lines 1 in + let txtw = Text.create ~width:lwidth ~height:lnum parent in + List.iter + (fun line -> + Text.insert ~index:(`End, []) ~text:line txtw; + Text.insert ~index:(`End, []) ~text:"\n" txtw) + lines; + txtw;; + +let give_help parent lines () = + let help_window = Toplevel.create parent in + Wm.title_set help_window "Help"; + + let help_frame = Frame.create help_window in + + let help_txtw = create_filled_text help_frame lines in + + let quit_help () = destroy help_window in + let ok_button = Button.create ~text:"Ok" ~command:quit_help help_frame in + + pack ~side:`Bottom [help_txtw]; + pack ~side:`Bottom [ok_button ]; + pack [help_frame];; + +let taquin nom_fichier nx ny = + let fp = openTk () in + Wm.title_set fp "Taquin"; + let img = Imagephoto.create ~file:nom_fichier () in + let c = + Canvas.create ~background:`Black + ~width:(Imagephoto.width img) + ~height:(Imagephoto.height img) fp in + let (tx, ty, pi�ces) = d�coupe_image img nx ny in + remplir_taquin c nx ny tx ty (permutation pi�ces); + pack [c]; + + let quit = Button.create ~text:"Quit" ~command:closeTk fp in + let help_lines = + ["Pour jouer, cliquer sur une des pi�ces"; + "entourant le trou"; + ""; + "To play, click on a part around the hole"] in + let help = + Button.create ~text:"Help" ~command:(give_help fp help_lines) fp in + pack ~side:`Left ~fill:`X [quit] ; + pack ~side:`Left ~fill:`X [help] ; + mainLoop ();; + +if !Sys.interactive then () else +begin taquin "Lambda2.back.gif" 4 4; exit 0 end;; diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml new file mode 100644 index 000000000..3e3f1e8a4 --- /dev/null +++ b/otherlibs/labltk/examples_labltk/tetris.ml @@ -0,0 +1,710 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* A Tetris game for LablTk *) +(* written by Jun P. Furuse *) + +open StdLabels +open Tk + +exception Done + +type falling_block = { + mutable pattern: int array list; + mutable bcolor: int; + mutable x: int; + mutable y: int; + mutable d: int; + mutable alive: bool + } + +let stop_a_bit = 300 + +let field_width = 10 +let field_height = 20 + +let colors = [| + `Color "red"; + `Color "yellow"; + + `Color "blue"; + `Color "orange"; + + `Color "magenta"; + `Color "green"; + + `Color "cyan" +|] + +(* Put here your favorite image files *) +let backgrounds = [ + "Lambda2.back.gif" +] + +(* blocks *) +let block_size = 16 +let cell_border = 2 + +let blocks = [ + [ [|"0000"; + "0000"; + "1111"; + "0000" |]; + + [|"0010"; + "0010"; + "0010"; + "0010" |]; + + [|"0000"; + "0000"; + "1111"; + "0000" |]; + + [|"0010"; + "0010"; + "0010"; + "0010" |] ]; + + [ [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |]; + + [|"0000"; + "0110"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "0111"; + "0100"; + "0000" |]; + + [|"0000"; + "0110"; + "0010"; + "0010" |]; + + [|"0000"; + "0010"; + "1110"; + "0000" |]; + + [|"0100"; + "0100"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "0100"; + "0111"; + "0000" |]; + + [|"0000"; + "0110"; + "0100"; + "0100" |]; + + [|"0000"; + "1110"; + "0010"; + "0000" |]; + + [|"0010"; + "0010"; + "0110"; + "0000" |] ]; + + [ [|"0000"; + "1100"; + "0110"; + "0000" |]; + + [|"0010"; + "0110"; + "0100"; + "0000" |]; + + [|"0000"; + "1100"; + "0110"; + "0000" |]; + + [|"0010"; + "0110"; + "0100"; + "0000" |] ]; + + [ [|"0000"; + "0011"; + "0110"; + "0000" |]; + + [|"0100"; + "0110"; + "0010"; + "0000" |]; + + [|"0000"; + "0011"; + "0110"; + "0000" |]; + + [|"0000"; + "0100"; + "0110"; + "0010" |] ]; + + [ [|"0000"; + "0000"; + "1110"; + "0100" |]; + + [|"0000"; + "0100"; + "1100"; + "0100" |]; + + [|"0000"; + "0100"; + "1110"; + "0000" |]; + + [|"0000"; + "0100"; + "0110"; + "0100" |] ] + +] + +let line_empty = int_of_string "0b1110000000000111" +let line_full = int_of_string "0b1111111111111111" + +let decode_block dvec = + let btoi d = int_of_string ("0b"^d) in + Array.map ~f:btoi dvec + +class cell t1 t2 t3 ~canvas ~x ~y = object + val mutable color = 0 + method get = color + method set ~color:col = + if color = col then () else + if color <> 0 && col = 0 then begin + Canvas.move canvas t1 + ~x:(- block_size * (x + 1) -10 - cell_border * 2) + ~y:(- block_size * (y + 1) -10 - cell_border * 2); + Canvas.move canvas t2 + ~x:(- block_size * (x + 1) -10 - cell_border * 2) + ~y:(- block_size * (y + 1) -10 - cell_border * 2); + Canvas.move canvas t3 + ~x:(- block_size * (x + 1) -10 - cell_border * 2) + ~y:(- block_size * (y + 1) -10 - cell_border * 2) + end else begin + Canvas.configure_rectangle canvas t2 + ~fill: colors.(col - 1) + ~outline: colors.(col - 1); + Canvas.configure_rectangle canvas t1 + ~fill: `Black + ~outline: `Black; + Canvas.configure_rectangle canvas t3 + ~fill: (`Color "light gray") + ~outline: (`Color "light gray"); + if color = 0 && col <> 0 then begin + Canvas.move canvas t1 + ~x: (block_size * (x+1)+10+ cell_border*2) + ~y: (block_size * (y+1)+10+ cell_border*2); + Canvas.move canvas t2 + ~x: (block_size * (x+1)+10+ cell_border*2) + ~y: (block_size * (y+1)+10+ cell_border*2); + Canvas.move canvas t3 + ~x: (block_size * (x+1)+10+ cell_border*2) + ~y: (block_size * (y+1)+10+ cell_border*2) + end + end; + color <- col +end + +let cell_get (c, cf) x y = cf.(y).(x) #get + +let cell_set (c, cf) ~x ~y ~color = + if x >= 0 && y >= 0 && Array.length cf > y && Array.length cf.(y) > x then + let cur = cf.(y).(x) in + if cur#get = color then () else cur#set ~color + +let create_base_matrix ~cols ~rows = + let m = Array.create_matrix ~dimx:rows ~dimy:cols (0,0) in + for x = 0 to cols - 1 do for y = 0 to rows - 1 do + m.(y).(x) <- (x,y) + done done; + m + +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: 2 in + let c = Canvas.create f ~width: (block_size * 10) + ~height: (block_size * 20) + ~borderwidth: cell_border + ~relief: `Sunken + ~background: `Black + and r = Frame.create f + and r' = Frame.create f in + + let nl = Label.create r ~text: "Next" ~font: "variable" in + let nc = Canvas.create r ~width: (block_size * 4) + ~height: (block_size * 4) + ~borderwidth: cell_border + ~relief: `Sunken + ~background: `Black in + let scl = Label.create r ~text: "Score" ~font: "variable" in + let sc = Label.create r ~textvariable: scorev ~font: "variable" in + let lnl = Label.create r ~text: "Lines" ~font: "variable" in + let ln = Label.create r ~textvariable: linev ~font: "variable" in + let levl = Label.create r ~text: "Level" ~font: "variable" in + let lev = Label.create r ~textvariable: levv ~font: "variable" in + let newg = Button.create r ~text: "New Game" ~font: "variable" in + + pack [f]; + pack [coe c; coe r; coe r'] ~side: `Left ~fill: `Y; + pack [coe nl; coe nc] ~side: `Top; + pack [coe scl; coe sc; coe lnl; coe ln; coe levl; coe lev; coe newg] + ~side: `Top; + + let cells_src = create_base_matrix ~cols:field_width ~rows:field_height in + let cells = + Array.map cells_src ~f: + (Array.map ~f: + begin fun (x,y) -> + let t1 = + Canvas.create_rectangle c + ~x1:(-block_size - 8) ~y1:(-block_size - 8) + ~x2:(-9) ~y2:(-9) + and t2 = + Canvas.create_rectangle c + ~x1:(-block_size - 10) ~y1:(-block_size - 10) + ~x2:(-11) ~y2:(-11) + and t3 = + Canvas.create_rectangle c + ~x1:(-block_size - 12) ~y1:(-block_size - 12) + ~x2:(-13) ~y2:(-13) + in + Canvas.raise c t1; + Canvas.raise c t2; + Canvas.lower c t3; + new cell ~canvas:c ~x ~y t1 t2 t3 + end) + in + let nexts_src = create_base_matrix ~cols:4 ~rows:4 in + let nexts = + Array.map nexts_src ~f: + (Array.map ~f: + begin fun (x,y) -> + let t1 = + Canvas.create_rectangle nc + ~x1:(-block_size - 8) ~y1:(-block_size - 8) + ~x2:(-9) ~y2:(-9) + and t2 = + Canvas.create_rectangle nc + ~x1:(-block_size - 10) ~y1:(-block_size - 10) + ~x2:(-11) ~y2:(-11) + and t3 = + Canvas.create_rectangle nc + ~x1:(-block_size - 12) ~y1:(-block_size - 12) + ~x2:(-13) ~y2:(-13) + in + Canvas.raise nc t1; + Canvas.raise nc t2; + Canvas.lower nc t3; + new cell ~canvas:nc ~x ~y t1 t2 t3 + end) + in + let game_over () = () + in + (* What a mess ! *) + [ coe f; coe c; coe r; coe nl; coe nc; coe scl; coe sc; coe levl; coe lev; + coe lnl; coe ln ], + newg, (c, cells), (nc, nexts), scorev, linev, levv, game_over + + +let draw_block field ~color ~block ~x ~y = + for iy = 0 to 3 do + let base = ref 1 in + let xd = block.(iy) in + for ix = 0 to 3 do + if xd land !base <> 0 then + cell_set field ~x:(ix + x) ~y:(iy + y) ~color; + base := !base lsl 1 + done + done + +let timer_ref = (ref None : Timer.t option ref) +(* I know, this should be timer ref, but I'm not sure what should be + the initial value ... *) + +let remove_timer () = + match !timer_ref with + None -> () + | Some t -> Timer.remove t (* ; prerr_endline "removed!" *) + +let do_after ~ms ~callback = + timer_ref := Some (Timer.add ~ms ~callback) + +let copy_block c = + { pattern= !c.pattern; + bcolor= !c.bcolor; + x= !c.x; + y= !c.y; + d= !c.d; + alive= !c.alive } + +let _ = + let top = openTk () in + let lb = Label.create top + and fw = Frame.create top + in + let set_message s = Label.configure lb ~text:s in + pack [coe lb; coe fw] ~side: `Top; + let score = ref 0 in + let line = ref 0 in + let level = ref 0 in + let time = ref 1000 in + let blocks = List.map ~f:(List.map ~f:decode_block) blocks in + let field = Array.create 26 0 in + let widgets, button, cell_field, next_field, scorev, linev, levv, game_over + = init fw in + let canvas = fst cell_field in + + let init_field () = + for i = 0 to 25 do + field.(i) <- line_empty + done; + field.(23) <- line_full; + for i = 0 to 19 do + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:i ~color:0 + done + done; + for i = 0 to 3 do + for j = 0 to 3 do + cell_set next_field ~x:j ~y:i ~color:0 + done + done + in + + let draw_falling_block fb = + draw_block cell_field ~color: fb.bcolor + ~block: (List.nth fb.pattern fb.d) + ~x: (fb.x - 3) + ~y: (fb.y - 3) + + and erase_falling_block fb = + draw_block cell_field ~color: 0 + ~block: (List.nth fb.pattern fb.d) + ~x: (fb.x - 3) + ~y: (fb.y - 3) + in + + let stone fb = + for i=0 to 3 do + let cur = field.(i + fb.y) in + field.(i + fb.y) <- + cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x) + done; + for i=0 to 2 do + field.(i) <- line_empty + done + + and clear fb = + let l = ref 0 in + for i = 0 to 3 do + if i + fb.y >= 3 && i + fb.y <= 22 then + if field.(i + fb.y) = line_full then + begin + incr l; + field.(i + fb.y) <- line_empty; + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:(i + fb.y - 3) ~color:0 + done + end + done; + !l + + and fall_lines () = + let eye = ref 22 (* bottom *) + and cur = ref 22 (* bottom *) + in + try + while !eye >= 3 do + while field.(!eye) = line_empty do + decr eye; + if !eye = 2 then raise Done + done; + field.(!cur) <- field.(!eye); + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:(!cur-3) + ~color:(cell_get cell_field j (!eye-3)) + done; + decr eye; + decr cur + done + with Done -> (); + for i = 3 to !cur do + field.(i) <- line_empty; + for j = 0 to 9 do + cell_set cell_field ~x:j ~y:(i-3) ~color:0 + done + done + in + + let next = ref 42 (* THE ANSWER *) + and current = + ref { pattern= [[|0;0;0;0|]]; bcolor=0; x=0; y=0; d=0; alive= false} + in + + let draw_next () = + draw_block next_field ~color: (!next+1) + ~block: (List.hd (List.nth blocks !next)) + ~x: 0 ~y: 0 + + and erase_next () = + draw_block next_field ~color: 0 + ~block: (List.hd (List.nth blocks !next)) + ~x: 0 ~y: 0 + in + + let set_nextblock () = + current := + { pattern= (List.nth blocks !next); + bcolor= !next+1; + x=6; y= 1; d= 0; alive= true}; + erase_next (); + next := Random.int 7; + draw_next () + in + + let death_check fb = + try + for i=0 to 3 do + let cur = field.(i + fb.y) in + if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0 + then raise Done + done; + false + with + Done -> true + in + + let try_to_move m = + if !current.alive then + let sub m = + if death_check m then false + else + begin + erase_falling_block !current; + draw_falling_block m; + current := m; + true + end + in + if sub m then true + else + begin + m.x <- m.x + 1; + if sub m then true + else + begin + m.x <- m.x - 2; + sub m + end + end + else false + in + + let image_load = + let i = Canvas.create_image canvas + ~x: (block_size * 5 + block_size / 2) + ~y: (block_size * 10 + block_size / 2) + ~anchor: `Center in + Canvas.lower canvas i; + let img = Imagephoto.create () in + fun file -> + try + Imagephoto.configure img ~file: file; + Canvas.configure_image canvas i ~image: img + with + _ -> + begin + Printf.eprintf "%s : No such image...\n" file; + flush stderr + end + in + + let add_score l = + let pline = !line in + if l <> 0 then + begin + line := !line + l; + score := !score + l * l; + set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2))) + end; + Textvariable.set linev (string_of_int !line); + Textvariable.set scorev (string_of_int !score); + + if !line /10 <> pline /10 then + (* update the background every 10 lines. *) + begin + let num_image = List.length backgrounds - 1 in + let n = !line/10 in + let n = if n > num_image then num_image else n in + let file = List.nth backgrounds n in + image_load file; + incr level; + Textvariable.set levv (string_of_int !level) + end + in + + let rec newblock () = + set_message "TETRIS"; + set_nextblock (); + draw_falling_block !current; + if death_check !current then + begin + !current.alive <- false; + set_message "GAME OVER"; + game_over () + end + else + begin + time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200); + if !time < 60 - !level * 3 then time := 60 - !level * 3; + do_after ~ms:stop_a_bit ~callback:loop + end + + and loop () = + let m = copy_block current in + m.y <- m.y + 1; + if death_check m then + begin + !current.alive <- false; + stone !current; + do_after ~ms:stop_a_bit ~callback: + begin fun () -> + let l = clear !current in + if l > 0 then + do_after ~ms:stop_a_bit ~callback: + begin fun () -> + fall_lines (); + add_score l; + do_after ~ms:stop_a_bit ~callback:newblock + end + else + newblock () + end + end + else + begin + erase_falling_block !current; + draw_falling_block m; + current := m; + do_after ~ms:!time ~callback:loop + end + in + + let bind_game w = + bind w ~events:[`KeyPress] ~fields:[`KeySymString] ~action: + begin fun e -> + match e.ev_KeySymString with + | "h" -> + let m = copy_block current in + m.x <- m.x - 1; + ignore (try_to_move m) + | "j" -> + let m = copy_block current in + m.d <- m.d + 1; + if m.d = List.length m.pattern then m.d <- 0; + ignore (try_to_move m) + | "k" -> + let m = copy_block current in + m.d <- m.d - 1; + if m.d < 0 then m.d <- List.length m.pattern - 1; + ignore (try_to_move m) + | "l" -> + let m = copy_block current in + m.x <- m.x + 1; + ignore (try_to_move m) + | "m" -> + remove_timer (); + loop () + | "space" -> + if !current.alive then + begin + let m = copy_block current + and n = copy_block current in + while + m.y <- m.y + 1; + if death_check m then false + else begin n.y <- m.y; true end + do () done; + erase_falling_block !current; + draw_falling_block n; + current := n; + remove_timer (); + loop () + end + | _ -> () + end + in + + let game_init () = + (* Game Initialization *) + set_message "Initializing ..."; + remove_timer (); + image_load (List.hd backgrounds); + time := 1000; + score := 0; + line := 0; + level := 1; + add_score 0; + init_field (); + next := Random.int 7; + set_message "Welcome to TETRIS"; + set_nextblock (); + draw_falling_block !current; + do_after ~ms:!time ~callback:loop + in + (* As an applet, it was required... *) + (* List.iter f: bind_game widgets; *) + bind_game top; + Button.configure button ~command: game_init; + game_init () + +let _ = Printexc.print mainLoop () diff --git a/otherlibs/labltk/frx/.depend b/otherlibs/labltk/frx/.depend new file mode 100644 index 000000000..d815ab0eb --- /dev/null +++ b/otherlibs/labltk/frx/.depend @@ -0,0 +1,38 @@ +frx_after.cmo: frx_after.cmi +frx_after.cmx: frx_after.cmi +frx_color.cmo: frx_color.cmi +frx_color.cmx: frx_color.cmi +frx_ctext.cmo: frx_fit.cmi frx_text.cmi frx_ctext.cmi +frx_ctext.cmx: frx_fit.cmx frx_text.cmx frx_ctext.cmi +frx_dialog.cmo: frx_dialog.cmi +frx_dialog.cmx: frx_dialog.cmi +frx_entry.cmo: frx_entry.cmi +frx_entry.cmx: frx_entry.cmi +frx_fillbox.cmo: frx_fillbox.cmi +frx_fillbox.cmx: frx_fillbox.cmi +frx_fit.cmo: frx_after.cmi frx_fit.cmi +frx_fit.cmx: frx_after.cmx frx_fit.cmi +frx_focus.cmo: frx_focus.cmi +frx_focus.cmx: frx_focus.cmi +frx_font.cmo: frx_misc.cmi frx_font.cmi +frx_font.cmx: frx_misc.cmx frx_font.cmi +frx_lbutton.cmo: frx_lbutton.cmi +frx_lbutton.cmx: frx_lbutton.cmi +frx_listbox.cmo: frx_listbox.cmi +frx_listbox.cmx: frx_listbox.cmi +frx_mem.cmo: frx_mem.cmi +frx_mem.cmx: frx_mem.cmi +frx_misc.cmo: frx_misc.cmi +frx_misc.cmx: frx_misc.cmi +frx_req.cmo: frx_entry.cmi frx_listbox.cmi frx_widget.cmi frx_req.cmi +frx_req.cmx: frx_entry.cmx frx_listbox.cmx frx_widget.cmx frx_req.cmi +frx_rpc.cmo: frx_rpc.cmi +frx_rpc.cmx: frx_rpc.cmi +frx_selection.cmo: frx_selection.cmi +frx_selection.cmx: frx_selection.cmi +frx_synth.cmo: frx_synth.cmi +frx_synth.cmx: frx_synth.cmi +frx_text.cmo: frx_misc.cmi frx_text.cmi +frx_text.cmx: frx_misc.cmx frx_text.cmi +frx_widget.cmo: frx_widget.cmi +frx_widget.cmx: frx_widget.cmi diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile new file mode 100644 index 000000000..226ba129f --- /dev/null +++ b/otherlibs/labltk/frx/Makefile @@ -0,0 +1,51 @@ +include ../support/Makefile.common + +COMPFLAGS=-I ../camltk -I ../support -I $(OTHERS)/unix + +OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ + frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ + frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ + frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo + +OBJSX = $(OBJS:.cmo=.cmx) + +all: frxlib.cma + +opt: frxlib.cmxa + +frxlib.cma: $(OBJS) + $(CAMLLIBR) -o frxlib.cma $(OBJS) + +frxlib.cmxa: $(OBJSX) + $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX) + +install: frxlib.cma + cp *.cmi *.mli frxlib.cma $(INSTALLDIR) + +installopt: frxlib.cmxa + cp frxlib.cmxa frxlib.a $(INSTALLDIR) + +clean: + rm -f *.cm* *.o *.a + +$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma + +$(OBJSX): ../lib/$(LIBNAME).cmxa + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo .cmx + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + + +depend: + $(CAMLDEP) *.mli *.ml > .depend + +include .depend diff --git a/otherlibs/labltk/frx/Makefile.nt b/otherlibs/labltk/frx/Makefile.nt new file mode 100644 index 000000000..bf624ee16 --- /dev/null +++ b/otherlibs/labltk/frx/Makefile.nt @@ -0,0 +1,53 @@ +!include ..\support\Makefile.common.nt + +COMPFLAGS=-I ../camltk -I ../support + +OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ + frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ + frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ + frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo + +OBJSX = $(OBJS:.cmo=.cmx) + +all: libfrx.cma + +opt: libfrx.cmxa + +libfrx.cma: $(OBJS) + $(CAMLLIBR) -o libfrx.cma $(OBJS) + +libfrx.cmxa: $(OBJSX) + $(CAMLOPTLIBR) -o libfrx.cmxa $(OBJSX) + + +install: libfrx.cma + cp *.cmi *.mli libfrx.cma $(INSTALLDIR) + +installopt: libfrx.cmxa + cp libfrx.cmxa libfrx.lib $(INSTALLDIR) + + +clean: + rm -f *.cm* *.obj *.a *~ *test *.lib + +$(OBJS) $(OBJS:.cmo=.cmi): ..\lib\$(LIBNAME).cma + +$(OBJSX): ..\lib\$(LIBNAME).cmxa + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo .cmx + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + + +depend: + $(CAMLDEP) *.mli *.ml > .depend + +!include .depend diff --git a/otherlibs/labltk/frx/README b/otherlibs/labltk/frx/README new file mode 100644 index 000000000..b86f8dcd8 --- /dev/null +++ b/otherlibs/labltk/frx/README @@ -0,0 +1,2 @@ +This is Francois Rouaix's widget set library, Frx. +It uses CamlTk API.
\ No newline at end of file diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml new file mode 100644 index 000000000..955f1cb48 --- /dev/null +++ b/otherlibs/labltk/frx/frx_after.ml @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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 Protocol +let idle f = + let id = new_function_id () in + let wrapped _ = + clear_callback id; (* do it first in case f raises exception *) + f() in + Hashtbl.add callback_naming_table id wrapped; + tkCommand [| TkToken "after"; TkToken "idle"; + TkToken ("camlcb "^ string_of_cbid id) |] diff --git a/otherlibs/labltk/frx/frx_after.mli b/otherlibs/labltk/frx/frx_after.mli new file mode 100644 index 000000000..73c07f7bb --- /dev/null +++ b/otherlibs/labltk/frx/frx_after.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val idle : (unit -> unit) -> unit + (* [idle f] is equivalent to Tk "after idle {camlcb f}" *) diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml new file mode 100644 index 000000000..4df3eb6b4 --- /dev/null +++ b/otherlibs/labltk/frx/frx_color.ml @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* 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 Protocol + +module StringSet = Set.Make(struct type t = string let compare = compare end) + +(* should we keep a negative cache ? *) +let available_colors = ref (StringSet.empty) + +let check s = + if StringSet.mem s !available_colors then true + else begin + try + let f = Frame.create_named Widget.default_toplevel "frxcolorcheck" + [Background (NamedColor s)] in + available_colors := StringSet.add s !available_colors; + destroy f; + true + with + TkError _ -> false + end diff --git a/otherlibs/labltk/frx/frx_color.mli b/otherlibs/labltk/frx/frx_color.mli new file mode 100644 index 000000000..513cb0839 --- /dev/null +++ b/otherlibs/labltk/frx/frx_color.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val check : string -> bool diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml new file mode 100644 index 000000000..01ede5457 --- /dev/null +++ b/otherlibs/labltk/frx/frx_ctext.ml @@ -0,0 +1,66 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* A trick by Steve Ball to do pixel scrolling on text widgets *) +(* USES frx_fit *) +open Camltk + +let create top opts navigation = + let f = Frame.create top [BorderWidth (Pixels 2); Relief Raised] in + let lf = Frame.create f [] in + let rf = Frame.create f [] in + let c = Canvas.create lf [BorderWidth (Pixels 0)] + and xscroll = Scrollbar.create lf [Orient Horizontal] + and yscroll = Scrollbar.create rf [Orient Vertical] + and secret = Frame.create_named rf "secret" [] + in + let t = Text.create c (BorderWidth(Pixels 0) :: opts) in + if navigation then Frx_text.navigation_keys t; + + (* Make the text widget an embedded canvas object *) + ignore + (Canvas.create_window c (Pixels 0) (Pixels 0) + [Anchor NW; Window t; Tags [Tag "main"]]); + Canvas.focus c (Tag "main"); + (* + Canvas.configure c [Width (Pixels (Winfo.reqwidth t)); + Height(Pixels (Winfo.reqheight t))]; + *) + Canvas.configure c [YScrollCommand (Scrollbar.set yscroll)]; + (* The horizontal scrollbar is directly attached to the + * text widget, because h scrolling works properly *) + Scrollbar.configure xscroll [ScrollCommand (Text.xview t)]; + (* But vertical scroll is attached to the canvas *) + Scrollbar.configure yscroll [ScrollCommand (Canvas.yview c)]; + let scroll, check = Frx_fit.vert t in + Text.configure t [ + XScrollCommand (Scrollbar.set xscroll); + YScrollCommand (fun first last -> + scroll first last; + let x,y,w,h = Canvas.bbox c [Tag "main"] in + Canvas.configure c + [ScrollRegion (Pixels x, Pixels y, Pixels w, Pixels h)]) + ]; + + bind c [[],Configure] (BindSet ([Ev_Width], (fun ei -> + Canvas.configure_window c (Tag "main") [Width (Pixels ei.ev_Width)]))); + + pack [rf] [Side Side_Right; Fill Fill_Y]; + pack [lf] [Side Side_Left; Fill Fill_Both; Expand true]; + pack [secret] [Side Side_Bottom]; + pack [yscroll] [Side Side_Top; Fill Fill_Y; Expand true]; + pack [xscroll] [Side Side_Bottom; Fill Fill_X]; + pack [c] [Side Side_Left; Fill Fill_Both; Expand true]; + f, t diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli new file mode 100644 index 000000000..157c0cad1 --- /dev/null +++ b/otherlibs/labltk/frx/frx_ctext.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* 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 + +val create : + Widget.widget -> Camltk.options list -> bool -> Widget.widget * Widget.widget + (* [create parent opts nav_keys] creates a text widget + with "pixel scrolling". Based on a trick learned from Steve Ball. + Returns (frame widget, text widget). + *) + + diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml new file mode 100644 index 000000000..440278586 --- /dev/null +++ b/otherlibs/labltk/frx/frx_dialog.ml @@ -0,0 +1,115 @@ +(***********************************************************************) +(* *) +(* 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 Protocol + +let rec mapi f n l = + match l with + [] -> [] + | x::l -> let v = f n x in v::(mapi f (succ n) l) + +(* Same as tk_dialog, but not sharing the tkwait variable *) +(* w IS the parent widget *) +let f w name title mesg bitmap def buttons = + let t = Toplevel.create_named w name [Class "Dialog"] in + Wm.title_set t title; + Wm.iconname_set t "Dialog"; + Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ()); + (* Wm.transient_set t (Winfo.toplevel w); *) + let ftop = + Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)] + and fbot = + Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)] + in + pack [ftop][Side Side_Top; Fill Fill_Both]; + pack [fbot][Side Side_Bottom; Fill Fill_Both]; + + let l = + Label.create_named ftop "msg" + [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in + pack [l][Side Side_Right; Expand true; Fill Fill_Both; + PadX (Millimeters 3.0); PadY (Millimeters 3.0)]; + begin match bitmap with + Predefined "" -> () + | _ -> + let b = + Label.create_named ftop "bitmap" [Bitmap bitmap] in + pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)] + end; + + let waitv = Textvariable.create_temporary t in + + let buttons = + mapi (fun i bname -> + let b = Button.create t + [Text bname; + Command (fun () -> Textvariable.set waitv (string_of_int i))] in + if i = def then begin + let f = Frame.create_named fbot "default" + [Relief Sunken; BorderWidth (Pixels 1)] in + raise_window_above b f; + pack [f][Side Side_Left; Expand true; + PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; + pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)]; + bind t [[], KeyPressDetail "Return"] + (BindSet ([], (fun _ -> Button.flash b; Button.invoke b))) + end + else + pack [b][In fbot; Side Side_Left; Expand true; + PadX (Millimeters 3.0); PadY (Millimeters 2.0)]; + b + ) + 0 buttons in + + Wm.withdraw t; + update_idletasks(); + let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 - + (Winfo.vrootx (Winfo.parent t)) + and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 - + (Winfo.vrooty (Winfo.parent t)) in + Wm.geometry_set t (Printf.sprintf "+%d+%d" x y); + Wm.deiconify t; + + let oldfocus = try Some (Focus.get()) with _ -> None + and oldgrab = Grab.current ~displayof: t () + and grabstatus = ref None in + begin match oldgrab with + [] -> () + | x::l -> grabstatus := Some(Grab.status x) + end; + + (* avoid errors here because it makes the entire app useless *) + (try Grab.set t with TkError _ -> ()); + Tkwait.visibility t; + Focus.set (if def >= 0 then List.nth buttons def else t); + + Tkwait.variable waitv; + begin match oldfocus with + None -> () + | Some w -> try Focus.set w with _ -> () + end; + destroy t; + begin match oldgrab with + [] -> () + | x::l -> + try + match !grabstatus with + Some(GrabGlobal) -> Grab.set_global x + | _ -> Grab.set x + with TkError _ -> () + end; + + int_of_string (Textvariable.get waitv) diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli new file mode 100644 index 000000000..2124150ca --- /dev/null +++ b/otherlibs/labltk/frx/frx_dialog.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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 +val f : + Widget.widget -> + string -> string -> string -> Camltk.bitmap -> int -> string list -> int + (* same as Dialog.create_named, but with a local variable for + synchronisation. Makes it possible to have several dialogs + simultaneously *) diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml new file mode 100644 index 000000000..eea7362d6 --- /dev/null +++ b/otherlibs/labltk/frx/frx_entry.ml @@ -0,0 +1,42 @@ +(***********************************************************************) +(* *) +(* 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 + +let version = "$Id$" + +(* + * Tk 4.0 has emacs bindings for entry widgets + *) + +let new_label_entry parent txt action = + let f = Frame.create parent [] in + let m = Label.create f [Text txt] + and e = Entry.create f [Relief Sunken; TextWidth 0] in + Camltk.bind e [[], KeyPressDetail "Return"] + (BindSet ([], fun _ -> action(Entry.get e))); + pack [m][Side Side_Left]; + pack [e][Side Side_Right; Fill Fill_X; Expand true]; + f,e + +let new_labelm_entry parent txt memo = + let f = Frame.create parent [] in + let m = Label.create f [Text txt] + and e = Entry.create f [Relief Sunken; TextVariable memo; TextWidth 0] in + pack [m][Side Side_Left]; + pack [e][Side Side_Right; Fill Fill_X; Expand true]; + f,e + + diff --git a/otherlibs/labltk/frx/frx_entry.mli b/otherlibs/labltk/frx/frx_entry.mli new file mode 100644 index 000000000..2f34a7e64 --- /dev/null +++ b/otherlibs/labltk/frx/frx_entry.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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 +val new_label_entry : + Widget.widget -> + string -> (string -> unit) -> Widget.widget * Widget.widget + (* [new_label_entry parent label action] + creates a "labelled" entry widget where [action] will be invoked + when the user types Return in the widget. + Returns (frame widget, entry widget) + *) +val new_labelm_entry : + Widget.widget -> + string -> Textvariable.textVariable -> Widget.widget * Widget.widget + (* [new_labelm_entry parent label variable] + creates a "labelled" entry widget whose contents is [variable]. + Returns (frame widget, entry widget) + *) diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml new file mode 100644 index 000000000..cf59d1303 --- /dev/null +++ b/otherlibs/labltk/frx/frx_fileinput.ml @@ -0,0 +1,40 @@ +(***********************************************************************) +(* *) +(* 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 + +let version = "$Id$" + +(* + * Simple spooling for fileinput callbacks + *) + +let waiting_list = Queue. new() +and waiting = ref 0 +and max_open = ref 10 +and cur_open = ref 0 + +let add fd f = + if !cur_open < !max_open then begin + incr cur_open; + add_fileinput fd f + end + else begin + incr waiting; + Queue.add (fd,f) waiting_list + end + +let remove fd = + diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml new file mode 100644 index 000000000..f0a45f0b7 --- /dev/null +++ b/otherlibs/labltk/frx/frx_fillbox.ml @@ -0,0 +1,65 @@ +(***********************************************************************) +(* *) +(* 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 + +(* + * Progress indicators + *) +let okcolor = NamedColor "#3cb371" +and kocolor = NamedColor "#dc5c5c" + + +let new_vertical parent w h = + let c = Canvas.create_named parent "fillbox" + [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); + Relief Sunken] + in + let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels w) (Pixels 0) + [FillColor okcolor; Outline okcolor] + in + c, (function + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels w; Pixels 0] + | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; + Outline kocolor] + | n -> + let percent = if n > 100 then 100 else n in + let hf = percent*h/100 in + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels w; Pixels hf]) + +let new_horizontal parent w h = + let c = Canvas.create_named parent "fillbox" + [Width (Pixels w); Height (Pixels h); BorderWidth (Pixels 1); + Relief Sunken] + in + let i = Canvas.create_rectangle c (Pixels 0) (Pixels 0) (Pixels 0) (Pixels h) + [FillColor okcolor; Outline okcolor] + in + c, (function + 0 -> Canvas.configure_rectangle c i [FillColor okcolor; + Outline okcolor]; + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels 0; Pixels h] + | -1 -> Canvas.configure_rectangle c i [FillColor kocolor; + Outline kocolor] + | n -> + let percent = if n > 100 then 100 else n in + let wf = percent*w/100 in + Canvas.coords_set c i [Pixels 0; Pixels 0; + Pixels wf; Pixels h]) diff --git a/otherlibs/labltk/frx/frx_fillbox.mli b/otherlibs/labltk/frx/frx_fillbox.mli new file mode 100644 index 000000000..a825524cd --- /dev/null +++ b/otherlibs/labltk/frx/frx_fillbox.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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 + +val new_vertical : + Widget.widget -> int -> int -> Widget.widget * (int -> unit) + (* [new_vertical parent width height] + creates a vertical fillbox of [width] and [height]. + Returns a frame widget and a function to set the current value of + the fillbox. The value can be + n < 0 : the fillbox changes color (reddish) + 0 <= n <= 100: the fillbox fills up to n percent + 100 <= n : the fillbox fills up to 95% + *) + +val new_horizontal : + Widget.widget -> int -> int -> Widget.widget * (int -> unit) + (* save as above, except the widget is horizontal *) diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml new file mode 100644 index 000000000..71e5b1979 --- /dev/null +++ b/otherlibs/labltk/frx/frx_fit.ml @@ -0,0 +1,83 @@ +(***********************************************************************) +(* *) +(* 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 + +let debug = ref false + +let vert wid = + let newsize = ref 0 + and pending_resize = ref false + and last_last = ref 0.0 in + let rec resize () = + pending_resize := false; + if !debug then + (Printf.eprintf "%s Resize %d\n" + (Widget.name wid) !newsize; flush stderr); + Text.configure wid [TextHeight !newsize]; + () + and check () = + let first, last = Text.yview_get wid in + check1 first last + + and check1 first last = + let curheight = int_of_string (cget wid CHeight) in + if !debug then begin + Printf.eprintf "%s C %d %f %f\n" + (Widget.name wid) curheight first last; + flush stderr + end; + if first = 0.0 && last = 1.0 then () + (* Don't attempt anything if widget is not visible *) + else if not (Winfo.viewable wid) then begin + if !debug then + (Printf.eprintf "%s C notviewable\n" (Widget.name wid); + flush stderr); + (* Try again later *) + bind wid [[], Expose] (BindSet ([], fun _ -> + bind wid [[], Expose] BindRemove; + check())) + end + else begin + let delta = + if last = 0.0 then 1 + else if last = !last_last then + (* it didn't change since our last resize ! *) + 1 + else begin + last_last := last; + (* never to more than double *) + let visible = max 0.5 (last -. first) in + max 1 (truncate (float curheight *. (1. -. visible))) + end in + newsize := max (curheight + delta) !newsize; + if !debug then + (Printf.eprintf "%s newsize: %d\n" (Widget.name wid) !newsize; + flush stderr); + if !pending_resize then () + else begin + pending_resize := true; + Timer.set 300 (fun () -> Frx_after.idle resize) + end + end + + and scroll first last = + if !debug then + (Printf.eprintf "%s V %f %f\n" (Widget.name wid) first last; + flush stderr); + if first = 0.0 && last = 1.0 then () + else check1 first last + in + scroll, check diff --git a/otherlibs/labltk/frx/frx_fit.mli b/otherlibs/labltk/frx/frx_fit.mli new file mode 100644 index 000000000..29479d801 --- /dev/null +++ b/otherlibs/labltk/frx/frx_fit.mli @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* 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 + +val debug: bool ref +val vert: widget -> (float -> float -> unit) * (unit -> unit) + +(* [vert widget] + can be applied to a text widget so that it expands to show its full + contents. Returns [scroll] and [check]. [scroll] must be used as + the YScrollCommand of the widget. [check] can be called when some + modification occurs in the content of the widget (such as a size change + in some embedded windows. + This feature is a terrible hack and should be used with extreme caution. + *) diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml new file mode 100644 index 000000000..f33b9e6df --- /dev/null +++ b/otherlibs/labltk/frx/frx_focus.ml @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* 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 + +(* Temporary focus *) + +(* ? use bind tag ? how about the global reference then *) +let auto w = + let old_focus = ref w in + bind w [[],Enter] + (BindSet([], fun _ -> old_focus := Focus.get (); Focus.set w)); + bind w [[],Leave] + (BindSet([], fun _ -> Focus.set !old_focus)) diff --git a/otherlibs/labltk/frx/frx_focus.mli b/otherlibs/labltk/frx/frx_focus.mli new file mode 100644 index 000000000..919f70475 --- /dev/null +++ b/otherlibs/labltk/frx/frx_focus.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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 +val auto : Widget.widget -> unit + (* *) diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml new file mode 100644 index 000000000..2f93c4dbd --- /dev/null +++ b/otherlibs/labltk/frx/frx_font.ml @@ -0,0 +1,51 @@ +(***********************************************************************) +(* *) +(* 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 + +let version = "$Id$" + +(* + * Finding fonts. Inspired by code in Ical by Sanjay Ghemawat. + * Possibly bogus because some families use "i" for italic where others + * use "o". + * wght: bold, medium + * slant: i, o, r + * pxlsz: 8, 10, ... +*) +module StringSet = Set.Make(struct type t = string let compare = compare end) + +let available_fonts = ref (StringSet.empty) + +let get_canvas = + Frx_misc.autodef (fun () -> Canvas.create Widget.default_toplevel []) + + +let find fmly wght slant pxlsz = + let fontspec = + "-*-"^fmly^"-"^wght^"-"^slant^"-normal-*-"^string_of_int pxlsz^"-*-*-*-*-*-iso8859-1" in + if StringSet.mem fontspec !available_fonts then fontspec + else + let c = get_canvas() in + try + let tag = Canvas.create_text c (Pixels 0) (Pixels 0) + [Text "foo"; Font fontspec] in + Canvas.delete c [tag]; + available_fonts := StringSet.add fontspec !available_fonts; + fontspec + with + _ -> raise (Invalid_argument fontspec) + diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli new file mode 100644 index 000000000..c0b7e6806 --- /dev/null +++ b/otherlibs/labltk/frx/frx_font.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val find : string -> string -> string -> int -> string + (* [find family weight slant pxlsz] returns the X11 full name of + the font required font, if available. + Raises Invalid_argument fullname otherwise. + *) diff --git a/otherlibs/labltk/frx/frx_group.ml b/otherlibs/labltk/frx/frx_group.ml new file mode 100644 index 000000000..17c8a0310 --- /dev/null +++ b/otherlibs/labltk/frx/frx_group.ml @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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 + +let vgroup top l = + let f = Frame.create top [] in + Pack.forget l; + Pack.configure l [In f]; + f diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml new file mode 100644 index 000000000..c4d51f7b5 --- /dev/null +++ b/otherlibs/labltk/frx/frx_lbutton.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* 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 + + +let version = "$Id$" + +(* + * Simulate a button with a bitmap AND a label + *) + +let rec sort_options but lab com = function + [] -> but,lab,com + |(Command f as o)::l -> sort_options (o::but) lab com l + |(Bitmap b as o)::l -> sort_options (o::but) lab com l + |(Text t as o)::l -> sort_options but (o::lab) com l + |o::l -> sort_options but lab (o::com) l + +let create parent options = + let but,lab,com = sort_options [] [] [] options in + let f = Frame.create parent com in + let b = Button.create f (but@com) + and l = Label.create f (lab@com) in + pack [b;l][]; + bind l [[],ButtonPressDetail 1] (BindSet ([],(function _ -> Button.invoke b))); + f + +let configure f options = + let but,lab,com = sort_options [] [] [] options in + match Pack.slaves f with + [b;l] -> + Frame.configure f com; + Button.configure b (but@com); + Label.configure l (lab@com) + | _ -> raise (Invalid_argument "lbutton configure") diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli new file mode 100644 index 000000000..d79431f34 --- /dev/null +++ b/otherlibs/labltk/frx/frx_lbutton.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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 Widget +open Camltk + + +val version : string + +val create : Widget -> option list -> Widget +and configure : Widget -> option list -> unit + diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml new file mode 100644 index 000000000..332dca5d5 --- /dev/null +++ b/otherlibs/labltk/frx/frx_listbox.ml @@ -0,0 +1,92 @@ +(***********************************************************************) +(* *) +(* 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 + +let version = "$Id$" + +(* + * Link a scrollbar and a listbox + *) +let scroll_link sb lb = + Listbox.configure lb + [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb + [ScrollCommand (Listbox.yview lb)] + +(* + * Completion for listboxes, Macintosh style. + * As long as you type fast enough, the listbox is repositioned to the + * first entry "greater" than the typed prefix. + * assumes: + * sorted list (otherwise it's stupid) + * fixed size, because we don't recompute size at each callback invocation + *) + +let add_completion lb action = + let prefx = ref "" (* current match prefix *) + and maxi = Listbox.size lb - 1 (* maximum index (doesn't matter actually) *) + and current = ref 0 (* current position *) + and lastevent = ref 0 in + + let rec move_forward () = + if Listbox.get lb (Number !current) < !prefx then + if !current < maxi then begin incr current; move_forward() end + + and recenter () = + let element = Number !current in + (* Clean the selection *) + Listbox.selection_clear lb (Number 0) End; + (* Set it to our unique element *) + Listbox.selection_set lb element element; + (* Activate it, to keep consistent with Up/Down. + You have to be in Extended or Browse mode *) + Listbox.activate lb element; + Listbox.selection_anchor lb element; + Listbox.see lb element in + + let complete time s = + if time - !lastevent < 500 then (* sorry, hard coded limit *) + prefx := !prefx ^ s + else begin (* reset *) + current := 0; + prefx := s + end; + lastevent := time; + move_forward(); + recenter() in + + + bind lb [[], KeyPress] + (BindSet([Ev_Char; Ev_Time], + (function ev -> + (* consider only keys producing characters. The callback is called + * even if you press Shift. + *) + if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); + (* Key specific bindings override KeyPress *) + bind lb [[], KeyPressDetail "Return"] (BindSet([], action)); + (* Finally, we have to set focus, otherwise events dont get through *) + Focus.set lb; + recenter() (* so that first item is selected *) + +let new_scrollable_listbox top options = + let f = Frame.create top [] in + let lb = Listbox.create f options + and sb = Scrollbar.create f [] in + scroll_link sb lb; + pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; + pack [sb] [Side Side_Left; Fill Fill_Y]; + f, lb diff --git a/otherlibs/labltk/frx/frx_listbox.mli b/otherlibs/labltk/frx/frx_listbox.mli new file mode 100644 index 000000000..b44b6ee9d --- /dev/null +++ b/otherlibs/labltk/frx/frx_listbox.mli @@ -0,0 +1,32 @@ +(***********************************************************************) +(* *) +(* 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 +val scroll_link : Widget.widget -> Widget.widget -> unit + (* [scroll_link scrollbar listbox] links [scrollbar] and [listbox] + as expected. + *) + +val add_completion : Widget.widget -> (eventInfo -> unit) -> unit + (* [add_completion listbox action] adds Macintosh like electric navigation + in the listbox when characters are typed in. + [action] is invoked if Return is pressed + *) + +val new_scrollable_listbox : + Widget.widget -> options list -> Widget.widget * Widget.widget + (* [new_scrollable_listbox parent options] makes a scrollable listbox and + returns (frame, listbox) + *) diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml new file mode 100644 index 000000000..c3f041d00 --- /dev/null +++ b/otherlibs/labltk/frx/frx_mem.ml @@ -0,0 +1,89 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Memory gauge *) +open Camltk +open Gc + +let inited = ref None +let w = ref 300 +let delay = ref 5 (* in seconds *) +let wordsize = (* officially approved *) + if 1 lsl 31 = 0 then 4 else 8 + + +let init () = + let top = Toplevel.create Widget.default_toplevel [Class "CamlGC"] in + let name = Camltk.appname_get () in + Wm.title_set top (name ^ " Memory Gauge"); + Wm.withdraw top; + inited := Some top; + (* this should be executed before the internal "all" binding *) + bind top [[], Destroy] (BindSet ([], (fun _ -> inited := None))); + let fminors = Frame.create top [] in + let lminors = Label.create fminors [Text "Minor collections"] + and vminors = Label.create fminors [] in + pack [lminors][Side Side_Left]; + pack [vminors][Side Side_Right; Fill Fill_X; Expand true]; + let fmajors = Frame.create top [] in + let lmajors = Label.create fmajors [Text "Major collections"] + and vmajors = Label.create fmajors [] in + pack [lmajors][Side Side_Left]; + pack [vmajors][Side Side_Right; Fill Fill_X; Expand true]; + let fcompacts = Frame.create top [] in + let lcompacts = Label.create fcompacts [Text "Compactions"] + and vcompacts = Label.create fcompacts [] in + pack [lcompacts][Side Side_Left]; + pack [vcompacts][Side Side_Right; Fill Fill_X; Expand true]; + let fsize = Frame.create top [] in + let lsize = Label.create fsize [Text "Heap size (bytes)"] + and vsize = Label.create fsize [] in + pack [lsize][Side Side_Left]; + pack [vsize][Side Side_Right; Fill Fill_X; Expand true]; + let fheap = Frame.create top [Width (Pixels !w); Height (Pixels 10)] in + let flive = Frame.create fheap [Background Red] + and ffree = Frame.create fheap [Background Green] + and fdead = Frame.create fheap [Background Black] in + pack [fminors; fmajors; fcompacts; fsize; fheap][Fill Fill_X]; + + let display () = + let st = Gc.stat() in + Label.configure vminors [Text (string_of_int st.minor_collections)]; + Label.configure vmajors [Text (string_of_int st.major_collections)]; + Label.configure vcompacts [Text (string_of_int st.compactions)]; + Label.configure vsize [Text (string_of_int (wordsize * st.heap_words))]; + let liver = (float st.live_words) /. (float st.heap_words) + and freer = (float st.free_words) /. (float st.heap_words) in + Place.configure flive [X (Pixels 0); Y (Pixels 0); + RelWidth liver; RelHeight 1.0]; + Place.configure ffree [RelX liver; Y (Pixels 0); + RelWidth freer; RelHeight 1.0]; + Place.configure fdead [RelX (liver +. freer); Y (Pixels 0); + RelWidth (1.0 -. freer -. liver); RelHeight 1.0] + + in + let rec tim () = + if Winfo.exists top then begin + display(); + Timer.set (!delay * 1000) tim + end + in + tim() + + +let rec f () = + match !inited with + Some w -> Wm.deiconify w + | None -> init (); f() diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli new file mode 100644 index 000000000..f3069ec28 --- /dev/null +++ b/otherlibs/labltk/frx/frx_mem.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* A Garbage Collector Gauge for Caml *) + +val init : unit -> unit + (* [init ()] creates the gauge and its updater, but keeps it iconified *) + +val f : unit -> unit + (* [f ()] makes the gauge visible if it has not been destroyed *) diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml new file mode 100644 index 000000000..38d27fda1 --- /dev/null +++ b/otherlibs/labltk/frx/frx_misc.ml @@ -0,0 +1,69 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Delayed global, a.k.a cache&carry *) +let autodef f = + let v = ref None in + (function () -> + match !v with + None -> + let x = f() in + v := Some x; + x + | Some x -> x) + +open Camltk + +(* allows Data in options *) +let create_photo options = + let hasopt = ref None in + (* Check options *) + List.iter (function + Data s -> + begin match !hasopt with + None -> hasopt := Some (Data s) + | Some _ -> raise (Protocol.TkError "two data sources in options") + end + | File f -> + begin match !hasopt with + None -> hasopt := Some (File f) + | Some _ -> raise (Protocol.TkError "two data sources in options") + end + | o -> ()) + options; + match !hasopt with + None -> raise (Protocol.TkError "no data source in options") + | Some (Data s) -> + begin + let tmpfile = Filename.temp_file "img" "" in + let oc = open_out_bin tmpfile in + output_string oc s; + close_out oc; + let newopts = + List.map (function + | Data s -> File tmpfile + | o -> o) + options in + try + let i = Imagephoto.create newopts in + (try Sys.remove tmpfile with Sys_error _ -> ()); + i + with + e -> + (try Sys.remove tmpfile with Sys_error _ -> ()); + raise e + end + | Some (File s) -> Imagephoto.create options + | _ -> assert false diff --git a/otherlibs/labltk/frx/frx_misc.mli b/otherlibs/labltk/frx/frx_misc.mli new file mode 100644 index 000000000..2df8ce3d2 --- /dev/null +++ b/otherlibs/labltk/frx/frx_misc.mli @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* 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 +val autodef : (unit -> 'a) -> (unit -> 'a) + (* [autodef make] is a pleasant wrapper around 'a option ref *) + +val create_photo : Camltk.options list -> Camltk.imagePhoto + (* [create_photo options] allows Data in options (by saving to tmp file) *) diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml new file mode 100644 index 000000000..088977d59 --- /dev/null +++ b/otherlibs/labltk/frx/frx_req.ml @@ -0,0 +1,198 @@ +(***********************************************************************) +(* *) +(* 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 + +(* + * Some standard requesters (in Amiga techspeak) or dialog boxes (in Apple + * jargon). +*) + +let version = "$Id$" + +(* + * Simple requester + * an entry field, unrestricted, with emacs-like bindings + * Note: grabs focus, thus always unique at one given moment, and we + * shouldn't have to worry about toplevel widget name. + * We add a title widget in case the window manager does not decorate + * toplevel windows. +*) + +let open_simple title action notaction memory = + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Focus.set t; + Wm.title_set t title; + let tit = Label.create t [Text title] in + let len = max 40 (String.length (Textvariable.get memory)) in + let e = + Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in + + let activate _ = + let v = Entry.get e in + Grab.release t; (* because of wm *) + destroy t; (* so action can call open_simple *) + action v in + + bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); + + let f = Frame.create t [] in + let bok = Button.create f [Text "Ok"; Command activate] in + let bcancel = Button.create f + [Text "Cancel"; + Command (fun () -> notaction(); Grab.release t; destroy t)] in + + bind e [[], KeyPressDetail "Escape"] + (BindSet ([], (fun _ -> Button.invoke bcancel))); + pack [bok] [Side Side_Left; Expand true]; + pack [bcancel] [Side Side_Right; Expand true]; + pack [tit;e] [Fill Fill_X]; + pack [f] [Side Side_Bottom; Fill Fill_X]; + Frx_widget.resizeable t; + Focus.set e; + Tkwait.visibility t; + Grab.set t + +(* A synchronous version *) +let open_simple_synchronous title memory = + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Focus.set t; + Wm.title_set t title; + let tit = Label.create t [Text title] in + let len = max 40 (String.length (Textvariable.get memory)) in + let e = + Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in + + let waiting = Textvariable.create_temporary t in + + let activate _ = + Grab.release t; (* because of wm *) + destroy t; (* so action can call open_simple *) + Textvariable.set waiting "1" in + + bind e [[], KeyPressDetail "Return"] (BindSet ([], activate)); + + let f = Frame.create t [] in + let bok = Button.create f [Text "Ok"; Command activate] in + let bcancel = + Button.create f + [Text "Cancel"; + Command (fun () -> + Grab.release t; destroy t; Textvariable.set waiting "0")] in + + bind e [[], KeyPressDetail "Escape"] + (BindSet ([], (fun _ -> Button.invoke bcancel))); + pack [bok] [Side Side_Left; Expand true]; + pack [bcancel] [Side Side_Right; Expand true]; + pack [tit;e] [Fill Fill_X]; + pack [f] [Side Side_Bottom; Fill Fill_X]; + Frx_widget.resizeable t; + Focus.set e; + Tkwait.visibility t; + Grab.set t; + Tkwait.variable waiting; + begin match Textvariable.get waiting with + "1" -> true + | _ -> false + end + +(* + * Simple list requester + * Same remarks as in open_simple. + * focus seems to be in the listbox automatically + *) +let open_list title elements action notaction = + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Wm.title_set t title; + + let tit = Label.create t [Text title] in + let fls = Frame.create t [Relief Sunken; BorderWidth (Pixels 2)] in + let lb = Listbox.create fls [SelectMode Extended] in + let sb = Scrollbar.create fls [] in + Frx_listbox.scroll_link sb lb; + Listbox.insert lb End elements; + + (* activation: we have to break() because we destroy the requester *) + let activate _ = + let l = List.map (Listbox.get lb) (Listbox.curselection lb) in + Grab.release t; + destroy t; + List.iter action l; + break() in + + + bind lb [[Double], ButtonPressDetail 1] (BindSetBreakable ([], activate)); + + Frx_listbox.add_completion lb activate; + + let f = Frame.create t [] in + let bok = Button.create f [Text "Ok"; Command activate] in + let bcancel = Button.create f + [Text "Cancel"; + Command (fun () -> notaction(); Grab.release t; destroy t)] in + + pack [bok; bcancel] [Side Side_Left; Fill Fill_X; Expand true]; + pack [lb] [Side Side_Left; Fill Fill_Both; Expand true]; + pack [sb] [Side Side_Right; Fill Fill_Y]; + pack [tit] [Fill Fill_X]; + pack [fls] [Fill Fill_Both; Expand true]; + pack [f] [Side Side_Bottom; Fill Fill_X]; + Frx_widget.resizeable t; + Tkwait.visibility t; + Grab.set t + + +(* Synchronous *) +let open_passwd title = + let username = ref "" + and password = ref "" + and cancelled = ref false in + let t = Toplevel.create Widget.default_toplevel [Class "Dialog"] in + Focus.set t; + Wm.title_set t title; + let tit = Label.create t [Text title] + and fu,eu = Frx_entry.new_label_entry t "Username" (fun s -> ()) + and fp,ep = Frx_entry.new_label_entry t "Password" (fun s -> ()) + in + let fb = Frame.create t [] in + let bok = Button.create fb + [Text "Ok"; Command (fun _ -> + username := Entry.get eu; + password := Entry.get ep; + Grab.release t; (* because of wm *) + destroy t)] (* will return from tkwait *) + and bcancel = Button.create fb + [Text "Cancel"; Command (fun _ -> + cancelled := true; + Grab.release t; (* because of wm *) + destroy t)] (* will return from tkwait *) + in + Entry.configure ep [Show '*']; + bind eu [[], KeyPressDetail "Return"] + (BindSetBreakable ([], (fun _ -> Focus.set ep; break()))); + bind ep [[], KeyPressDetail "Return"] + (BindSetBreakable ([], (fun _ -> Button.flash bok; + Button.invoke bok; + break()))); + + pack [bok] [Side Side_Left; Expand true]; + pack [bcancel] [Side Side_Right; Expand true]; + pack [tit;fu;fp;fb] [Fill Fill_X]; + Tkwait.visibility t; + Focus.set eu; + Grab.set t; + Tkwait.window t; + if !cancelled then failwith "cancelled" + else (!username, !password) diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli new file mode 100644 index 000000000..815b28459 --- /dev/null +++ b/otherlibs/labltk/frx/frx_req.mli @@ -0,0 +1,43 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Various dialog boxes *) +val open_simple : + string -> + (string -> unit) -> (unit -> 'a) -> Textvariable.textVariable -> unit + (* [open_simple title action cancelled memory] + A dialog with a message and an entry field (with memory between + invocations). Either [action] or [cancelled] is called when the user + answers to the dialog (with Ok or Cancel) + *) + +val open_simple_synchronous : string -> Textvariable.textVariable -> bool + (* [open_simple_synchronous title memory] + A synchronous dialog with a message and an entry field (with + memory between invocations). Returns true if the user clicks Ok + or false if the user clicks Cancel. + *) +val open_list : + string -> string list -> (string -> unit) -> (unit -> unit) -> unit + (* [open_list title elements action cancelled] + A dialog for selecting from a list of elements. [action] is called + on each selected element, or [cancelled] is called if the user clicks + Cancel. + *) + +val open_passwd : string -> string * string + (* [open_passwd title] pops up a username/password dialog and returns + (username, password). + *) diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml new file mode 100644 index 000000000..23ccd2526 --- /dev/null +++ b/otherlibs/labltk/frx/frx_rpc.ml @@ -0,0 +1,55 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Some notion of RPC *) +open Camltk +open Protocol + +(* A RPC is just a callback with a particular name, plus a Tcl procedure *) +let register name f = + let id = new_function_id() in + Hashtbl.add callback_naming_table id f; + (* For rpc_info *) + Textvariable.set (Textvariable.coerce ("camltkrpc("^name^")")) + (string_of_cbid id); + tkCommand [| TkToken "proc"; TkToken name; TkToken "args"; + TkToken ("camlcb "^(string_of_cbid id)^" $args") |] + +(* RPC *) +let invoke interp f args = + tkEval [| + TkToken "send"; + TkToken interp; + TkToken f; + TkTokenList (List.map (fun s -> TkToken s) args) + |] + +let async_invoke interp f args = + tkCommand [| + TkToken "send"; + TkToken "-async"; + TkToken interp; + TkToken f; + TkTokenList (List.map (fun s -> TkToken s) args) + |] + +let rpc_info interp = + tkEval [| + TkToken "send"; + TkToken interp; + TkToken "array"; + TkToken "names"; + TkToken "camltkrpc" + |] diff --git a/otherlibs/labltk/frx/frx_rpc.mli b/otherlibs/labltk/frx/frx_rpc.mli new file mode 100644 index 000000000..808fe87c7 --- /dev/null +++ b/otherlibs/labltk/frx/frx_rpc.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Some notion of RPC *) + +val register : string -> (string list -> unit) -> unit + (* [register external_name f] *) +val invoke : string -> string -> string list -> string + (* [invoke interp name args] *) +val async_invoke : string -> string -> string list -> unit + (* [async_invoke interp name args] *) +val rpc_info : string -> string + (* [rpc_info interp] *) diff --git a/otherlibs/labltk/frx/frx_selection.ml b/otherlibs/labltk/frx/frx_selection.ml new file mode 100644 index 000000000..7ef64ce86 --- /dev/null +++ b/otherlibs/labltk/frx/frx_selection.ml @@ -0,0 +1,45 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* A selection handler *) +open Widget +open Protocol +open Camltk + +let frame = ref None +let selection = ref "" + +let read ofs n = + let res = + if ofs < 0 then "" + else if ofs + n > String.length !selection + then String.sub !selection ofs (String.length !selection - ofs) + else String.sub !selection ofs n in + tkreturn res + +(* As long as we don't loose the selection, we keep the widget *) +(* Calling this function means that we own the selection *) +(* When we loose the selection, both cb are destroyed *) +let own () = + match !frame with + None -> + let f = Frame.create_named Widget.default_toplevel "frx_selection" [] in + let lost () = selection := ""; destroy f; frame := None in + Selection.own_set [Selection "PRIMARY"; LostCommand lost] f; + Selection.handle_set [Selection "PRIMARY"; ICCCMType "STRING"] f read; + frame := Some f + | Some f -> () + +let set s = own(); selection := s diff --git a/otherlibs/labltk/frx/frx_selection.mli b/otherlibs/labltk/frx/frx_selection.mli new file mode 100644 index 000000000..dfb27ee24 --- /dev/null +++ b/otherlibs/labltk/frx/frx_selection.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val set : string -> unit + (* [set s] sets the X PRIMARY selection to [s] *) diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml new file mode 100644 index 000000000..5ce23b1d4 --- /dev/null +++ b/otherlibs/labltk/frx/frx_synth.ml @@ -0,0 +1,88 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Some notion of synthetic events *) +open Camltk +open Widget +open Protocol + +(* To each event is associated a table of (widget, callback) *) +let events = Hashtbl.create 37 + +(* Notes: + * "cascading" events (on the same event) are not supported + * Only one binding active at a time for each event on each widget. + *) + +(* Get the callback table associated with <name>. Initializes if required *) +let get_event name = + try Hashtbl.find events name + with + Not_found -> + let h = Hashtbl.create 37 in + Hashtbl.add events name h; + (* Initialize the callback invocation mechanism, based on + variable trace + *) + let var = "camltk_events(" ^ name ^")" in + let tkvar = Textvariable.coerce var in + let rec set () = + Textvariable.handle tkvar + (fun () -> + begin match Textvariable.get tkvar with + "all" -> (* Invoke all callbacks *) + Hashtbl.iter + (fun p f -> + try + f (cTKtoCAMLwidget p) + with _ -> ()) + h + | p -> (* Invoke callback for p *) + try + let w = cTKtoCAMLwidget p + and f = Hashtbl.find h p in + f w + with + _ -> () + end; + set ()(* reactivate the callback *) + ) in + set(); + h + +(* Remove binding for event <name> on widget <w> *) +let remove w name = + Hashtbl.remove (get_event name) (Widget.name w) + +(* Adds <f> as callback for widget <w> on event <name> *) +let bind w name f = + remove w name; + Hashtbl.add (get_event name) (Widget.name w) f + +(* Sends event <name> to all widgets *) +let broadcast name = + Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all" + +(* Sends event <name> to widget <w> *) +let send name w = + Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) + (Widget.name w) + +(* Remove all callbacks associated to widget <w> *) +let remove_callbacks w = + Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events + +let _ = + add_destroy_hook remove_callbacks diff --git a/otherlibs/labltk/frx/frx_synth.mli b/otherlibs/labltk/frx/frx_synth.mli new file mode 100644 index 000000000..0b8d85d85 --- /dev/null +++ b/otherlibs/labltk/frx/frx_synth.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* Synthetic events *) +open Camltk +open Widget + + +val send : string -> widget -> unit + (* [send event_name widget] *) + +val broadcast : string -> unit + (* [broadcase event_name] *) + +val bind : widget -> string -> (widget -> unit) -> unit + (* [bind event_name callback] *) + +val remove : widget -> string -> unit + (* [remove widget event_name] *) diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml new file mode 100644 index 000000000..cd405baab --- /dev/null +++ b/otherlibs/labltk/frx/frx_text.ml @@ -0,0 +1,229 @@ +(***********************************************************************) +(* *) +(* 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 + +let version = "$Id$" + +(* + * convert an integer to an absolute index +*) +let abs_index n = + TextIndex (LineChar(0,0), [CharOffset n]) + +let insertMark = + TextIndex(Mark "insert", []) + +let currentMark = + TextIndex(Mark "current", []) + +let textEnd = + TextIndex(End, []) + +let textBegin = + TextIndex (LineChar(0,0), []) + +(* + * Link a scrollbar and a text widget +*) +let scroll_link sb tx = + Text.configure tx [YScrollCommand (Scrollbar.set sb)]; + Scrollbar.configure sb [ScrollCommand (Text.yview tx)] + + +(* + * Tk 4.0 has navigation in Text widgets, sometimes using scrolling + * sometimes using the insertion mark. It is a pain to add more + * compatible bindings. We do our own. + *) +let page_up tx = Text.yview tx (ScrollPage (-1)) +and page_down tx = Text.yview tx (ScrollPage 1) +and line_up tx = Text.yview tx (ScrollUnit (-1)) +and line_down tx = Text.yview tx (ScrollUnit 1) +and top tx = Text.yview_index tx textBegin +and bottom tx = Text.yview_index tx textEnd + +let navigation_keys tx = + let tags = bindtags_get tx in + match tags with + (WidgetBindings t)::l when t = tx -> + bindtags tx ((WidgetBindings tx) :: (TagBindings "TEXT_RO") :: l) + | _ -> () + +let new_scrollable_text top options navigation = + let f = Frame.create top [] in + let tx = Text.create f options + and sb = Scrollbar.create f [] in + scroll_link sb tx; + (* IN THIS ORDER -- RESIZING *) + pack [sb] [Side Side_Right; Fill Fill_Y]; + pack [tx] [Side Side_Left; Fill Fill_Both; Expand true]; + if navigation then navigation_keys tx; + f, tx + +(* + * Searching + *) +let patternv = Frx_misc.autodef Textvariable.create +and casev = Frx_misc.autodef Textvariable.create + +let topsearch t = + (* The user interface *) + let top = Toplevel.create t [Class "TextSearch"] in + Wm.title_set top "Text search"; + let f = Frame.create_named top "fpattern" [] in + let m = Label.create_named f "search" [Text "Search pattern"] + and e = Entry.create_named f "pattern" + [Relief Sunken; TextVariable (patternv()) ] in + let hgroup = Frame.create top [] + and bgroup = Frame.create top [] in + let fdir = Frame.create hgroup [] + and fmisc = Frame.create hgroup [] in + let direction = Textvariable.create_temporary fdir + and exactv = Textvariable.create_temporary fdir + in + let forw = Radiobutton.create_named fdir "forward" + [Text "Forward"; Variable direction; Value "f"] + and backw = Radiobutton.create_named fdir "backward" + [Text "Backward"; Variable direction; Value "b"] + and exact = Checkbutton.create_named fmisc "exact" + [Text "Exact match"; Variable exactv] + and case = Checkbutton.create_named fmisc "case" + [Text "Fold Case"; Variable (casev())] + and searchb = Button.create_named bgroup "search" [Text "Search"] + and contb = Button.create_named bgroup "continue" [Text "Continue"] + and dismissb = Button.create_named bgroup "dismiss" + [Text "Dismiss"; + Command (fun () -> Text.tag_delete t ["search"]; destroy top)] in + + Radiobutton.invoke forw; + pack [m][Side Side_Left]; + pack [e][Side Side_Right; Fill Fill_X; Expand true]; + pack [forw; backw] [Anchor W]; + pack [exact; case] [Anchor W]; + pack [fdir; fmisc] [Side Side_Left; Anchor Center]; + pack [searchb; contb; dismissb] [Side Side_Left; Fill Fill_X]; + pack [f;hgroup;bgroup] [Fill Fill_X; Expand true]; + + let current_index = ref textBegin in + + let search cont = fun () -> + let opts = ref [] in + if Textvariable.get direction = "f" then + opts := Forwards :: !opts + else opts := Backwards :: !opts ; + if Textvariable.get exactv = "1" then + opts := Exact :: !opts; + if Textvariable.get (casev()) = "1" then + opts := Nocase :: !opts; + try + let forward = Textvariable.get direction = "f" in + let i = Text.search t !opts (Entry.get e) + (if cont then !current_index + else if forward then textBegin + else TextIndex(End, [CharOffset (-1)])) (* does not work with end *) + (if forward then textEnd + else textBegin) in + let found = TextIndex (i, []) in + current_index := + TextIndex(i, [CharOffset (if forward then 1 else (-1))]); + Text.tag_delete t ["search"]; + Text.tag_add t "search" found (TextIndex (i, [WordEnd])); + Text.tag_configure t "search" + [Relief Raised; BorderWidth (Pixels 1); + Background Red]; + Text.see t found + with + Invalid_argument _ -> Bell.ring() in + + bind e [[], KeyPressDetail "Return"] + (BindSet ([], fun _ -> search false ())); + Button.configure searchb [Command (search false)]; + Button.configure contb [Command (search true)]; + Tkwait.visibility top; + Focus.set e + +let addsearch tx = + let tags = bindtags_get tx in + match tags with + (WidgetBindings t)::l when t = tx -> + bindtags tx ((WidgetBindings tx) :: (TagBindings "SEARCH") :: l) + | _ -> () + +(* We use Mod1 instead of Meta or Alt *) +let init () = + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> page_up ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "BackSpace"]; + [[], KeyPressDetail "Delete"]; + [[], KeyPressDetail "Prior"]; + [[], KeyPressDetail "b"]; + [[Mod1], KeyPressDetail "v"] + ]; + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> page_down ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "space"]; + [[], KeyPressDetail "Next"]; + [[Control], KeyPressDetail "v"] + ]; + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> line_up ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Up"]; + [[Mod1], KeyPressDetail "z"] + ]; + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> line_down ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Down"]; + [[Control], KeyPressDetail "z"] + ]; + + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> top ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "Home"]; + [[Mod1], KeyPressDetail "less"] + ]; + + List.iter (function ev -> + tag_bind "TEXT_RO" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> bottom ei.ev_Widget; break())))) + [ + [[], KeyPressDetail "End"]; + [[Mod1], KeyPressDetail "greater"] + ]; + + List.iter (function ev -> + tag_bind "SEARCH" ev + (BindSetBreakable ([Ev_Widget], + (fun ei -> topsearch ei.ev_Widget; break())))) + [ + [[Control], KeyPressDetail "s"] + ] + diff --git a/otherlibs/labltk/frx/frx_text.mli b/otherlibs/labltk/frx/frx_text.mli new file mode 100644 index 000000000..ac0384432 --- /dev/null +++ b/otherlibs/labltk/frx/frx_text.mli @@ -0,0 +1,46 @@ +(***********************************************************************) +(* *) +(* 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 + +val abs_index : int -> textIndex + (* [abs_index offs] returns the corresponding TextIndex *) + +val insertMark : textIndex +val currentMark : textIndex +val textEnd : textIndex +val textBegin : textIndex + (* shortcuts for various positions in a text widget *) + +val scroll_link : Widget.widget -> Widget.widget -> unit + (* [scroll_link scrollbar text] links a scrollbar and a text widget + as expected + *) + +val new_scrollable_text : + Widget.widget -> options list -> bool -> Widget.widget * Widget.widget + (* [new_scrollable_text parent opts nav_keys] makes a scrollable text + widget with optional navigation keys. Returns frame and text widget. + *) +val addsearch : Widget.widget -> unit + (* [addsearch textw] adds a search dialog bound on [Control-s] + on the text widget + *) + +val navigation_keys : Widget.widget -> unit + (* [navigation_keys textw] adds common navigations functions to [textw] *) + +val init : unit -> unit + (* [init ()] must be called before any of the above features is used *) diff --git a/otherlibs/labltk/frx/frx_toplevel.mli b/otherlibs/labltk/frx/frx_toplevel.mli new file mode 100644 index 000000000..3608e1e57 --- /dev/null +++ b/otherlibs/labltk/frx/frx_toplevel.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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 Widget +val make_visible : Widget -> unit diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml new file mode 100644 index 000000000..ab7d26112 --- /dev/null +++ b/otherlibs/labltk/frx/frx_widget.ml @@ -0,0 +1,24 @@ +(***********************************************************************) +(* *) +(* 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 + +let version = "$Id$" +(* Make a window (toplevel widget) resizeable *) +let resizeable t = + update_idletasks(); (* wait until layout is computed *) + Wm.minsize_set t (Winfo.width t) (Winfo.height t) + diff --git a/otherlibs/labltk/frx/frx_widget.mli b/otherlibs/labltk/frx/frx_widget.mli new file mode 100644 index 000000000..ff26749ca --- /dev/null +++ b/otherlibs/labltk/frx/frx_widget.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* 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 +val resizeable : widget -> unit diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile index 1286c177b..1c499356d 100644 --- a/otherlibs/labltk/jpf/Makefile +++ b/otherlibs/labltk/jpf/Makefile @@ -1,56 +1,60 @@ include ../support/Makefile.common -COMPFLAGS=-I ../lib -I ../support -I $(OTHERS)/unix -I $(OTHERS)/str +COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/unix -I $(OTHERS)/str -OBJS= fileselect.cmo balloon.cmo +OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo OBJSX = $(OBJS:.cmo=.cmx) -all: libjpf.cma +all: jpflib.cma -opt: libjpf.cmxa +opt: jpflib.cmxa test: balloontest testopt: balloontest.opt -libjpf.cma: $(OBJS) - $(LABLLIBR) -o libjpf.cma $(OBJS) +jpflib.cma: $(OBJS) + $(CAMLLIBR) -o jpflib.cma $(OBJS) -libjpf.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX) +jpflib.cmxa: $(OBJSX) + $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX) -install: libjpf.cma - cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(LABLTKDIR) +install: jpflib.cma + cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR) -installopt: libjpf.cmxa - cp libjpf.cmxa libjpf.a $(OBJS:.cmo=.cmx) $(LABLTKDIR) +installopt: jpflib.cmxa + cp jpflib.cmxa jpflib.a $(OBJS:.cmo=.cmx) $(INSTALLDIR) clean: rm -f *.cm* *.o *.a *~ *test +$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma + +$(OBJSX): ../lib/$(LIBNAME).cmxa + ### Tests balloontest: balloontest.cmo - $(LABLC) -o balloontest -I ../support -I ../lib \ - -custom labltk.cma libjpf.cma balloontest.cmo + $(CAMLC) -o balloontest -I ../support -I ../lib \ + -custom $(LIBNAME).cma jpflib.cma balloontest.cmo balloontest.opt: balloontest.cmx $(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \ - labltk.cmxa libjpf.cmxa balloontest.cmx + $(LIBNAME).cmxa jpflib.cmxa balloontest.cmx -balloontest.cmo : balloon.cmo libjpf.cma +balloontest.cmo : balloon.cmo jpflib.cma -balloontest.cmx : balloon.cmx libjpf.cmxa +balloontest.cmx : balloon.cmx jpflib.cmxa .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmx .cmo .mli.cmi: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< @@ -58,14 +62,16 @@ balloontest.cmx : balloon.cmx libjpf.cmxa depend: mv Makefile Makefile.bak (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ - $(LABLDEP) *.mli *.ml) > Makefile + $(CAMLDEP) *.mli *.ml) > Makefile ### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED ### DO NOT DELETE THIS LINE balloon.cmo: balloon.cmi balloon.cmx: balloon.cmi -balloontest.cmo: balloon.cmi -balloontest.cmx: balloon.cmx fileselect.cmo: fileselect.cmi fileselect.cmx: fileselect.cmi +jpf_font.cmo: shell.cmi jpf_font.cmi +jpf_font.cmx: shell.cmx jpf_font.cmi +shell.cmo: shell.cmi +shell.cmx: shell.cmi diff --git a/otherlibs/labltk/jpf/Makefile.nt b/otherlibs/labltk/jpf/Makefile.nt index 8a0f58cb8..cccd58436 100644 --- a/otherlibs/labltk/jpf/Makefile.nt +++ b/otherlibs/labltk/jpf/Makefile.nt @@ -1,6 +1,6 @@ !include ..\support\Makefile.common.nt -COMPFLAGS=-I ../lib -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/str +COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/str OBJS= fileselect.cmo balloon.cmo @@ -15,29 +15,33 @@ test: balloontest testopt: balloontest.opt libjpf.cma: $(OBJS) - $(LABLLIBR) -o libjpf.cma $(OBJS) + $(CAMLLIBR) -o libjpf.cma $(OBJS) libjpf.cmxa: $(OBJSX) $(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX) install: libjpf.cma - cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(LABLTKDIR) + cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(INSTALLDIR) installopt: libjpf.cmxa - cp libjpf.cmxa libjpf.lib $(LABLTKDIR) + cp libjpf.cmxa libjpf.lib $(INSTALLDIR) clean: - rm -f *.cm* *.o *.a *~ *test + rm -f *.cm* *.obj *.a *~ *test *.lib + +$(OBJS) $(OBJS:.cmo=.cmi): ..\lib\$(LIBNAME).cma + +$(OBJSX): ..\lib\$(LIBNAME).cmxa ### Tests balloontest: balloontest.cmo - $(LABLC) -o balloontest -I ../support -I ../lib \ - -custom labltk.cma libjpf.cma balloontest.cmo $(TKLINKOPT) + $(CAMLC) -o balloontest -I ../support -I ../labltk -I ../lib \ + -custom $(LIBNAME).cma libjpf.cma balloontest.cmo $(TKLINKOPT) balloontest.opt: balloontest.cmx - $(CAMLOPT) -o balloontest.opt -I ../support -I ../lib \ - labltk.cmxa libjpf.cmxa balloontest.cmx $(TKLINKOPT) + $(CAMLOPT) -o balloontest.opt -I ../support -I ../labltk -I ../lib \ + $(LIBNAME).cmxa libjpf.cmxa balloontest.cmx $(TKLINKOPT) balloontest.cmo : balloon.cmo libjpf.cma @@ -47,10 +51,10 @@ balloontest.cmx : balloon.cmx libjpf.cmxa .SUFFIXES : .mli .ml .cmi .cmx .cmo .mli.cmi: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< @@ -58,7 +62,7 @@ balloontest.cmx : balloon.cmx libjpf.cmxa depend: mv Makefile Makefile.bak (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ - $(LABLDEP) *.mli *.ml) > Makefile + $(CAMLDEP) *.mli *.ml) > Makefile ### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED diff --git a/otherlibs/labltk/jpf/README b/otherlibs/labltk/jpf/README new file mode 100644 index 000000000..275c2d780 --- /dev/null +++ b/otherlibs/labltk/jpf/README @@ -0,0 +1,2 @@ +This is Jun Furuse's widget set library, Jpf. +It uses LablTk API. diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml index 818a48881..6b2f36d20 100644 --- a/otherlibs/labltk/jpf/balloon.ml +++ b/otherlibs/labltk/jpf/balloon.ml @@ -1,16 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -94,7 +96,7 @@ let init () = begin fun w -> try Hashtbl.find t w.ev_Widget with Not_found -> - Hashtbl'.add t ~key:w.ev_Widget ~data: (); + Hashtbl.add t w.ev_Widget (); let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x end diff --git a/otherlibs/labltk/jpf/balloon.mli b/otherlibs/labltk/jpf/balloon.mli index cae6e5bb3..633796ce6 100644 --- a/otherlibs/labltk/jpf/balloon.mli +++ b/otherlibs/labltk/jpf/balloon.mli @@ -1,16 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml index 63e86c169..36e6c8dbf 100644 --- a/otherlibs/labltk/jpf/balloontest.ml +++ b/otherlibs/labltk/jpf/balloontest.ml @@ -1,16 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -22,9 +24,9 @@ open Protocol let _ = let t = openTk () in Balloon.init (); - let b = Button.create t text: "hello" in - Button.configure b command: (fun () -> destroy b); + let b = Button.create t ~text: "hello" in + Button.configure b ~command: (fun () -> destroy b); pack [b]; - Balloon.put on: b ms: 1000 "Balloon"; + Balloon.put ~on: b ~ms: 1000 "Balloon"; Printexc.catch mainLoop () diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml index 28d2349ea..ec0e7749f 100644 --- a/otherlibs/labltk/jpf/fileselect.ml +++ b/otherlibs/labltk/jpf/fileselect.ml @@ -1,21 +1,26 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) (* file selection box *) +(* This file selecter works only under the OS with the full unix support. + For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) + open StdLabels open UnixLabels open Str diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli index 1948ad772..79dc828f9 100644 --- a/otherlibs/labltk/jpf/fileselect.mli +++ b/otherlibs/labltk/jpf/fileselect.mli @@ -1,19 +1,24 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Jun Furuse, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) +(* This file selecter works only under the OS with the full unix support. + For the portability, Tk.getOpenFile and Tk.getSaveFile are recommended. *) + open Support val f : diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml new file mode 100644 index 000000000..93deab643 --- /dev/null +++ b/otherlibs/labltk/jpf/jpf_font.ml @@ -0,0 +1,218 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +(* find font information *) + +let debug = ref false +let log s = + if !debug then try prerr_endline s with _ -> () + +type ('s, 'i) xlfd = { + (* some of them are currently not interesting for me *) + mutable foundry: 's; + mutable family: 's; + mutable weight: 's; + mutable slant: 's; + mutable setWidth: 's; + mutable addStyle: 's; + mutable pixelSize: 'i; + mutable pointSize: 'i; + mutable resolutionX: 'i; + mutable resolutionY: 'i; + mutable spacing: 's; + mutable averageWidth: 'i; + mutable registry: 's; + mutable encoding: 's + } + +let copy xlfd = {xlfd with foundry= xlfd.foundry} + +let string_of_xlfd s i xlfd = + let foundry= s xlfd.foundry + and family= s xlfd.family + and weight= s xlfd.weight + and slant= s xlfd.slant + and setWidth = s xlfd.setWidth + and addStyle = s xlfd.addStyle + and pixelSize= i xlfd.pixelSize + and pointSize = i xlfd.pointSize + and resolutionX = i xlfd.resolutionX + and resolutionY = i xlfd.resolutionY + and spacing= s xlfd.spacing + and averageWidth = i xlfd.averageWidth + and registry= s xlfd.registry + and encoding = s xlfd.encoding in + + "-"^foundry^ + "-"^family^ + "-"^weight^ + "-"^slant^ + "-"^setWidth ^ + "-"^addStyle ^ + "-"^pixelSize^ + "-"^pointSize ^ + "-"^resolutionX ^ + "-"^resolutionY ^ + "-"^spacing^ + "-"^averageWidth ^ + "-"^registry^ + "-"^encoding + +exception Parse_Xlfd_Failure of string + +let parse_xlfd xlfd_string = + (* this must not be a pattern *) + let split_str char_sep str = + let len = String.length str in + let rec split beg cur = + if cur >= len then [String.sub str beg (len - beg)] + else if char_sep (String.get str cur) + then + let nextw = succ cur in + (String.sub str beg (cur - beg)) + ::(split nextw nextw) + else split beg (succ cur) in + split 0 0 + in + match split_str (function '-' -> true | _ -> false) xlfd_string with + | [ _; foundry; family; weight; slant; setWidth; addStyle; pixelSize; + pointSize; resolutionX; resolutionY; spacing; averageWidth; + registry; encoding ] -> + { foundry= foundry; + family= family; + weight= weight; + slant= slant; + setWidth= setWidth; + addStyle= addStyle; + pixelSize= int_of_string pixelSize; + pointSize= int_of_string pointSize; + resolutionX= int_of_string resolutionX; + resolutionY= int_of_string resolutionY; + spacing= spacing; + averageWidth= int_of_string averageWidth; + registry= registry; + encoding= encoding; + } + | _ -> raise (Parse_Xlfd_Failure xlfd_string) + +type valid_xlfd = (string, int) xlfd + +let string_of_valid_xlfd = string_of_xlfd (fun x -> x) string_of_int + +type pattern = (string option, int option) xlfd + +let empty_pattern = + { foundry= None; + family= None; + weight= None; + slant= None; + setWidth= None; + addStyle= None; + pixelSize= None; + pointSize= None; + resolutionX= None; + resolutionY= None; + spacing= None; + averageWidth= None; + registry= None; + encoding= None; + } + +let string_of_pattern = + let pat f = function + Some x -> f x + | None -> "*" + in + let pat_string = pat (fun x -> x) in + let pat_int = pat string_of_int in + string_of_xlfd pat_string pat_int + +let is_vector_font xlfd = + (xlfd.pixelSize = 0 && xlfd.resolutionX = 0 && xlfd.resolutionY = 0) || + xlfd.spacing <> "c" + +let list_fonts dispname pattern = + let dispopt = match dispname with + None -> "" + | Some x -> "-display " ^ x + in + let result = List.map parse_xlfd + (Shell.subshell ("xlsfonts "^dispopt^" -fn "^string_of_pattern pattern)) + in + if result = [] then raise Not_found + else result + +let available_pixel_size_aux dispname pattern = + (* return available pixel size without font resizing *) + (* to obtain good result, *) + (* the pattern should contain as many information as possible *) + let pattern = copy pattern in + pattern.pixelSize <- None; + let xlfds = list_fonts dispname pattern in + let pxszs = Hashtbl.create 107 in + List.iter (fun xlfd -> + Hashtbl.add pxszs xlfd.pixelSize xlfd) xlfds; + pxszs + +let extract_size_font_hash tbl = + let keys = ref [] in + Hashtbl.iter (fun k _ -> + if not (List.mem k !keys) then keys := k :: !keys) tbl; + Sort.list (fun (k1,_) (k2,_) -> k1 < k2) + (List.map (fun k -> k, Hashtbl.find_all tbl k) !keys) + +let available_pixel_size dispname pattern = + let pxszs = available_pixel_size_aux dispname pattern in + extract_size_font_hash pxszs + +let nearest_pixel_size dispname vector_ok pattern = + (* find the font with the nearest pixel size *) + log ("\n*** "^string_of_pattern pattern); + let pxlsz = + match pattern.pixelSize with + None -> raise (Failure "invalid pixelSize pattern") + | Some x -> x + in + let tbl = available_pixel_size_aux dispname pattern in + let newtbl = Hashtbl.create 107 in + Hashtbl.iter (fun s xlfd -> + if vector_ok then + if s = 0 then begin + if is_vector_font xlfd then begin + log (Printf.sprintf "%s is vector" (string_of_valid_xlfd xlfd)); + xlfd.pixelSize <- pxlsz; + Hashtbl.add newtbl pxlsz xlfd + end + end else Hashtbl.add newtbl s xlfd + else if not (is_vector_font xlfd) && s <> 0 then + Hashtbl.add newtbl s xlfd) tbl; + + let size_font_table = extract_size_font_hash newtbl in + + let diff = ref 10000 in + let min = ref None in + List.iter (fun (s,xlfds) -> + let d = abs(s - pxlsz) in + if d < !diff then begin + min := Some (s,xlfds); + diff := d + end) size_font_table; + (* if it contains more than one font, just return the first *) + match !min with + | None -> raise Not_found + | Some(s, xlfds) -> + log (Printf.sprintf "Size %d is selected" s); + List.iter (fun xlfd -> log (string_of_valid_xlfd xlfd)) xlfds; + List.hd xlfds diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli new file mode 100644 index 000000000..cd1e21229 --- /dev/null +++ b/otherlibs/labltk/jpf/jpf_font.mli @@ -0,0 +1,54 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val debug : bool ref + +type ('a, 'b) xlfd = + { mutable foundry: 'a; + mutable family: 'a; + mutable weight: 'a; + mutable slant: 'a; + mutable setWidth: 'a; + mutable addStyle: 'a; + mutable pixelSize: 'b; + mutable pointSize: 'b; + mutable resolutionX: 'b; + mutable resolutionY: 'b; + mutable spacing: 'a; + mutable averageWidth: 'b; + mutable registry: 'a; + mutable encoding: 'a } + +exception Parse_Xlfd_Failure of string + +type valid_xlfd = (string, int) xlfd +type pattern = (string option, int option) xlfd + +val empty_pattern : pattern + +val copy : ('a, 'b) xlfd -> ('a, 'b) xlfd + +val string_of_valid_xlfd : valid_xlfd -> string +val string_of_pattern : pattern -> string + +val is_vector_font : valid_xlfd -> bool + +val list_fonts : string option -> pattern -> valid_xlfd list + +val available_pixel_size : + string option -> pattern -> (int * valid_xlfd list) list + +val nearest_pixel_size : + string option -> bool -> pattern -> valid_xlfd diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml new file mode 100644 index 000000000..45b342258 --- /dev/null +++ b/otherlibs/labltk/jpf/shell.ml @@ -0,0 +1,36 @@ +(***********************************************************************) +(* *) +(* 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 Unix + +(************************************************************* Subshell call *) + +let subshell cmd = + let r,w = pipe () in + match fork () with + 0 -> close r; dup2 w stdout; + close stderr; + execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127 + | id -> + close w; + let rc = in_channel_of_descr r in + let rec it () = try + let x = input_line rc in x:: it () + with _ -> [] + in + let answer = it() in + close_in rc; (* because of finalize_channel *) + let p, st = waitpid [] id in answer + diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli new file mode 100644 index 000000000..be93f5f1a --- /dev/null +++ b/otherlibs/labltk/jpf/shell.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +val subshell : string -> string list + diff --git a/otherlibs/labltk/labltk/.cvsignore b/otherlibs/labltk/labltk/.cvsignore new file mode 100644 index 000000000..585067641 --- /dev/null +++ b/otherlibs/labltk/labltk/.cvsignore @@ -0,0 +1,3 @@ +*.ml *.mli labltktop labltk +modules +.depend diff --git a/otherlibs/labltk/labltk/Makefile b/otherlibs/labltk/labltk/Makefile new file mode 100644 index 000000000..423a67e80 --- /dev/null +++ b/otherlibs/labltk/labltk/Makefile @@ -0,0 +1,45 @@ +include ../support/Makefile.common + +COMPFLAGS= -I ../support + +all: labltkobjs + +opt: labltkobjsx + +include ./modules + +LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo +LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) + +labltkobjs: $(LABLTKOBJS) + +labltkobjsx: $(LABLTKOBJSX) + +# All .{ml,mli} files are generated in this directory +clean: + rm -f *.cm* *.ml *.mli *.o *.a + $(MAKE) -f Makefile.gen clean + +install: $(LABLTKOBJS) + if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) $(INSTALLDIR) + chmod 644 $(INSTALLDIR)/*.cmi + +installopt: $(LABLTKOBJSX) + @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(LABLTKOBJSX) $(INSTALLDIR) + chmod 644 $(INSTALLDIR)/*.cmx + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +include .depend diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen new file mode 100644 index 000000000..08b91a032 --- /dev/null +++ b/otherlibs/labltk/labltk/Makefile.gen @@ -0,0 +1,42 @@ +include ../support/Makefile.common + +all: tk.ml labltk.ml .depend + +_tkgen.ml: ../Widgets.src ../compiler/tkcompiler + cd ..; ../../boot/ocamlrun compiler/tkcompiler -outdir labltk + +# dependencies are broken: wouldn't work with gmake 3.77 + +tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml + (echo 'open StdLabels'; \ + echo 'open Widget'; \ + echo 'open Protocol'; \ + echo 'open Support'; \ + echo 'open Textvariable'; \ + cat ../builtin/report.ml; \ + cat ../builtin/builtin_*.ml; \ + cat _tkgen.ml; \ + echo ; \ + echo ; \ + echo 'module Tkintf = struct'; \ + cat ../builtin/builtini_*.ml; \ + cat _tkigen.ml; \ + echo 'end (* module Tkintf *)'; \ + echo ; \ + echo ; \ + echo 'open Tkintf' ;\ + echo ; \ + echo ; \ + cat ../builtin/builtinf_*.ml; \ + cat _tkfgen.ml; \ + echo ; \ + ) > _tk.ml + ../../../boot/ocamlrun ../compiler/pp < _tk.ml > tk.ml + rm -f _tk.ml + $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend + +../compiler/pp: + cd ../compiler; $(MAKE) pp + +clean: + rm -f modules .depend diff --git a/otherlibs/labltk/labltk/Makefile.gen.nt b/otherlibs/labltk/labltk/Makefile.gen.nt new file mode 100644 index 000000000..dc0fa9367 --- /dev/null +++ b/otherlibs/labltk/labltk/Makefile.gen.nt @@ -0,0 +1,43 @@ +!include ..\support\Makefile.common.nt + +all: tk.ml labltk.ml .depend + +_tkgen.ml: ..\Widgets.src ..\compiler\tkcompiler.exe + cd .. & ..\..\boot\ocamlrun compiler/tkcompiler.exe -outdir labltk + +# dependencies are broken: wouldn't work with gmake 3.77 + +tk.ml labltk.ml .depend: _tkgen.ml ..\builtin\report.ml ..\compiler\pp.exe #../builtin/builtin_*.ml + type << > _tk.ml +open StdLabels +open Widget +open Protocol +open Support +open Textvariable +<< + type ..\builtin\report.ml >> _tk.ml + type ..\builtin\builtin_*.ml >> _tk.ml + type _tkgen.ml >> _tk.ml + type << >> _tk.ml + + +module Tkintf = struct +<< + type ..\builtin\builtini_*.ml >> _tk.ml + type _tkigen.ml >> _tk.ml + type << >> _tk.ml +end (* module Tkintf *) + + +open Tkintf + + +<< + type ..\builtin\builtinf_*.ml >> _tk.ml + type _tkfgen.ml >> _tk.ml + ..\..\..\boot\ocamlrun ..\compiler\pp.exe < _tk.ml > tk.ml + rm -f _tk.ml + $(CAMLDEP) -I ../support *.mli *.ml > .depend + +clean: + rm -f modules .depend diff --git a/otherlibs/labltk/labltk/Makefile.nt b/otherlibs/labltk/labltk/Makefile.nt new file mode 100644 index 000000000..12582b807 --- /dev/null +++ b/otherlibs/labltk/labltk/Makefile.nt @@ -0,0 +1,43 @@ +!include ..\support\Makefile.common.nt + +COMPFLAGS= -I ../support + +all: labltkobjs + +opt: labltkobjsx + +# All .{ml,mli} files are generated in this directory +clean : + rm -f *.cm* *.ml *.mli *.a *.obj + $(MAKE) -f Makefile.gen.nt clean + +!include .\modules + +LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo +LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) + +labltkobjs: $(LABLTKOBJS) + +labltkobjsx: $(LABLTKOBJSX) + +install: $(LABLTKOBJS) + @if not exist $(INSTALLDIR) mkdir $(INSTALLDIR) + cp *.cmi [a-z]*.mli $(INSTALLDIR) + +installopt: $(LABLTKOBJSX) + @if not exist $(INSTALLDIR) mkdir $(INSTALLDIR) + cp $(LABLTKOBJSX) $(INSTALLDIR) + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +!include .depend diff --git a/otherlibs/labltk/lib/.cvsignore b/otherlibs/labltk/lib/.cvsignore index 585067641..3a756bb7a 100644 --- a/otherlibs/labltk/lib/.cvsignore +++ b/otherlibs/labltk/lib/.cvsignore @@ -1,3 +1,3 @@ -*.ml *.mli labltktop labltk +*.ml *.mli labltktop labltk mltktop mltk modules .depend diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile index ec1e04cd3..9a1e1003f 100644 --- a/otherlibs/labltk/lib/Makefile +++ b/otherlibs/labltk/lib/Makefile @@ -1,83 +1,69 @@ include ../support/Makefile.common -COMPFLAGS= -I ../support +all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME) -SUPPORT=../support/support.cmo ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo +opt: $(LIBNAME).cmxa -SUPPORTX = $(SUPPORT:.cmo=.cmx) +clean: + rm -f $(LIBNAME).cma $(LIBNAME).cmxa $(LIBNAME)top$(EXE) $(LIBNAME) *.a -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo +include ../labltk/modules +LABLTKOBJS=tk.cmo $(WIDGETOBJS) -all : labltk.cma labltktop$(EXE) labltk +include ../camltk/modules +CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo + +SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ + ../support/widget.cmo ../support/protocol.cmo \ + ../support/textvariable.cmo ../support/timer.cmo \ + ../support/fileevent.cmo ../support/camltkwrap.cmo -opt : labltk.cmxa +TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) -include ./modules -WIDGETOBJSX = $(WIDGETOBJS:.cmo=.cmx) +TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo -labltk.cma : $(SUPPORT) $(WIDGETOBJS) tk.cmo - $(MKLIB) -ocamlc '$(LABLC)' -o labltk -oc labltk41 \ - $(SUPPORT) tk.cmo $(WIDGETOBJS) \ +$(LIBNAME).cma: $(SUPPORT) + cd ../labltk; $(MAKE) + cd ../camltk; $(MAKE) + $(MKLIB) -ocamlc '$(CAMLC)' -o $(LIBNAME) -oc $(LIBNAME) \ + -I ../labltk -I ../camltk $(TKOBJS) \ $(TK_LINK) $(X11_LINK) -labltk.cmxa : $(SUPPORTX) $(WIDGETOBJSX) tk.cmx - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o labltk -oc labltk41 \ - $(SUPPORTX) tk.cmx $(WIDGETOBJSX) \ +$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) + cd ../labltk; $(MAKE) opt + cd ../camltk; $(MAKE) opt + $(MKLIB) -ocamlopt '$(CAMLOPT)' -o $(LIBNAME) -oc $(LIBNAME) \ + -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ $(TK_LINK) $(X11_LINK) -labltktop$(EXE) : $(TOPDEPS) $(WIDGETOBJS) $(SUPPORT) ../support/liblabltk41.a - $(LABLC) -linkall -o labltktop$(EXE) -I ../support \ - -I $(TOPDIR)/toplevel toplevellib.cma labltk.cma \ +$(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a + $(CAMLC) -linkall -o $(LIBNAME)top$(EXE) -I ../support \ + -I $(TOPDIR)/toplevel toplevellib.cma \ + -I ../labltk -I ../camltk $(LIBNAME).cma \ -I $(OTHERS)/unix unix.cma \ -I $(OTHERS)/str str.cma \ $(DLLPATH) \ topmain.cmo -labltk: Makefile $(TOPDIR)/config/Makefile +$(LIBNAME): Makefile $(TOPDIR)/config/Makefile @echo Generate $@ @echo "#!/bin/sh" > $@ - @echo 'exec $(LABLTKDIR)/labltktop$(EXE) -I $(LABLTKDIR) $$*' >> $@ - -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.o *.a labltktop$(EXE) - -install: labltk.cma labltktop$(EXE) labltk - if test -d $(LABLTKDIR); then : ; else mkdir $(LABLTKDIR); fi - if test `grep -s -c '^$(LABLTKDIR)$$' $(LIBDIR)/ld.conf || :` = 0; \ - then echo $(LABLTKDIR) >> $(LIBDIR)/ld.conf; fi - cp $(WIDGETOBJS:.cmo=.cmi) tk.cmi $(LABLTKDIR) - cp labltk.cma labltktop$(EXE) $(LABLTKDIR) - chmod 644 $(LABLTKDIR)/*.cmi - chmod 644 $(LABLTKDIR)/labltk.cma - chmod 755 $(LABLTKDIR)/labltktop$(EXE) + @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@ + +install: all + if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + if test `grep -s -c '^$(INSTALLDIR)$$' $(LIBDIR)/ld.conf || :` = 0; \ + then echo $(INSTALLDIR) >> $(LIBDIR)/ld.conf; fi + cp $(LIBNAME).cma $(LIBNAME)top$(EXE) $(INSTALLDIR) + chmod 644 $(INSTALLDIR)/$(LIBNAME).cma + chmod 755 $(INSTALLDIR)/$(LIBNAME)top$(EXE) @if test -d $(BINDIR); then : ; else mkdir $(BINDIR); fi - cp labltk $(BINDIR) - chmod 755 $(BINDIR)/labltk - - -installopt: labltk.cmxa - @if test -d $(LABLTKDIR); then : ; else mkdir $(LABLTKDIR); fi - cp $(SUPPORTX) $(WIDGETOBJSX) tk.cmx $(LABLTKDIR) - cp labltk.cmxa labltk.a $(LABLTKDIR) - cd $(LABLTKDIR); $(RANLIB) labltk.a - chmod 644 $(LABLTKDIR)/*.cmx - chmod 644 $(LABLTKDIR)/labltk.cmxa - chmod 644 $(LABLTKDIR)/labltk.a - @if test -d $(BINDIR); then : ; else mkdir $(BINDIR); fi - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(LABLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(LABLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend + cp $(LIBNAME) $(BINDIR) + chmod 755 $(BINDIR)/$(LIBNAME) + +installopt: opt + @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(LIBNAME).cmxa $(LIBNAME).a $(INSTALLDIR) + cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).a + chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa + chmod 644 $(INSTALLDIR)/$(LIBNAME).a diff --git a/otherlibs/labltk/lib/Makefile.gen.nt b/otherlibs/labltk/lib/Makefile.gen.nt deleted file mode 100644 index 43ad1ebe5..000000000 --- a/otherlibs/labltk/lib/Makefile.gen.nt +++ /dev/null @@ -1,38 +0,0 @@ -!include ..\support\Makefile.common.nt - -all: tk.ml .depend - -tkgen.ml: ..\Widgets.src ..\compiler\tkcompiler - cd .. & ..\..\boot\ocamlrun compiler/tkcompiler - -# dependencies are broken: wouldn't work with gmake 3.77 - -tk.ml .depend: tkgen.ml ..\builtin\report.ml #../builtin/builtin_*.ml - type << > tk.ml -open StdLabels -open Widget -open Protocol -open Support -open Textvariable -<< - type ..\builtin\report.ml >> tk.ml - type ..\builtin\builtin_*.ml >> tk.ml - type tkgen.ml >> tk.ml - type << >> tk.ml - - -module Tkintf = struct -<< - type ..\builtin\builtini_*.ml >> tk.ml - type tkigen.ml >> tk.ml - type << >> tk.ml -end (* module Tkintf *) - - -open Tkintf - - -<< - type ..\builtin\builtinf_*.ml >> tk.ml - type tkfgen.ml >> tk.ml - $(LABLDEP) *.mli *.ml > .depend diff --git a/otherlibs/labltk/lib/Makefile.nt b/otherlibs/labltk/lib/Makefile.nt index d3dfffa5f..99176c73e 100644 --- a/otherlibs/labltk/lib/Makefile.nt +++ b/otherlibs/labltk/lib/Makefile.nt @@ -1,60 +1,59 @@ !include ..\support\Makefile.common.nt -COMPFLAGS= -I ../support +all: $(LIBNAME).cma -SUPPORT=../support/support.cmo ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo - -SUPPORTX = $(SUPPORT:.cmo=.cmx) - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -all : labltk.cma - -opt : labltk.cmxa - -include ./modules -WIDGETOBJSX = $(WIDGETOBJS:.cmo=.cmx) +opt: $(LIBNAME).cmxa -labltk.cma : $(SUPPORT) $(WIDGETOBJS) tk.cmo - $(LABLLIBR) -o labltk.cma $(SUPPORT) tk.cmo $(WIDGETOBJS) \ - -dllib -llabltk41 -cclib -llabltk41 $(TK_LINK) +clean: + rm -f $(LIBNAME).cma $(LIBNAME).cmxa *.lib -labltk.cmxa : $(SUPPORTX) $(WIDGETOBJSX) tk.cmx - $(CAMLOPTLIBR) -o labltk.cmxa $(SUPPORTX) tk.cmx $(WIDGETOBJSX) \ - -cclib -llabltk41 $(TK_LINK) +!include ..\labltk\modules +LABLTKOBJS=tk.cmo $(WIDGETOBJS) -#labltk : $(TOPDEPS) $(WIDGETOBJS) $(SUPPORT) -# $(LABLC) -linkall -o $@ -I ../support $(TKLINKOPT) \ -# -I $(TOPDIR)/toplevel toplevellib.cma labltk.cma \ -# -I $(OTHERS)/win32unix unix.cma -I $(OTHERS)/str str.cma \ -# topmain.cmo +!include ..\camltk\modules +CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.o *.a labltktop - -install: labltk.cma #labltk - @if not exist $(LABLTKDIR) mkdir $(LABLTKDIR) - cp *.cmi labltk.cma $(LABLTKDIR) -# @if not exist $(BINDIR) mkdir $(BINDIR) -# cp labltk.exe $(BINDIR) - -installopt: labltk.cmxa - @if not exist $(LABLTKDIR) mkdir $(LABLTKDIR) - cp labltk.cmxa labltk.lib $(LABLTKDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(LABLCOMP) $(COMPFLAGS) $< +SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ + ../support/widget.cmo ../support/protocol.cmo \ + ../support/textvariable.cmo ../support/timer.cmo \ + ../support/fileevent.cmo ../support/camltkwrap.cmo -.ml.cmo: - $(LABLCOMP) $(COMPFLAGS) $< +TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< +TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo -!include .depend +$(LIBNAME).cma: $(SUPPORT) + cd ..\labltk & $(MAKEREC) + cd ..\camltk & $(MAKEREC) + $(CAMLLIBR) -o $(LIBNAME).cma -I ../labltk -I ../camltk $(TKOBJS) \ + -dllib -l$(LIBNAME) -cclib -l$(LIBNAME) $(TK_LINK) + +$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) + cd ../labltk; $(MAKEREC) opt + cd ../camltk; $(MAKEREC) opt + $(CAMLOPTLIBR) -o $(LIBNAME).cmxa -I ../labltk -I ../camltk \ + $(TKOBJS:.cmo=.cmx) -cclib -l$(LIBNAME) $(TK_LINK) + +# $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a +# $(CAMLC) -linkall -o $(LIBNAME)top$(EXE) -I ../support \ +# -I $(TOPDIR)/toplevel toplevellib.cma \ +# -I ../labltk -I ../camltk $(LIBNAME).cma \ +# -I $(OTHERS)/unix unix.cma \ +# -I $(OTHERS)/str str.cma \ +# $(DLLPATH) \ +# topmain.cmo +# +# $(LIBNAME): Makefile $(TOPDIR)/config/Makefile +# @echo Generate $@ +# @echo "#!/bin/sh" > $@ +# @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@ + +install: all + @if not exist $(INSTALLDIR) mkdir $(INSTALLDIR) + cp $(LIBNAME).cma $(INSTALLDIR) +# @if test -d $(BINDIR); then : ; else mkdir $(BINDIR); fi +# cp $(LIBNAME) $(BINDIR) + +installopt: opt + @if not exist $(INSTALLDIR) mkdir $(INSTALLDIR) + cp $(LIBNAME).cmxa $(LIBNAME).lib $(INSTALLDIR) diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend index c10b37a92..0abefc892 100644 --- a/otherlibs/labltk/support/.depend +++ b/otherlibs/labltk/support/.depend @@ -1,9 +1,17 @@ +camltkwrap.cmi: protocol.cmi textvariable.cmi timer.cmi widget.cmi protocol.cmi: widget.cmi textvariable.cmi: protocol.cmi widget.cmi +widget.cmi: rawwidget.cmi +camltkwrap.cmo: fileevent.cmi protocol.cmi rawwidget.cmi textvariable.cmi \ + timer.cmi camltkwrap.cmi +camltkwrap.cmx: fileevent.cmx protocol.cmx rawwidget.cmx textvariable.cmx \ + timer.cmx camltkwrap.cmi fileevent.cmo: protocol.cmi support.cmi fileevent.cmi fileevent.cmx: protocol.cmx support.cmx fileevent.cmi protocol.cmo: support.cmi widget.cmi protocol.cmi protocol.cmx: support.cmx widget.cmx protocol.cmi +rawwidget.cmo: support.cmi rawwidget.cmi +rawwidget.cmx: support.cmx rawwidget.cmi slave.cmo: widget.cmi slave.cmx: widget.cmx support.cmo: support.cmi @@ -12,5 +20,5 @@ textvariable.cmo: protocol.cmi support.cmi widget.cmi textvariable.cmi textvariable.cmx: protocol.cmx support.cmx widget.cmx textvariable.cmi timer.cmo: protocol.cmi support.cmi timer.cmi timer.cmx: protocol.cmx support.cmx timer.cmi -widget.cmo: support.cmi widget.cmi -widget.cmx: support.cmx widget.cmi +widget.cmo: rawwidget.cmi widget.cmi +widget.cmx: rawwidget.cmx widget.cmi diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile index dff07f26a..06ef541c8 100644 --- a/otherlibs/labltk/support/Makefile +++ b/otherlibs/labltk/support/Makefile @@ -1,49 +1,50 @@ include Makefile.common -all: support.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo \ - liblabltk41.a +all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ + textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ + lib$(LIBNAME).a -opt: support.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx \ - liblabltk41.a +opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ + textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ + lib$(LIBNAME).a -COBJS=cltkCaml.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \ - cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o +COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \ + cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o CCFLAGS=-I../../../byterun $(TK_DEFS) $(X11_INCLUDES) $(SHAREDCCCOMPOPTS) COMPFLAGS=-I $(OTHERS)/unix -liblabltk41.a : $(COBJS) - $(MKLIB) -o labltk41 $(COBJS) $(TK_LINK) $(X11_LINK) +lib$(LIBNAME).a : $(COBJS) + $(MKLIB) -o $(LIBNAME) $(COBJS) $(TK_LINK) $(X11_LINK) PUB=fileevent.cmi fileevent.mli \ protocol.cmi protocol.mli \ textvariable.cmi textvariable.mli \ timer.cmi timer.mli \ + rawwidget.cmi rawwidget.mli \ widget.cmi widget.mli -install: liblabltk41.a $(PUB) - if test -d $(LABLTKDIR); then : ; else mkdir $(LABLTKDIR); fi - cp $(PUB) liblabltk41.a $(LABLTKDIR) - cd $(LABLTKDIR); $(RANLIB) liblabltk41.a - cd $(LABLTKDIR); chmod 644 $(PUB) liblabltk41.a - if test -f dlllabltk41.so; then \ - cp dlllabltk41.so $(LABLTKDIR)/dlllabltk41.so; \ - chmod 644 $(LABLTKDIR)/dlllabltk41.so; fi +install: lib$(LIBNAME).a $(PUB) + if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi + cp $(PUB) lib$(LIBNAME).a $(INSTALLDIR) + cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).a + cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).a + if test -f dll$(LIBNAME).so; then \ + cp dll$(LIBNAME).so $(INSTALLDIR)/dll$(LIBNAME).so; \ + chmod 644 $(INSTALLDIR)/dll$(LIBNAME).so; fi clean : - rm -f *.cm* *.o *.a + rm -f *.cm* *.o *.a *.so .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .o .mli.cmi: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< @@ -52,7 +53,7 @@ clean : $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< depend: - $(LABLDEP) *.mli *.ml > .depend + $(CAMLDEP) *.mli *.ml > .depend $(COBJS): $(TOPDIR)/config/Makefile camltk.h diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common index f50adf886..85cfbaf2c 100644 --- a/otherlibs/labltk/support/Makefile.common +++ b/otherlibs/labltk/support/Makefile.common @@ -4,22 +4,24 @@ TOPDIR=../../.. ## Path to the otherlibs subdirectory OTHERS=../.. +LIBNAME=labltk + include $(TOPDIR)/config/Makefile -LABLTKDIR=$(LIBDIR)/labltk +INSTALLDIR=$(LIBDIR)/$(LIBNAME) ## Tools from the Objective Caml distribution CAMLRUN=$(TOPDIR)/boot/ocamlrun -LABLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib -LABLCOMP=$(LABLC) -c -warn-error A -LABLYACC=$(TOPDIR)/boot/ocamlyacc -v -LABLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex -LABLLIBR=$(LABLC) -a -LABLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep +CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib +CAMLCOMP=$(CAMLC) -c -warn-error A +CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v +CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex +CAMLLIBR=$(CAMLC) -a +CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep COMPFLAGS= LINKFLAGS= -DLLPATH=`if $(SUPPORTS_SHARED_LIBRARIES); then echo -dllpath $(LABLTKDIR); fi` +DLLPATH=`if $(SUPPORTS_SHARED_LIBRARIES); then echo -dllpath $(INSTALLDIR); fi` CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib CAMLOPTLIBR=$(CAMLOPT) -a diff --git a/otherlibs/labltk/support/Makefile.common.nt b/otherlibs/labltk/support/Makefile.common.nt index 98f30283e..f2f22110c 100644 --- a/otherlibs/labltk/support/Makefile.common.nt +++ b/otherlibs/labltk/support/Makefile.common.nt @@ -7,20 +7,22 @@ EXEDIR=$(TOPDIRNT) ## Path to the otherlibs subdirectory OTHERS=../.. +LIBNAME=mltk + !include $(TOPDIRNT)\config\Makefile.nt -LABLTKDIR=$(LIBDIR)\labltk +INSTALLDIR=$(LIBDIR)\$(LIBNAME) TKLINKOPT=$(STATIC) ## Tools from the Objective Caml distribution CAMLRUN=$(EXEDIR)\boot\ocamlrun -LABLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib -LABLCOMP=$(LABLC) -labels -c -LABLYACC=$(EXEDIR)\boot\ocamlyacc -v -LABLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex -LABLLIBR=$(LABLC) -a -LABLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep +CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib +CAMLCOMP=$(CAMLC) -labels -c +CAMLYACC=$(EXEDIR)\boot\ocamlyacc -v +CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex +CAMLLIBR=$(CAMLC) -a +CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep COMPFLAGS= LINKFLAGS= diff --git a/otherlibs/labltk/support/Makefile.nt b/otherlibs/labltk/support/Makefile.nt index cff71b45e..acc3071dc 100644 --- a/otherlibs/labltk/support/Makefile.nt +++ b/otherlibs/labltk/support/Makefile.nt @@ -1,53 +1,53 @@ !include Makefile.common.nt -all: support.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo \ - dlllabltk41.dll liblabltk41.lib +all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ + textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ + dll$(LIBNAME).dll lib$(LIBNAME).lib -opt: support.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx \ - liblabltk41.lib +opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ + textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ + lib$(LIBNAME).lib -COBJS=cltkCaml.obj cltkEval.obj cltkEvent.obj cltkFile.obj cltkMain.obj \ - cltkMisc.obj cltkTimer.obj cltkVar.obj cltkWait.obj +COBJS=cltkCaml.obj cltkUtf.obj cltkEval.obj cltkEvent.obj cltkFile.obj \ + cltkMain.obj cltkMisc.obj cltkTimer.obj cltkVar.obj cltkWait.obj cltkImg.obj CCFLAGS=-I..\..\..\byterun -I..\..\win32unix $(TK_DEFS) COMPFLAGS=-I $(OTHERS)/win32unix -dlllabltk41.dll : $(COBJS:.obj=.dobj) - link /nologo /dll /out:dlllabltk41.dll /implib:tmp.lib \ +dll$(LIBNAME).dll : $(COBJS:.obj=.dobj) + link /nologo /dll /out:dll$(LIBNAME).dll /implib:dll$(LIBNAME).lib \ $(COBJS:.obj=.dobj) ..\..\..\byterun\ocamlrun.lib \ $(TK_LINK) wsock32.lib - rm tmp.* -liblabltk41.lib : $(COBJS:.obj=.sobj) - rm -f liblabltk41.lib - $(MKLIB)liblabltk41.lib $(COBJS:.obj=.sobj) +lib$(LIBNAME).lib : $(COBJS:.obj=.sobj) + rm -f lib$(LIBNAME).lib + $(MKLIB)lib$(LIBNAME).lib $(COBJS:.obj=.sobj) PUB=fileevent.cmi fileevent.mli \ protocol.cmi protocol.mli \ textvariable.cmi textvariable.mli \ timer.cmi timer.mli \ + rawwidget.cmi rawwidget.mli \ widget.cmi widget.mli -install: dlllabltk41.dll liblabltk41.lib $(PUB) - @if not exist $(LABLTKDIR) mkdir $(LABLTKDIR) - cp $(PUB) $(LABLTKDIR) - cp dlllabltk41.dll liblabltk41.lib $(LABLTKDIR) - echo $(LABLTKDIR)>> $(LIBDIR)\ld.conf +install: dll$(LIBNAME).dll lib$(LIBNAME).lib $(PUB) + @if not exist $(INSTALLDIR) mkdir $(INSTALLDIR) + cp $(PUB) $(INSTALLDIR) + cp dll$(LIBNAME).dll dll$(LIBNAME).lib lib$(LIBNAME).lib $(INSTALLDIR) + echo $(INSTALLDIR)>> $(LIBDIR)\ld.conf clean : - rm -f *.cm* *.dobj *.sobj *.dll *.lib + rm -f *.cm* *.dobj *.sobj *.dll *.lib *.exp *.obj .SUFFIXES : .SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .dobj .sobj .mli.cmi: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmo: - $(LABLCOMP) $(COMPFLAGS) $< + $(CAMLCOMP) $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< @@ -61,7 +61,7 @@ clean : mv $*.obj $*.sobj depend: - $(LABLDEP) *.mli *.ml > .depend + $(CAMLDEP) *.mli *.ml > .depend $(COBJS): camltk.h diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h index 741a4184e..06505cf71 100644 --- a/otherlibs/labltk/support/camltk.h +++ b/otherlibs/labltk/support/camltk.h @@ -20,8 +20,12 @@ /* copy a Caml string to the C heap. Must be deallocated with stat_free */ extern char *string_to_c(value s); +/* cltkUtf.c */ +extern value tcl_string_to_caml( char * ); +extern char * caml_string_to_tcl( value ); + /* cltkEval.c */ -extern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ +CAMLprim Tcl_Interp *cltclinterp; /* The Tcl interpretor */ extern value copy_string_list(int argc, char ** argv); /* cltkCaml.c */ @@ -30,7 +34,7 @@ extern value *tkerror_exn; extern value *handler_code; extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, char *argv[]); -extern void tk_error(char * errmsg) Noreturn; +CAMLprim void tk_error(char * errmsg) Noreturn; /* cltkMain.c */ extern int signal_events; diff --git a/otherlibs/labltk/support/camltkwrap.ml b/otherlibs/labltk/support/camltkwrap.ml new file mode 100644 index 000000000..5afe864df --- /dev/null +++ b/otherlibs/labltk/support/camltkwrap.ml @@ -0,0 +1,77 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +module Widget = struct + include Rawwidget + type widget = raw_any raw_widget + + let default_toplevel = coe default_toplevel +end + +module Protocol = struct + open Widget + include Protocol + + let opentk () = coe (opentk ()) + let opentk_with_args args = coe (opentk_with_args args) + let openTk ?display ?clas () = coe (openTk ?display ?clas ()) + + let cCAMLtoTKwidget table w = + Widget.check_class w table; (* we need run time type check of widgets *) + TkToken (Widget.name w) + + (* backward compatibility *) + let openTkClass s = coe (openTkClass s) + let openTkDisplayClass disp c = coe (openTkDisplayClass disp c) +end + +module Textvariable = struct + open Textvariable + type textVariable = Textvariable.textVariable + let create = create + let set = set + let get = get + let name = name + let cCAMLtoTKtextVariable = cCAMLtoTKtextVariable + let handle tv cbk = handle tv ~callback:cbk + let coerce = coerce + + (*-*) + let free = free + + (* backward compatibility *) + let create_temporary w = create ~on: w () +end + +module Fileevent = struct + open Fileevent + let add_fileinput fd callback = add_fileinput ~fd ~callback + let remove_fileinput fd = remove_fileinput ~fd + let add_fileoutput fd callback = add_fileoutput ~fd ~callback + let remove_fileoutput fd = remove_fileoutput ~fd +end + +module Timer = struct + open Timer + type t = Timer.t + let add ms callback = add ~ms ~callback + let set ms callback = set ~ms ~callback + let remove = remove +end + +(* +Not compiled in support +module Tkwait = Tkwait +*) diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli new file mode 100644 index 000000000..914ad0223 --- /dev/null +++ b/otherlibs/labltk/support/camltkwrap.mli @@ -0,0 +1,251 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) +module Widget : sig + type widget = Widget.any Widget.widget + (* widget is an abstract type *) + + val default_toplevel : widget + (* [default_toplevel] is "." in Tk, the toplevel widget that is + always existing during a Tk session. Destroying [default_toplevel] + ends the main loop + *) + + val atom : parent: widget -> name: string -> widget + (* [atom parent name] returns the widget [parent.name]. The widget is + not created. Only its name is returned. In a given parent, there may + only exist one children for a given name. + This function should only be used to check the existence of a widget + with a known name. It doesn't add the widget to the internal tables + of CamlTk. + *) + + val name : widget -> string + (* [name w] returns the name (tk "path") of a widget *) + + (*--*) + (* The following functions are used internally. + There is normally no need for them in users programs + *) + + val known_class : widget -> string + (* [known_class w] returns the class of a widget (e.g. toplevel, frame), + as known by the CamlTk interface. + Not equivalent to "winfo w" in Tk. + *) + + val dummy : widget + (* [dummy] is a widget used as context when we don't have any. + It is *not* a real widget. + *) + + val new_atom : parent: widget -> ?name: string -> string -> widget + (* incompatible with the classic camltk *) + + val get_atom : string -> widget + (* [get_atom path] returns the widget with Tk path [path] *) + + val remove : widget -> unit + (* [remove w] removes widget from the internal tables *) + + (* Subtypes tables *) + val widget_any_table : string list + val widget_button_table : string list + val widget_canvas_table : string list + val widget_checkbutton_table : string list + val widget_entry_table : string list + val widget_frame_table : string list + val widget_label_table : string list + val widget_listbox_table : string list + val widget_menu_table : string list + val widget_menubutton_table : string list + val widget_message_table : string list + val widget_radiobutton_table : string list + val widget_scale_table : string list + val widget_scrollbar_table : string list + val widget_text_table : string list + val widget_toplevel_table : string list + + val chk_sub : string -> 'a list -> 'a -> unit + val check_class : widget -> string list -> unit + (* Widget subtyping *) + + exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) + + (* this function is not used, but introduced for the compatibility + with labltk. useless for camltk users *) + val coe : 'a Widget.widget -> Widget.any Widget.widget +end + +module Protocol : sig + open Widget + + (* Lower level interface *) + exception TkError of string + (* Raised by the communication functions *) + + val debug : bool ref + (* When set to true, displays approximation of intermediate Tcl code *) + + type tkArgs = + TkToken of string + | TkTokenList of tkArgs list (* to be expanded *) + | TkQuote of tkArgs (* mapped to Tcl list *) + + + (* Misc *) + external splitlist : string -> string list + = "camltk_splitlist" + + val add_destroy_hook : (widget -> unit) -> unit + + + (* Opening, closing, and mainloop *) + val default_display : unit -> string + + val opentk : unit -> widget + (* The basic initialization function. [opentk ()] parses automatically + the command line options and use the tk related options in them + such as "-display localhost:0" to initialize Tk applications. + Consult wish manpage about the supported options. *) + + val keywords : (string * Arg.spec * string) list + (* Command line parsing specification for Arg.parse, which contains + the standard Tcl/Tk command line options such as "-display" and "-name". + These Tk command line options are used by opentk *) + + val opentk_with_args : string list -> widget + (* [opentk_with_args argv] invokes [opentk] with the tk related + command line options given by [argv] to the executable program. *) + + val openTk : ?display:string -> ?clas:string -> unit -> widget + (* [openTk ~display:display ~clas:clas ()] is equivalent to + [opentk ["-display"; display; "-name"; clas]] *) + + (* Legacy opentk functions *) + val openTkClass: string -> widget + (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) + val openTkDisplayClass: string -> string -> widget + (* [openTkDisplayClass disp class] is equivalent to + [opentk ["-display"; disp; "-name"; class]] *) + + val closeTk : unit -> unit + val finalizeTk : unit -> unit + (* Finalize tcl/tk before exiting. This function will be automatically + called when you call [Pervasives.exit ()] *) + + val mainLoop : unit -> unit + + + (* Direct evaluation of tcl code *) + val tkEval : tkArgs array -> string + + val tkCommand : tkArgs array -> unit + + (* Returning a value from a Tcl callback *) + val tkreturn: string -> unit + + + (* Callbacks: this is private *) + + type cbid = Protocol.cbid + + type callback_buffer = string list + (* Buffer for reading callback arguments *) + + val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t + (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *) + val callback_memo_table : (widget, cbid) Hashtbl.t + (* Exported for debug purposes only. Don't use them unless you + know what you are doing *) + val new_function_id : unit -> cbid + val string_of_cbid : cbid -> string + val register_callback : widget -> callback:(callback_buffer -> unit) -> string + (* Callback support *) + val clear_callback : cbid -> unit + (* Remove a given callback from the table *) + val remove_callbacks : widget -> unit + (* Clean up callbacks associated to widget. Must be used only when + the Destroy event is bind by the user and masks the default + Destroy event binding *) + + val cTKtoCAMLwidget : string -> widget + val cCAMLtoTKwidget : string list -> widget -> tkArgs + + val register : string -> callback:(callback_buffer -> unit) -> unit + + (*-*) + val prerr_cbid : cbid -> unit +end + +module Textvariable : sig + open Widget + open Protocol + + type textVariable = Textvariable.textVariable + (* TextVariable is an abstract type *) + + val create : ?on: widget -> unit -> textVariable + (* Allocation of a textVariable with lifetime associated to widget + if a widget is specified *) + val create_temporary : widget -> textVariable + (* for backward compatibility + [create_temporary w] is equivalent to [create ~on:w ()] *) + + val set : textVariable -> string -> unit + (* Setting the val of a textVariable *) + val get : textVariable -> string + (* Reading the val of a textVariable *) + val name : textVariable -> string + (* Its tcl name *) + + val cCAMLtoTKtextVariable : textVariable -> tkArgs + (* Internal conversion function *) + + val handle : textVariable -> (unit -> unit) -> unit + (* Callbacks on variable modifications *) + + val coerce : string -> textVariable + + (*-*) + val free : textVariable -> unit +end + +module Fileevent : sig + open Unix + + val add_fileinput : file_descr -> (unit -> unit) -> unit + val remove_fileinput: file_descr -> unit + val add_fileoutput : file_descr -> (unit -> unit) -> unit + val remove_fileoutput: file_descr -> unit + (* see [tk] module *) +end + +module Timer : sig + type t = Timer.t + + val add : int -> (unit -> unit) -> t + val set : int -> (unit -> unit) -> unit + val remove : t -> unit +end + +(* +Tkwait exists, but is not used in support +module Tkwait : sig + val internal_tracevis : string -> string -> unit + val internal_tracedestroy : string -> string -> unit +end +*) diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c index f9b9f7406..976c864ef 100644 --- a/otherlibs/labltk/support/cltkCaml.c +++ b/otherlibs/labltk/support/cltkCaml.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -61,7 +61,7 @@ CAMLprim value camltk_return (value v) } /* Note: raise_with_string WILL copy the error message */ -void tk_error(char *errmsg) +CAMLprim void tk_error(char *errmsg) { raise_with_string(*tkerror_exn, errmsg); } diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c index 40adccf2d..236dc299a 100644 --- a/otherlibs/labltk/support/cltkEval.c +++ b/otherlibs/labltk/support/cltkEval.c @@ -1,22 +1,23 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ #include <stdlib.h> +#include <string.h> #include <tcl.h> #include <tk.h> @@ -29,26 +30,26 @@ #include "camltk.h" /* The Tcl interpretor */ -Tcl_Interp *cltclinterp = NULL; +CAMLprim Tcl_Interp *cltclinterp = NULL; /* Copy a list of strings from the C heap to Caml */ value copy_string_list(int argc, char **argv) { - value res; + CAMLparam0(); + CAMLlocal3( res, oldres, str ); int i; - value oldres = Val_unit, str = Val_unit; - - Begin_roots2 (oldres, str); - res = Val_int(0); /* [] */ - for (i = argc-1; i >= 0; i--) { - oldres = res; - str = copy_string(argv[i]); - res = alloc(2, 0); - Field(res, 0) = str; - Field(res, 1) = oldres; - } - End_roots(); - return res; + oldres = Val_unit; + str = Val_unit; + + res = Val_int(0); /* [] */ + for (i = argc-1; i >= 0; i--) { + oldres = res; + str = tcl_string_to_caml(argv[i]); + res = alloc(2, 0); + Field(res, 0) = str; + Field(res, 1) = oldres; + } + CAMLreturn(res); } /* @@ -68,13 +69,13 @@ CAMLprim value camltk_tcl_eval(value str) * leak */ Tcl_ResetResult(cltclinterp); - cmd = string_to_c(str); + cmd = caml_string_to_tcl(str); code = Tcl_Eval(cltclinterp, cmd); stat_free(cmd); switch (code) { case TCL_OK: - return copy_string(cltclinterp->result); + return tcl_string_to_caml(cltclinterp->result); case TCL_ERROR: tk_error(cltclinterp->result); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ @@ -104,7 +105,7 @@ int argv_size(value v) case 0: /* TkToken */ return 1; case 1: /* TkTokenList */ - { int n; + { int n = 0; value l; for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1)) n+=argv_size(Field(l,0)); @@ -112,23 +113,11 @@ int argv_size(value v) } case 2: /* TkQuote */ return 1; - default: /* should not happen */ - Assert(0); - return 0; + default: + tk_error("argv_size: illegal tag"); } } -/* - * Memory of allocated Tcl lists. - * We should not need more than MAX_LIST - */ -#define MAX_LIST 256 -static char *tcllists[MAX_LIST]; - -static int startfree = 0; -/* If size is lower, do not allocate */ -static char *quotedargv[16]; - /* Fill a preallocated vector arguments, doing expansion and all. * Assumes Tcl will * not tamper with our strings @@ -136,34 +125,35 @@ static char *quotedargv[16]; */ int fill_args (char **argv, int where, value v) { + value l; + switch (Tag_val(v)) { case 0: - argv[where] = String_val(Field(v,0)); + argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */ return (where + 1); case 1: - { value l; - for (l=Field(v,0); Is_block(l); l=Field(l,1)) - where = fill_args(argv,where,Field(l,0)); - return where; - } + for (l=Field(v,0); Is_block(l); l=Field(l,1)) + where = fill_args(argv,where,Field(l,0)); + return where; case 2: { char **tmpargv; + char *merged; + int i; int size = argv_size(Field(v,0)); - if (size < 16) - tmpargv = "edargv[0]; - else - tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); + tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); fill_args(tmpargv,0,Field(v,0)); tmpargv[size] = NULL; - argv[where] = Tcl_Merge(size,tmpargv); - tcllists[startfree++] = argv[where]; /* so we can free it later */ - if (size >= 16) - stat_free((char *)tmpargv); + merged = Tcl_Merge(size,tmpargv); + for(i = 0 ; i<size; i++){ stat_free(tmpargv[i]); } + stat_free((char *)tmpargv); + /* must be freed by stat_free */ + argv[where] = (char*)stat_alloc(strlen(merged)+1); + strcpy(argv[where], merged); + Tcl_Free(merged); return (where + 1); } - default: /* should not happen */ - Assert(0); - return 0; + default: + tk_error("fill_args: illegal tag"); } } @@ -172,10 +162,9 @@ CAMLprim value camltk_tcl_direct_eval(value v) { int i; int size; /* size of argv */ - char **argv; + char **argv, **allocated; int result; Tcl_CmdInfo info; - int wherewasi,whereami; /* positions in tcllists array */ CheckInit(); @@ -186,76 +175,71 @@ CAMLprim value camltk_tcl_direct_eval(value v) /* +2: one slot for NULL one slot for "unknown" if command not found */ argv = (char **)stat_alloc((size + 2) * sizeof(char *)); + allocated = (char **)stat_alloc(size * sizeof(char *)); - wherewasi = startfree; /* should be zero except when nested calls */ - Assert(startfree < MAX_LIST); - - /* Copy */ + /* Copy -- argv[i] must be freed by stat_free */ { int where; - for(i=0, where=0;i<Wosize_val(v);i++) + for(i=0, where=0;i<Wosize_val(v);i++){ where = fill_args(argv,where,Field(v,i)); + } + if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); } + for(i=0; i<where; i++){ allocated[i] = argv[i]; } argv[size] = NULL; argv[size + 1] = NULL; } - Begin_roots_block ((value *) argv, size + 2); - - whereami = startfree; - - /* Eval */ - Tcl_ResetResult(cltclinterp); - if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */ + /* Eval */ + Tcl_ResetResult(cltclinterp); + if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */ #if (TCL_MAJOR_VERSION >= 8) - /* info.proc might be a NULL pointer - * We should probably attempt an Obj invocation, but the following quick - * hack is easier. - */ - if (info.proc == NULL) { - Tcl_DString buf; - char *string; - Tcl_DStringInit(&buf); - Tcl_DStringAppend(&buf, argv[0], -1); - for (i=1; i<size; i++) { - Tcl_DStringAppend(&buf, " ", -1); - Tcl_DStringAppend(&buf, argv[i], -1); - } - /* fprintf(stderr,"80 compat: %s\n", argv[0]); */ - result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf)); - Tcl_DStringFree(&buf); + /* info.proc might be a NULL pointer + * We should probably attempt an Obj invocation, but the following quick + * hack is easier. + */ + if (info.proc == NULL) { + Tcl_DString buf; + char *string; + Tcl_DStringInit(&buf); + Tcl_DStringAppend(&buf, argv[0], -1); + for (i=1; i<size; i++) { + Tcl_DStringAppend(&buf, " ", -1); + Tcl_DStringAppend(&buf, argv[i], -1); } - else - result = (*info.proc)(info.clientData,cltclinterp,size,argv); -#else + result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf)); + Tcl_DStringFree(&buf); + } else { result = (*info.proc)(info.clientData,cltclinterp,size,argv); + } +#else + result = (*info.proc)(info.clientData,cltclinterp,size,argv); #endif - } else {/* implement the autoload stuff */ - if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ - for (i = size; i >= 0; i--) - argv[i+1] = argv[i]; - argv[0] = "unknown"; - result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); - } else { /* ah, it isn't there at all */ - result = TCL_ERROR; - Tcl_AppendResult(cltclinterp, "Unknown command \"", - argv[0], "\"", NULL); - } + } else { /* implement the autoload stuff */ + if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ + for (i = size; i >= 0; i--) + argv[i+1] = argv[i]; + argv[0] = "unknown"; + result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); + } else { /* ah, it isn't there at all */ + result = TCL_ERROR; + Tcl_AppendResult(cltclinterp, "Unknown command \"", + argv[0], "\"", NULL); } - End_roots (); + } /* Free the various things we allocated */ + for(i=0; i< size; i ++){ + stat_free((char *) allocated[i]); + } stat_free((char *)argv); - for (i=wherewasi; i<whereami; i++) - free(tcllists[i]); - startfree = wherewasi; + stat_free((char *)allocated); switch (result) { case TCL_OK: - return copy_string (cltclinterp->result); + return tcl_string_to_caml (cltclinterp->result); case TCL_ERROR: tk_error(cltclinterp->result); default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */ tk_error("bad tcl result"); } } - diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c index e2c24cca6..81c9413f6 100644 --- a/otherlibs/labltk/support/cltkEvent.c +++ b/otherlibs/labltk/support/cltkEvent.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -26,14 +26,13 @@ CAMLprim value camltk_tk_mainloop(void) { CheckInit(); - if (cltk_slave_mode) - return Val_unit; + if (cltk_slave_mode) return Val_unit; if (!signal_events) { /* Initialise signal handling */ signal_events = 1; Tk_CreateTimerHandler(100, invoke_pending_caml_signals, NULL); - }; + } Tk_MainLoop(); return Val_unit; } diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c index c77ea2198..9ea6004ed 100644 --- a/otherlibs/labltk/support/cltkFile.c +++ b/otherlibs/labltk/support/cltkFile.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c new file mode 100644 index 000000000..f30166ef5 --- /dev/null +++ b/otherlibs/labltk/support/cltkImg.c @@ -0,0 +1,111 @@ +/***********************************************************************/ +/* */ +/* 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 <string.h> +#include <tcl.h> +#include <tk.h> +#include <mlvalues.h> +#include <memory.h> +#include <alloc.h> +#include "camltk.h" + +/* + * Pixmap manipulation from OCaml : get the pixmap from an arbitrary photo + * image, and put it back in some (possibly other) image. + * TODO: other blits + * We use the same format of "internal" pixmap data as in Tk, that is + * 24 bits per pixel + */ + +CAMLprim value camltk_getimgdata (value imgname) /* ML */ +{ + CAMLparam1(imgname); + CAMLlocal1(res); + Tk_PhotoHandle ph; + Tk_PhotoImageBlock pib; + int code,size; + +#if (TK_MAJOR_VERSION < 8) + if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) + tk_error("no such image"); +#else + if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) + tk_error("no such image"); +#endif + + code = Tk_PhotoGetImage(ph,&pib); /* never fails ? */ + size = pib.width * pib.height * pib.pixelSize; + res = alloc_string(size); + + /* no holes, default format ? */ + if ((pib.pixelSize == 3) && + (pib.pitch == (pib.width * pib.pixelSize)) && + (pib.offset[0] == 0) && + (pib.offset[1] == 1) && + (pib.offset[2] == 2)) { + memcpy(pib.pixelPtr, String_val(res),size); + CAMLreturn(res); + } else { + int y; /* varies from 0 to height - 1 */ + int yoffs = 0; /* byte offset of line in src */ + int yidx = 0; /* byte offset of line in dst */ + for (y=0; y<pib.height; y++,yoffs+=pib.pitch,yidx+=pib.width * 3) { + int x; /* varies from 0 to width - 1 */ + int xoffs = yoffs; /* byte offset of pxl in src */ + int xidx = yidx; /* byte offset of pxl in dst */ + for (x=0; x<pib.width; x++,xoffs+=pib.pixelSize,xidx+=3) { + Byte(res, xidx) = pib.pixelPtr[xoffs+pib.offset[0]]; + Byte(res, xidx + 1) = pib.pixelPtr[xoffs+pib.offset[1]]; + Byte(res, xidx + 2) = pib.pixelPtr[xoffs+pib.offset[2]]; + }; + } + CAMLreturn(res); + } +} + +CAMLprim void +camltk_setimgdata_native (value imgname, value pixmap, value x, value y, + value w, value h) /* ML */ +{ + Tk_PhotoHandle ph; + Tk_PhotoImageBlock pib; + int code; + +#if (TK_MAJOR_VERSION < 8) + if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) + tk_error("no such image"); +#else + if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) + tk_error("no such image"); +#endif + + pib.pixelPtr = String_val(pixmap); + pib.width = Int_val(w); + pib.height = Int_val(h); + pib.pitch = pib.width * 3; + pib.pixelSize = 3; + pib.offset[0] = 0; + pib.offset[1] = 1; + pib.offset[2] = 2; + Tk_PhotoPutBlock(ph,&pib,Int_val(x),Int_val(y),Int_val(w),Int_val(h)); +} + +CAMLprim void camltk_setimgdata_bytecode(argv,argn) + value *argv; + int argn; +{ + camltk_setimgdata_native(argv[0], argv[1], argv[2], argv[3], + argv[4], argv[5]); +} diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c index 8512c72b2..6400c4a49 100644 --- a/otherlibs/labltk/support/cltkMain.c +++ b/otherlibs/labltk/support/cltkMain.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -23,6 +23,7 @@ #include <memory.h> #include <callback.h> #include <signals.h> +#include <fail.h> #ifdef HAS_UNISTD #include <unistd.h> /* for R_OK */ #endif @@ -65,28 +66,62 @@ Tk_Window cltk_mainWindow; int cltk_slave_mode = 0; /* Initialisation, based on tkMain.c */ -CAMLprim value camltk_opentk(value display, value name) +CAMLprim value camltk_opentk(value argv) { + CAMLparam1(argv); + CAMLlocal1(tmp); + char *argv0; + + /* argv must contain argv[0], the application command name */ + tmp = Val_unit; + + if ( argv == Val_int(0) ){ + failwith("camltk_opentk: argv is empty"); + } + argv0 = String_val( Field( argv, 0 ) ); + if (!cltk_slave_mode) { /* Create an interpreter, dies if error */ #if TCL_MAJOR_VERSION >= 8 - Tcl_FindExecutable(String_val(name)); + Tcl_FindExecutable(String_val(argv0)); #endif cltclinterp = Tcl_CreateInterp(); if (Tcl_Init(cltclinterp) != TCL_OK) tk_error(cltclinterp->result); - Tcl_SetVar(cltclinterp, "argv0", String_val (name), TCL_GLOBAL_ONLY); - { /* Sets display if needed */ - char *args; - char *tkargv[2]; - if (string_length(display) > 0) { - Tcl_SetVar(cltclinterp, "argc", "2", TCL_GLOBAL_ONLY); - tkargv[0] = "-display"; - tkargv[1] = String_val(display); - args = Tcl_Merge(2, tkargv); + Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY); + + { /* Sets argv */ + int argc = 0; + + tmp = Field(argv, 1); /* starts from argv[1] */ + while ( tmp != Val_int(0) ) { + argc++; + tmp = Field(tmp, 1); + } + + if( argc != 0 ){ + int i; + char *args; + char **tkargv; + char argcstr[256]; /* string of argc */ + + tkargv = (char**)stat_alloc(sizeof( char* ) * argc ); + tmp = Field(argv, 1); /* starts from argv[1] */ + i = 0; + + while ( tmp != Val_int(0) ) { + tkargv[i] = String_val(Field(tmp, 0)); + tmp = Field(tmp, 1); + i++; + } + + sprintf( argcstr, "%d", argc ); + Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); + args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */ Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); - free(args); + Tcl_Free(args); + stat_free( tkargv ); } } if (Tk_Init(cltclinterp) != TCL_OK) @@ -129,6 +164,11 @@ CAMLprim value camltk_opentk(value display, value name) } } - return Val_unit; + CAMLreturn(Val_unit); } +CAMLprim value camltk_finalize(value unit) /* ML */ +{ + Tcl_Finalize(); + return Val_unit; +} diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c index 7980e0c8a..a6e823d1d 100644 --- a/otherlibs/labltk/support/cltkMisc.c +++ b/otherlibs/labltk/support/cltkMisc.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -29,19 +29,24 @@ CAMLprim value camltk_splitlist (value v) int argc; char **argv; int result; + char *utf; CheckInit(); + utf = caml_string_to_tcl(v); /* argv is allocated by Tcl, to be freed by us */ - result = Tcl_SplitList(cltclinterp,String_val(v),&argc,&argv); + result = Tcl_SplitList(cltclinterp,utf,&argc,&argv); switch(result) { case TCL_OK: { value res = copy_string_list(argc,argv); - free((char *)argv); /* only one large block was allocated */ + Tcl_Free((char *)argv); /* only one large block was allocated */ + /* argv points into utf: utf must be freed after argv are freed */ + stat_free( utf ); return res; } case TCL_ERROR: default: + stat_free( utf ); tk_error(cltclinterp->result); } } diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c index 793535bea..21f1b1588 100644 --- a/otherlibs/labltk/support/cltkTimer.c +++ b/otherlibs/labltk/support/cltkTimer.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ diff --git a/otherlibs/labltk/support/cltkUtf.c b/otherlibs/labltk/support/cltkUtf.c new file mode 100644 index 000000000..fd01bd15a --- /dev/null +++ b/otherlibs/labltk/support/cltkUtf.c @@ -0,0 +1,89 @@ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include <stdlib.h> +#include <string.h> + +#include <tcl.h> +#include <tk.h> +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#ifdef HAS_UNISTD +#include <unistd.h> +#endif +#include "camltk.h" + +#if (TCL_MAJOR_VERSION > 8 || \ + (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1)) /* 8.1 */ +# define UTFCONVERSION +#endif + +#ifdef UTFCONVERSION + +char *external_to_utf( char *str ){ + char *res; + Tcl_DString dstr; + int length; + + Tcl_ExternalToUtfDString(NULL, str, strlen(str), &dstr); + length = Tcl_DStringLength(&dstr); + res = stat_alloc(length + 1); + memmove( res, Tcl_DStringValue(&dstr), length+1); + Tcl_DStringFree(&dstr); + + return res; +} + +char *utf_to_external( char *str ){ + char *res; + Tcl_DString dstr; + int length; + + Tcl_UtfToExternalDString(NULL, str, strlen(str), &dstr); + length = Tcl_DStringLength(&dstr); + res = stat_alloc(length + 1); + memmove( res, Tcl_DStringValue(&dstr), length+1); + Tcl_DStringFree(&dstr); + + return res; +} + +char *caml_string_to_tcl( value s ) +{ + return external_to_utf( String_val(s) ); +} + +value tcl_string_to_caml( char *s ) +{ + CAMLparam0(); + CAMLlocal1(res); + char *str; + + str = utf_to_external( s ); + res = copy_string(str); + stat_free(str); + CAMLreturn(res); +} + +#else + +char *caml_string_to_tcl(value s){ return string_to_c(s); } +value tcl_string_to_caml(char *s){ return copy_string(s); } + +#endif diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c index eae7eb12f..971336850 100644 --- a/otherlibs/labltk/support/cltkVar.c +++ b/otherlibs/labltk/support/cltkVar.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -40,22 +40,28 @@ CAMLprim value camltk_getvar(value var) if (s == NULL) tk_error(cltclinterp->result); else - return(copy_string(s)); + return(tcl_string_to_caml(s)); } CAMLprim value camltk_setvar(value var, value contents) { char *s; char *stable_var = NULL; + char *utf_contents; CheckInit(); /* SetVar makes a copy of the contents. */ /* In case we have write traces in Caml, it's better to make sure that var doesn't move... */ stable_var = string_to_c(var); - s = Tcl_SetVar(cltclinterp,stable_var, String_val(contents), + utf_contents = caml_string_to_tcl(contents); + s = Tcl_SetVar(cltclinterp,stable_var, utf_contents, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); stat_free(stable_var); + if( s == utf_contents ){ + tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); + } + stat_free(utf_contents); if (s == NULL) tk_error(cltclinterp->result); @@ -68,12 +74,12 @@ CAMLprim value camltk_setvar(value var, value contents) typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *part1, char *part2, int flags)); */ -static char * tracevar(ClientData clientdata, Tcl_Interp *interp, - char *name1, char *name2, int flags) - /* Interpreter containing variable. */ - /* Name of variable. */ - /* Second part of variable name. */ - /* Information about what happened. */ +static char * tracevar(clientdata, interp, name1, name2, flags) + ClientData clientdata; + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ { Tcl_UntraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c index a39e62519..f562ff6e6 100644 --- a/otherlibs/labltk/support/cltkWait.c +++ b/otherlibs/labltk/support/cltkWait.c @@ -1,18 +1,18 @@ -/*************************************************************************/ -/* */ -/* Objective Caml LablTk library */ -/* */ -/* Francois Rouaix, Francois Pessaux and Jun Furuse */ -/* projet Cristal, INRIA Rocquencourt */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 1999 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. */ -/* */ -/*************************************************************************/ +/***********************************************************************/ +/* */ +/* 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. */ +/* */ +/***********************************************************************/ /* $Id$ */ @@ -44,8 +44,9 @@ struct WinCBData { Tk_Window win; }; -static void WaitVisibilityProc(ClientData clientData, XEvent *eventPtr) - /* Information about event (not used). */ +static void WaitVisibilityProc(clientData, eventPtr) + ClientData clientData; + XEvent *eventPtr; /* Information about event (not used). */ { struct WinCBData *vis = clientData; value cbid = Val_int(vis->cbid); diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml index 1db7b3a2e..9d985147c 100644 --- a/otherlibs/labltk/support/fileevent.ml +++ b/otherlibs/labltk/support/fileevent.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -22,11 +22,11 @@ open Protocol external add_file_input : file_descr -> cbid -> unit = "camltk_add_file_input" -external rem_file_input : file_descr -> unit +external rem_file_input : file_descr -> cbid -> unit = "camltk_rem_file_input" external add_file_output : file_descr -> cbid -> unit = "camltk_add_file_output" -external rem_file_output : file_descr -> unit +external rem_file_output : file_descr -> cbid -> unit = "camltk_rem_file_output" (* File input handlers *) @@ -35,8 +35,8 @@ let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *) let add_fileinput ~fd ~callback:f = let id = new_function_id () in - Hashtbl'.add callback_naming_table ~key:id ~data:(fun _ -> f()); - Hashtbl'.add fd_table ~key:(fd, 'r') ~data:id; + Hashtbl.add callback_naming_table id (fun _ -> f()); + Hashtbl.add fd_table (fd, 'r') id; if !Protocol.debug then begin Protocol.prerr_cbid id; prerr_endline " for fileinput" end; @@ -52,14 +52,14 @@ let remove_fileinput ~fd = Protocol.prerr_cbid id; prerr_endline " for fileinput" end; - rem_file_input fd + rem_file_input fd id with Not_found -> () let add_fileoutput ~fd ~callback:f = let id = new_function_id () in - Hashtbl'.add callback_naming_table ~key:id ~data:(fun _ -> f()); - Hashtbl'.add fd_table ~key:(fd, 'w') ~data:id; + Hashtbl.add callback_naming_table id (fun _ -> f()); + Hashtbl.add fd_table (fd, 'w') id; if !Protocol.debug then begin Protocol.prerr_cbid id; prerr_endline " for fileoutput" end; @@ -75,7 +75,7 @@ let remove_fileoutput ~fd = Protocol.prerr_cbid id; prerr_endline " for fileoutput" end; - rem_file_output fd + rem_file_output fd id with Not_found -> () diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli index 8b9af8833..34760f0c7 100644 --- a/otherlibs/labltk/support/fileevent.mli +++ b/otherlibs/labltk/support/fileevent.mli @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml index cb8bcbb33..e6c378504 100644 --- a/otherlibs/labltk/support/protocol.ml +++ b/otherlibs/labltk/support/protocol.ml @@ -1,22 +1,21 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) -open StdLabels open Support open Widget @@ -30,7 +29,7 @@ type tkArgs = type cbid = int -external opentk : display:string -> clas:string -> unit +external opentk_low : string list -> unit = "camltk_opentk" external tcl_eval : string -> string = "camltk_tcl_eval" @@ -44,6 +43,11 @@ external tkreturn : string -> unit = "camltk_return" external callback_init : unit -> unit = "camltk_init" +external finalizeTk : unit -> unit + = "camltk_finalize" + (* Finalize tcl/tk before exiting. This function will be automatically + called when you call [Pervasives.exit ()] (This is installed at + [install_cleanup ()] *) let tcl_command s = ignore (tcl_eval s);; @@ -60,10 +64,10 @@ let debug = let dump_args args = let rec print_arg = function TkToken s -> prerr_string s; prerr_string " " - | TkTokenList l -> List.iter ~f:print_arg l + | TkTokenList l -> List.iter print_arg l | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " in - Array.iter ~f:print_arg args; + Array.iter print_arg args; prerr_newline() (* @@ -86,14 +90,15 @@ let tkCommand args = ignore (tkEval args) * Callbacks *) +(* LablTk only *) let cCAMLtoTKwidget w = + (* Widget.check_class w table; (* with subtyping, it is redundant *) *) TkToken (Widget.name w) let cTKtoCAMLwidget = function "" -> raise (Invalid_argument "cTKtoCAMLwidget") | s -> Widget.get_atom s - let callback_naming_table = (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) @@ -110,9 +115,9 @@ let string_of_cbid = string_of_int (* The callback should be cleared when w is destroyed *) let register_callback w ~callback:f = let id = new_function_id () in - Hashtbl'.add callback_naming_table ~key:id ~data:f; + Hashtbl.add callback_naming_table id f; if (forget_type w) <> (forget_type Widget.dummy) then - Hashtbl'.add callback_memo_table ~key:(forget_type w) ~data:id; + Hashtbl.add callback_memo_table (forget_type w) id; (string_of_cbid id) let clear_callback id = @@ -122,7 +127,7 @@ let clear_callback id = let remove_callbacks w = let w = forget_type w in let cb_ids = Hashtbl.find_all callback_memo_table w in - List.iter ~f:clear_callback cb_ids; + List.iter clear_callback cb_ids; for i = 1 to List.length cb_ids do Hashtbl.remove callback_memo_table w done @@ -143,13 +148,13 @@ let install_cleanup () = let call_destroy_hooks = function [wname] -> let w = cTKtoCAMLwidget wname in - List.iter ~f:(fun f -> f w) !destroy_hooks + List.iter (fun f -> f w) !destroy_hooks | _ -> raise (TkError "bad cleanup callback") in let fid = new_function_id () in - Hashtbl'.add callback_naming_table ~key:fid ~data:call_destroy_hooks; + Hashtbl.add callback_naming_table fid call_destroy_hooks; (* setup general destroy callback *) - tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}") - + tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}"); + at_exit finalizeTk let prerr_cbid id = prerr_string "camlcb "; prerr_int id @@ -158,7 +163,7 @@ let prerr_cbid id = let dispatch_callback id args = if !debug then begin prerr_cbid id; - List.iter ~f:(fun x -> prerr_string " "; prerr_string x) args; + List.iter (fun x -> prerr_string " "; prerr_string x) args; prerr_newline() end; (Hashtbl.find callback_naming_table id) args; @@ -166,11 +171,16 @@ let dispatch_callback id args = let protected_dispatch id args = try - Printexc.print (dispatch_callback id) args + dispatch_callback id args with - Out_of_memory -> raise Out_of_memory - | Sys.Break -> raise Sys.Break - | e -> flush Pervasives.stderr + | e -> + try + Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); + flush stderr; + (* raise x *) + with + Out_of_memory -> raise Out_of_memory + | Sys.Break -> raise Sys.Break let _ = Callback.register "camlcb" protected_dispatch @@ -178,12 +188,76 @@ let _ = Callback.register "camlcb" protected_dispatch let _ = callback_init () (* Different version of initialisation functions *) -(* Native opentk is [opentk display class] *) -let openTk ?(display = "") ?(clas = "LablTk") () = - opentk ~display ~clas; +let default_display_name = ref "" +let default_display () = !default_display_name + +let camltk_argv = ref [] + +(* options for Arg.parse *) +let keywords = [ + "-display", Arg.String (fun s -> + camltk_argv := "-display" :: s :: !camltk_argv), + "<disp> : X server to contact (CamlTk)"; + "-colormap", Arg.String (fun s -> + camltk_argv := "-colormap" :: s :: !camltk_argv), + "<colormap> : colormap to use (CamlTk)"; + "-geometry", Arg.String (fun s -> + camltk_argv := "-geometry" :: s :: !camltk_argv), + "<geom> : size and position (CamlTk)"; + "-name", Arg.String (fun s -> + camltk_argv := "-name" :: s :: !camltk_argv), + "<name> : application class (CamlTk)"; + "-sync", Arg.Unit (fun () -> + camltk_argv := "-sync" :: !camltk_argv), + ": sync mode (CamlTk)"; + "-use", Arg.String (fun s -> + camltk_argv := "-use" :: s :: !camltk_argv), + "<id> : parent window id (CamlTk)"; + "-window", Arg.String (fun s -> + camltk_argv := "-use" :: s :: !camltk_argv), + "<id> : parent window id (CamlTk)"; + "-visual", Arg.String (fun s -> + camltk_argv := "-visual" :: s :: !camltk_argv), + "<visual> : visual to use (CamlTk)" ] + +let opentk_with_args argv (* = [argv1;..;argvn] *) = + (* argv must be command line for wish *) + let argv0 = Sys.argv.(0) in + let rec find_display = function + | "-display" :: s :: xs -> s + | "-colormap" :: s :: xs -> find_display xs + | "-geometry" :: s :: xs -> find_display xs + | "-name" :: s :: xs -> find_display xs + | "-sync" :: xs -> find_display xs + | "-use" :: s :: xs -> find_display xs + | "-window" :: s :: xs -> find_display xs + | "-visual" :: s :: xs -> find_display xs + | "--" :: _ -> "" + | _ :: xs -> find_display xs + | [] -> "" + in + default_display_name := find_display argv; + opentk_low (argv0 :: argv); install_cleanup(); Widget.default_toplevel +let opentk () = + let argv0 = Sys.argv.(0) in + Arg.parse keywords (fun _ -> ()) argv0; + opentk_with_args !camltk_argv + +let openTkClass s = opentk_with_args ["-name"; s] +let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl] + +(*JPF CAMLTK/LABLTK? *) +let openTk ?(display = "") ?(clas = "LablTk") () = + let dispopt = + match display with + | "" -> [] + | _ -> ["-display"; display] + in + opentk_with_args (dispopt @ ["-name"; clas]) + (* Destroy all widgets, thus cleaning up table and exiting the loop *) let closeTk () = tcl_command "destroy ." diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli index c816ba029..c7ce3eaba 100644 --- a/otherlibs/labltk/support/protocol.mli +++ b/otherlibs/labltk/support/protocol.mli @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -39,18 +39,49 @@ val add_destroy_hook : (any widget -> unit) -> unit (* Opening, closing, and mainloop *) -val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget -val closeTk : unit -> unit -val mainLoop : unit -> unit +val default_display : unit -> string + +val opentk : unit -> toplevel widget + (* The basic initialization function. [opentk ()] parses automatically + the command line options and use the tk related options in them + such as "-display localhost:0" to initialize Tk applications. + Consult wish manpage about the supported options. *) + +val keywords : (string * Arg.spec * string) list + (* Command line parsing specification for Arg.parse, which contains + the standard Tcl/Tk command line options such as "-display" and "-name". + These Tk command line options are used by opentk *) + +val opentk_with_args : string list -> toplevel widget + (* [opentk_with_args argv] invokes [opentk] with the tk related + command line options given by [argv] to the executable program. *) + +val openTk : ?display:string -> ?clas:string -> unit -> toplevel widget + (* [openTk ~display:display ~clas:clas ()] is equivalent to + [opentk ["-display"; display; "-name"; clas]] *) + +(* Legacy opentk functions *) +val openTkClass: string -> toplevel widget + (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) +val openTkDisplayClass: string -> string -> toplevel widget + (* [openTkDisplayClass disp class] is equivalent to + [opentk ["-display"; disp; "-name"; class]] *) + +val closeTk : unit -> unit +val finalizeTk : unit -> unit + (* Finalize tcl/tk before exiting. This function will be automatically + called when you call [Pervasives.exit ()] *) + +val mainLoop : unit -> unit (* Direct evaluation of tcl code *) -val tkEval : tkArgs array -> string +val tkEval : tkArgs array -> string -val tkCommand : tkArgs array -> unit +val tkCommand : tkArgs array -> unit (* Returning a value from a Tcl callback *) -val tkreturn: string -> unit +val tkreturn: string -> unit (* Callbacks: this is private *) diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml new file mode 100644 index 000000000..4ddf1a301 --- /dev/null +++ b/otherlibs/labltk/support/rawwidget.ml @@ -0,0 +1,176 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +open Support + +(* + * Widgets + *) + +exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) + +(***************************************************) +(* Widgets *) +(* This 'a raw_widget will be 'a Widget.widget *) +(***************************************************) +type 'a raw_widget = + Untyped of string +| Typed of string * string + +type raw_any (* will be Widget.any *) +and button +and canvas +and checkbutton +and entry +and frame +and label +and listbox +and menu +and menubutton +and message +and radiobutton +and scale +and scrollbar +and text +and toplevel + +let forget_type w = (Obj.magic (w : 'a raw_widget) : raw_any raw_widget) +let coe = forget_type + +(* table of widgets *) +let table = (Hashtbl.create 401 : (string, raw_any raw_widget) Hashtbl.t) + +let name = function + Untyped s -> s + | Typed (s,_) -> s + +(* Normally all widgets are known *) +(* this is a provision for send commands to external tk processes *) +let known_class = function + Untyped _ -> "unknown" + | Typed (_,c) -> c + +(* This one is always created by opentk *) +let default_toplevel = + let wname = "." in + let w = Typed (wname, "toplevel") in + Hashtbl.add table wname w; + w + +(* Dummy widget to which global callbacks are associated *) +(* also passed around by camltotkoption when no widget in context *) +let dummy = + Untyped "dummy" + +let remove w = + Hashtbl.remove table (name w) + +(* Retype widgets returned from Tk *) +(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) +let get_atom s = + try + Hashtbl.find table s + with + Not_found -> Untyped s + +let naming_scheme = [ + "button", "b"; + "canvas", "ca"; + "checkbutton", "cb"; + "entry", "en"; + "frame", "f"; + "label", "l"; + "listbox", "li"; + "menu", "me"; + "menubutton", "mb"; + "message", "ms"; + "radiobutton", "rb"; + "scale", "sc"; + "scrollbar", "sb"; + "text", "t"; + "toplevel", "top" ] + + +let widget_any_table = List.map fst naming_scheme +(* subtypes *) +let widget_button_table = [ "button" ] +and widget_canvas_table = [ "canvas" ] +and widget_checkbutton_table = [ "checkbutton" ] +and widget_entry_table = [ "entry" ] +and widget_frame_table = [ "frame" ] +and widget_label_table = [ "label" ] +and widget_listbox_table = [ "listbox" ] +and widget_menu_table = [ "menu" ] +and widget_menubutton_table = [ "menubutton" ] +and widget_message_table = [ "message" ] +and widget_radiobutton_table = [ "radiobutton" ] +and widget_scale_table = [ "scale" ] +and widget_scrollbar_table = [ "scrollbar" ] +and widget_text_table = [ "text" ] +and widget_toplevel_table = [ "toplevel" ] + +let new_suffix clas n = + try + (List.assoc clas naming_scheme) ^ (string_of_int n) + with + Not_found -> "w" ^ (string_of_int n) + +(* The function called by generic creation *) +let counter = ref 0 +let new_atom ~parent ?name:nom clas = + let parentpath = name parent in + let path = + match nom with + None -> + incr counter; + if parentpath = "." + then "." ^ (new_suffix clas !counter) + else parentpath ^ "." ^ (new_suffix clas !counter) + | Some name -> + if parentpath = "." + then "." ^ name + else parentpath ^ "." ^ name + in + let w = Typed(path,clas) in + Hashtbl.add table path w; + w + +(* Just create a path. Only to check existence of widgets *) +(* Use with care *) +let atom ~parent ~name:pathcomp = + let parentpath = name parent in + let path = + if parentpath = "." + then "." ^ pathcomp + else parentpath ^ "." ^ pathcomp in + Untyped path + +(* LablTk: Redundant with subtyping of Widget, backward compatibility *) +let check_class w clas = + match w with + Untyped _ -> () (* assume run-time check by tk*) + | Typed(_,c) -> + if List.mem c clas then () + else raise (IllegalWidgetType c) + + +(* Checking membership of constructor in subtype table *) +let chk_sub errname table c = + if List.mem c table then () + else raise (Invalid_argument errname) diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli new file mode 100644 index 000000000..7a7857dc7 --- /dev/null +++ b/otherlibs/labltk/support/rawwidget.mli @@ -0,0 +1,109 @@ +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* Support for widget manipulations *) + +type 'a raw_widget + (* widget is an abstract type *) + +type raw_any +and button +and canvas +and checkbutton +and entry +and frame +and label +and listbox +and menu +and menubutton +and message +and radiobutton +and scale +and scrollbar +and text +and toplevel + +val forget_type : 'a raw_widget -> raw_any raw_widget +val coe : 'a raw_widget -> raw_any raw_widget + +val default_toplevel : toplevel raw_widget + (* [default_toplevel] is "." in Tk, the toplevel widget that is + always existing during a Tk session. Destroying [default_toplevel] + ends the main loop + *) + +val atom : parent: 'a raw_widget -> name: string -> raw_any raw_widget + (* [atom parent name] returns the widget [parent.name]. The widget is + not created. Only its name is returned. In a given parent, there may + only exist one children for a given name. + This function should only be used to check the existence of a widget + with a known name. It doesn't add the widget to the internal tables + of CamlTk. + *) + +val name : 'a raw_widget -> string + (* [name w] returns the name (tk "path") of a widget *) + +(*--*) +(* The following functions are used internally. + There is normally no need for them in users programs + *) + +val known_class : 'a raw_widget -> string + (* [known_class w] returns the class of a widget (e.g. toplevel, frame), + as known by the CamlTk interface. + Not equivalent to "winfo w" in Tk. + *) + +val dummy : raw_any raw_widget + (* [dummy] is a widget used as context when we don't have any. + It is *not* a real widget. + *) + +val new_atom : parent:'a raw_widget -> ?name: string -> string -> 'b raw_widget + +val get_atom : string -> raw_any raw_widget + (* [get_atom path] returns the widget with Tk path [path] *) + +val remove : 'a raw_widget -> unit + (* [remove w] removes widget from the internal tables *) + +(* Subtypes tables *) +val widget_any_table : string list +val widget_button_table : string list +val widget_canvas_table : string list +val widget_checkbutton_table : string list +val widget_entry_table : string list +val widget_frame_table : string list +val widget_label_table : string list +val widget_listbox_table : string list +val widget_menu_table : string list +val widget_menubutton_table : string list +val widget_message_table : string list +val widget_radiobutton_table : string list +val widget_scale_table : string list +val widget_scrollbar_table : string list +val widget_text_table : string list +val widget_toplevel_table : string list + +val chk_sub : string -> 'a list -> 'a -> unit +val check_class : 'a raw_widget -> string list -> unit + (* Widget subtyping *) + +exception IllegalWidgetType of string + (* Raised when widget command applied illegally*) diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml index 8169f1f18..b994fe17e 100644 --- a/otherlibs/labltk/support/slave.ml +++ b/otherlibs/labltk/support/slave.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml index b0b028830..c8bebc2fc 100644 --- a/otherlibs/labltk/support/support.ml +++ b/otherlibs/labltk/support/support.ml @@ -1,23 +1,21 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) -open StdLabels - (* Parsing results of Tcl *) (* List.split a string according to char_sep predicate *) let split_str ~pred:char_sep str = @@ -29,11 +27,11 @@ let split_str ~pred:char_sep str = let rec split beg cur = if cur >= len then if beg = cur then [] - else [String.sub str ~pos:beg ~len:(len - beg)] + else [String.sub str beg (len - beg)] else if char_sep str.[cur] then let nextw = skip_sep cur in - (String.sub str ~pos:beg ~len:(cur - beg)) + (String.sub str beg (cur - beg)) ::(split nextw nextw) else split beg (succ cur) in let wstart = skip_sep 0 in @@ -48,7 +46,3 @@ let maycons f x l = match x with Some x -> f x :: l | None -> l - -(* Get some labels on Hashtbl.add *) -module Hashtbl' = - struct let add tbl ~key ~data = Hashtbl.add tbl key data end diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli index 92a89ca8f..95a2255cb 100644 --- a/otherlibs/labltk/support/support.mli +++ b/otherlibs/labltk/support/support.mli @@ -1,23 +1,21 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) val split_str : pred:(char -> bool) -> string -> string list val may : ('a -> 'b) -> 'a option -> 'b option val maycons : ('a -> 'b) -> 'a option -> 'b list -> 'b list -module Hashtbl' : - sig val add : ('a, 'b) Hashtbl.t -> key:'a -> data:'b -> unit end diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml index cb3f8c7f7..af272e682 100644 --- a/otherlibs/labltk/support/textvariable.ml +++ b/otherlibs/labltk/support/textvariable.ml @@ -1,22 +1,21 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) -open StdLabels open Support open Protocol @@ -39,7 +38,7 @@ let add_handle var cbid = r := cbid :: !r with Not_found -> - Hashtbl'.add handles var (ref [cbid]) + Hashtbl.add handles var (ref [cbid]) let exceptq x = let rec ex acc = function @@ -64,7 +63,7 @@ let rem_handle var cbid = let rem_all_handles var = try let r = Hashtbl.find handles var in - List.iter ~f:(internal_untracevar var) !r; + List.iter (internal_untracevar var) !r; Hashtbl.remove handles var with Not_found -> () @@ -77,7 +76,7 @@ let handle vname ~callback:f = clear_callback id; rem_handle vname id; f() in - Hashtbl'.add callback_naming_table ~key:id ~data:wrapped; + Hashtbl.add callback_naming_table id wrapped; add_handle vname id; if !Protocol.debug then begin prerr_cbid id; prerr_string " for variable "; prerr_endline vname @@ -97,9 +96,9 @@ let add w v = try Hashtbl.find memo w with Not_found -> - let r = ref StringSet.empty in - Hashtbl'.add memo ~key:w ~data:r; - r in + let r = ref StringSet.empty in + Hashtbl.add memo w r; + r in r := StringSet.add v !r (* to be used with care ! *) diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli index 900106e52..09a19148a 100644 --- a/otherlibs/labltk/support/textvariable.mli +++ b/otherlibs/labltk/support/textvariable.mli @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml index 96fd44474..1d15c1afd 100644 --- a/otherlibs/labltk/support/timer.ml +++ b/otherlibs/labltk/support/timer.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) @@ -35,7 +35,7 @@ let add ~ms ~callback = let wrapped _ = clear_callback id; (* do it first in case f raises exception *) callback() in - Hashtbl'.add callback_naming_table ~key:id ~data:wrapped; + Hashtbl.add callback_naming_table id wrapped; if !Protocol.debug then begin prerr_cbid id; prerr_endline " for timer" end; diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli index 168d6d553..a45e1c9d2 100644 --- a/otherlibs/labltk/support/timer.mli +++ b/otherlibs/labltk/support/timer.mli @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml index 3d886c2ed..2574928c0 100644 --- a/otherlibs/labltk/support/tkwait.ml +++ b/otherlibs/labltk/support/tkwait.ml @@ -1,18 +1,18 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml index b9379b146..65e0d26a9 100644 --- a/otherlibs/labltk/support/widget.ml +++ b/otherlibs/labltk/support/widget.ml @@ -1,179 +1,23 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) -open StdLabels -open Support - -(* - * Widgets - *) - -exception IllegalWidgetType of string - (* Raised when widget command applied illegally*) - -(***************************************************) -(* Widgets *) -(***************************************************) -type 'a widget = - Untyped of string -| Typed of string * string - -type any -and button -and canvas -and checkbutton -and entry -and frame -and label -and listbox -and menu -and menubutton -and message -and radiobutton -and scale -and scrollbar -and text -and toplevel - -let forget_type w = (Obj.magic (w : 'a widget) : any widget) -let coe = forget_type - -(* table of widgets *) -let table = (Hashtbl.create 401 : (string, any widget) Hashtbl.t) - -let name = function - Untyped s -> s - | Typed (s,_) -> s - -(* Normally all widgets are known *) -(* this is a provision for send commands to external tk processes *) -let known_class = function - Untyped _ -> "unknown" - | Typed (_,c) -> c - -(* This one is always created by opentk *) -let default_toplevel = - let wname = "." in - let w = Typed (wname, "toplevel") in - Hashtbl'.add table ~key:wname ~data:w; - w - -(* Dummy widget to which global callbacks are associated *) -(* also passed around by camltotkoption when no widget in context *) -let dummy = - Untyped "dummy" - -let remove w = - Hashtbl.remove table (name w) - -(* Retype widgets returned from Tk *) -(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *) -let get_atom s = - try - Hashtbl.find table s - with - Not_found -> Untyped s - -let naming_scheme = [ - "button", "b"; - "canvas", "ca"; - "checkbutton", "cb"; - "entry", "en"; - "frame", "f"; - "label", "l"; - "listbox", "li"; - "menu", "me"; - "menubutton", "mb"; - "message", "ms"; - "radiobutton", "rb"; - "scale", "sc"; - "scrollbar", "sb"; - "text", "t"; - "toplevel", "top" ] - - -let widget_any_table = List.map ~f:fst naming_scheme -(* subtypes *) -let widget_button_table = [ "button" ] -and widget_canvas_table = [ "canvas" ] -and widget_checkbutton_table = [ "checkbutton" ] -and widget_entry_table = [ "entry" ] -and widget_frame_table = [ "frame" ] -and widget_label_table = [ "label" ] -and widget_listbox_table = [ "listbox" ] -and widget_menu_table = [ "menu" ] -and widget_menubutton_table = [ "menubutton" ] -and widget_message_table = [ "message" ] -and widget_radiobutton_table = [ "radiobutton" ] -and widget_scale_table = [ "scale" ] -and widget_scrollbar_table = [ "scrollbar" ] -and widget_text_table = [ "text" ] -and widget_toplevel_table = [ "toplevel" ] - -let new_suffix clas n = - try - (List.assoc clas naming_scheme) ^ (string_of_int n) - with - Not_found -> "w" ^ (string_of_int n) - - -(* The function called by generic creation *) -let counter = ref 0 -let new_atom ~parent ?name:nom clas = - let parentpath = name parent in - let path = - match nom with - None -> - incr counter; - if parentpath = "." - then "." ^ (new_suffix clas !counter) - else parentpath ^ "." ^ (new_suffix clas !counter) - | Some name -> - if parentpath = "." - then "." ^ (new_suffix clas !counter) - else parentpath ^ "." ^ name - in - let w = Typed(path,clas) in - Hashtbl'.add table ~key:path ~data:w; - w - -(* Just create a path. Only to check existence of widgets *) -(* Use with care *) -let atom ~parent ~name:pathcomp = - let parentpath = name parent in - let path = - if parentpath = "." - then "." ^ pathcomp - else parentpath ^ "." ^ pathcomp in - Untyped path - - - -(* Redundant with subtyping of Widget, backward compatibility *) -let check_class w clas = - match w with - Untyped _ -> () (* assume run-time check by tk*) - | Typed(_,c) -> - if List.mem c clas then () - else raise (IllegalWidgetType c) - - -(* Checking membership of constructor in subtype table *) -let chk_sub errname table c = - if List.mem c table then () - else raise (Invalid_argument errname) +(* Hack to permit having the different data type with the same name + [widget] for CamlTk and LablTk. *) +include Rawwidget +type 'a widget = 'a raw_widget +type any = raw_any diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli index 326fc6b04..fd3b461c2 100644 --- a/otherlibs/labltk/support/widget.mli +++ b/otherlibs/labltk/support/widget.mli @@ -1,27 +1,27 @@ -(*************************************************************************) -(* *) -(* Objective Caml LablTk library *) -(* *) -(* Francois Rouaix, Francois Pessaux and Jun Furuse *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 1999 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. *) -(* *) -(*************************************************************************) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) (* $Id$ *) (* Support for widget manipulations *) -type 'a widget +type 'a widget = 'a Rawwidget.raw_widget (* widget is an abstract type *) -type any +type any = Rawwidget.raw_any and button and canvas and checkbutton diff --git a/otherlibs/labltk/tkanim/.depend b/otherlibs/labltk/tkanim/.depend new file mode 100644 index 000000000..600934779 --- /dev/null +++ b/otherlibs/labltk/tkanim/.depend @@ -0,0 +1,2 @@ +tkanim.cmo: tkanim.cmi +tkanim.cmx: tkanim.cmi diff --git a/otherlibs/labltk/tkanim/Makefile b/otherlibs/labltk/tkanim/Makefile new file mode 100644 index 000000000..288712a82 --- /dev/null +++ b/otherlibs/labltk/tkanim/Makefile @@ -0,0 +1,65 @@ +include ../support/Makefile.common + +COMPFLAGS=-I ../../../byterun -I ../support -I ../camltk -I ../../unix -ccopt "$(TK_DEFS)" + +all: tkanim.cma libtkanim.a +opt: tkanim.cmxa libtkanim.a +example: gifanimtest + +OBJS=tkanim.cmo +COBJS= cltkaniminit.o tkAnimGIF.o + +tkanim.cma: $(OBJS) + $(MKLIB) -ocamlc '$(CAMLC)' -o tkanim -oc tkanim \ + $(OBJS) $(TK_LINK) $(X11_LINK) + +tkanim.cmxa: $(OBJS:.cmo=.cmx) + $(MKLIB) -ocamlopt '$(CAMLOPT)' -o tkanim -oc tkanim \ + $(OBJS:.cmo=.cmx) $(TK_LINK) $(X11_LINK) + +libtkanim.a: $(COBJS) + $(MKLIB) -o tkanim $(COBJS) $(TK_LINK) $(X11_LINK) + +gifanimtest: all gifanimtest.cmo + $(CAMLC) -o $@ -I ../lib -I ../support -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.so animwish gifanimtest + +.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: + $(CAMLCOMP) -c $(X_CFLAGS) $(COMPFLAGS) $(TCLTKINCLUDES) $< + + +install: tkanim.cma + cp tkanim.cma *.cmi *.mli libtkanim.a $(INSTALLDIR) + if [ -f dlltkanim.so ]; then \ + cp dlltkanim.so $(INSTALLDIR); \ + fi + +installopt: tkanim.cmxa + 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 new file mode 100644 index 000000000..8f2291133 --- /dev/null +++ b/otherlibs/labltk/tkanim/Makefile.nt @@ -0,0 +1,76 @@ +!include ..\support\Makefile.common.nt + +CCFLAGS=-I..\support -I..\..\..\byterun $(TK_DEFS) + +COMPFLAGS=-I $(OTHERS)/win32unix -I ../support -I ../camltk + +all: tkanim.cma dlltkanim.dll libtkanim.lib +opt: tkanim.cmxa libtkanim.lib +example: gifanimtest.exe + +OBJS=tkanim.cmo +COBJS= cltkaniminit.obj tkAnimGIF.obj + +tkanim.cma: $(OBJS) + $(CAMLLIBR) -o tkanim.cma $(OBJS) \ + -dllib -ltkanim -cclib -ltkanim $(TK_LINK) + +tkanim.cmxa: $(OBJS:.cmo=.cmx) + $(CAMLOPTLIBR) -o tkanim.cmxa $(OBJS:.cmo=.cmx) \ + -cclib -ltkanim $(TK_LINK) + +libtkanim.lib: $(COBJS:.obj=.sobj) + rm -f libtkanim.lib + $(MKLIB)libtkanim.lib $(COBJS:.obj=.sobj) + +dlltkanim.dll: $(COBJS:.obj=.dobj) + link /nologo /dll /out:dlltkanim.dll /implib:tmp.lib \ + $(COBJS:.obj=.dobj) ..\support\dll$(LIBNAME).lib \ + ..\..\..\byterun\ocamlrun.lib \ + $(TK_LINK) wsock32.lib + rm tmp.* + +gifanimtest.exe: all gifanimtest.cmo + $(CAMLC) -custom -o $@ -I ../lib -I ../camltk -I ../support unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo + +# animwish: $(TKANIM_LIB) tkAppInit.o +# $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \ +# -L. -ltkanim $(LIBS) + +clean: + rm -f *.cm* *.obj *.dobj *.sobj *.lib *.dll gifanimtest.exe + +$(OBJS) $(OBJS:.cmo=.cmi): ..\lib\$(LIBNAME).cma + +$(OBJS:.cmo=.cmx): ..\lib\$(LIBNAME).cmxa + +.SUFFIXES : +.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .dobj .sobj + +.mli.cmi: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLCOMP) $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +.c.dobj: + $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $< + mv $*.obj $*.dobj + +.c.sobj: + $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< + mv $*.obj $*.sobj + +install: tkanim.cma + cp tkanim.cma *.cmi *.mli libtkanim.lib dlltkanim.dll $(INSTALLDIR) + +installopt: tkanim.cmxa + cp tkanim.cmxa $(INSTALLDIR) + +depend: tkanim.ml + $(CAMLDEP) *.mli *.ml > .depend + +!include .depend diff --git a/otherlibs/labltk/tkanim/README b/otherlibs/labltk/tkanim/README new file mode 100644 index 000000000..175401f30 --- /dev/null +++ b/otherlibs/labltk/tkanim/README @@ -0,0 +1,5 @@ +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 new file mode 100644 index 000000000..773407f4f --- /dev/null +++ b/otherlibs/labltk/tkanim/cltkaniminit.c @@ -0,0 +1,26 @@ +/***********************************************************************/ +/* */ +/* 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" + +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 new file mode 100644 index 000000000..acd51c80b --- /dev/null +++ b/otherlibs/labltk/tkanim/gifanimtest.ml @@ -0,0 +1,71 @@ +(***********************************************************************) +(* *) +(* 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/mmm.anim.gif b/otherlibs/labltk/tkanim/mmm.anim.gif Binary files differnew file mode 100644 index 000000000..daeee00ee --- /dev/null +++ b/otherlibs/labltk/tkanim/mmm.anim.gif diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c new file mode 100644 index 000000000..a606fc40f --- /dev/null +++ b/otherlibs/labltk/tkanim/tkAnimGIF.c @@ -0,0 +1,906 @@ +/***********************************************************************/ +/* */ +/* 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 prevpos; + 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", widthbuf, + "-height", 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(photoHandle, &block, 0, 0, + imageWidth, imageHeight); +#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 new file mode 100644 index 000000000..932a37fc1 --- /dev/null +++ b/otherlibs/labltk/tkanim/tkAppInit.c @@ -0,0 +1,141 @@ +/***********************************************************************/ +/* */ +/* 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 new file mode 100644 index 000000000..cc859e1cf --- /dev/null +++ b/otherlibs/labltk/tkanim/tkanim.ml @@ -0,0 +1,230 @@ +(***********************************************************************) +(* *) +(* 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 "/tmp" 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 new file mode 100644 index 000000000..26f425035 --- /dev/null +++ b/otherlibs/labltk/tkanim/tkanim.mli @@ -0,0 +1,95 @@ +(***********************************************************************) +(* *) +(* 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. *) |
