\ *** X-Windows Widgets for bigFORTH *** 25aug96py \ Copyright (C) 1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 Bernd Paysan \ This file is part of MINOS \ MINOS is free software; you can redistribute it and/or \ modify it under the terms of the GNU Lesser General Public License \ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, \ but WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the \ GNU Lesser General Public License for more details. \ You should have received a copy of the GNU Lesser General Public License \ along with this program; if not, see http://www.gnu.org/licenses/. \ generic loadscreen 21sep07py [defined] VFXFORTH [IF] include vfx-minos/VFXharness.fth include vfx-minos/oof.fs include sincos.fs include vfx-minos/points.fs include vfx-minos/string.fs include vfx-minos/xchar.fs include vfx-minos/accept.fs include i18n.fs include vfx-minos/struct.fs [ELSE] \needs { include locals.fs \needs object include oof.fb \needs [: include lambda.fs include sincos.fs \needs >xyxy include points.fs \needs sort include qsort.fs \needs $! include string.fs \needs xc@+ include utf-8.fs \needs l" include i18n.fs \needs substitute include substitute.fs ' /string Alias safe/string [THEN] \ useful utilities 09jan00py [defined] bigFORTH [IF] Code pin ( x n -- ) DX pop DX SP AX *4 I) mov AX pop Next end-code macro :dx :ax T&P $7FFFFFFF | Constant mi : 0max dup 0>= and ; : 0min dup 0< and ; Code 8* ( n -- 8*n ) 3 # AX sal Next end-code macro Code 3* ( n -- 3*n ) AX AX *2 I) AX lea Next end-code macro Synonym */f */ Synonym /modf /mod Synonym /f / Synonym modf mod \ : till postpone timer@ postpone over postpone - postpone ~~ \ postpone drop postpone till postpone ~~ ; immediate [THEN] \ class utility 01jan00py [defined] >class" 0= [IF] | : cell-@ dup IF cell- @ THEN ; : parent@ ( object -- parent ) >o object parento @ cell-@ o> ; : child@ ( object -- child ) >o object childo @ cell-@ o> ; : next@ ( child -- next ) >o object nexto @ cell-@ o> ; : object" ( object -- addr n ) body> >name count $1F and ; : >class" ( object -- addr n ) dup @ swap parent@ child@ BEGIN 2dup @ <> WHILE next@ dup 0= UNTIL 2drop s" ---" EXIT THEN nip object" ; : lctype bounds ?DO I c@ tolower emit LOOP ; Patch .class :noname cr ." class: " base push hex ^ . ^ >class" lctype ~~ ; IS .class \ :noname ( object -- ) >class" lctype cr ; IS .class [THEN] [defined] unix [IF] \ Loadscreen for X11 21sep07py [defined] VFXFORTH [IF] include vfx-minos/x11.fs include vfx-minos/xrender.fs include vfx-minos/xpm.fs include vfx-minos/opengl.fs include x.fs include glconst.fs include vfx-minos/splines.fs [ELSE] \needs x11 include x11.fs \needs xrender include xrender.fs \needs xpm include xpm.fs \needs opengl include opengl.fs \needs xconst | import xconst \needs glconst | import glconst \needs >bezier 1 loadfrom splines.fb [THEN] Onlyforth Module MINOS Memory also x11 also xrender also xconst also Forth also MINOS [THEN] [defined] win32 [IF] \ Loadscreen for win32 21sep07py \needs struct{ include struct.fs \needs win32api include win32.fs \needs opengl include opengl.fs \needs glconst include glconst.fs \needs >bezier 1 loadfrom splines.fb include win32ex.fs Onlyforth Module MINOS Memory also win32api also Forth also MINOS [THEN] include minos-base.fs include displays.fs include minos-fonts.fs include vdisplays.fs include actors.fs include widgets.fs include minos-boxes.fs include minos-buttons.fs include minos-viewport.fs include minos-windows.fs include resources.fs include minos-complex.fs \ win-init 07jan07py : clear-resources ( -- ) clear-icons clear-fonts [defined] term [IF] 0 bind term [THEN] 0 to scratch ; [defined] x11 [IF] also DOS : win-init ( -- ) !time clear-resources xresource new xresource with s" DISPLAY" env$ 0= IF drop s" :0.0" THEN open connect colors ^ endwith displays new bind screen screen xrc dpy @ 0" STRING" 0 XInternAtom to XA_STRING8 screen xrc dpy @ maxascii $80 = IF 0" UTF8_STRING" ELSE 0" STRING" THEN 0 XInternAtom to XA_STRING screen timeoffset screen xrc timeoffset ! screen xrc calibrate XTime screen lastcal ! normal-font 'nilscreen screen bind parent get-pixmap-format pixmap-format @ 1 = IF mono THEN ; previous [THEN] \ win-init 07jan07py [defined] win32 [IF] ficon: minos-win icons/minos1+.icn" : win-init ( -- ) !time clear-resources xresource new xresource with IDI_APPLICATION 0 LoadIcon register \ minos-win icon-pixmap with \ image @ shape @ &24 1 h @ w @ \ endwith inst @ CreateIcon register get-sys-colors colors ^ endwith displays new bind screen normal-font 'nilscreen screen bind parent ; [THEN] \ main: cold: bye: 10apr04py [defined] VFXFORTH 0= [IF] main: ['] WINi/o IS standardi/o ; [defined] x11 [IF] cold: win-init ; [THEN] [defined] win32 [IF] cold: set-exceptions win-init ; [THEN] : event-loop BEGIN stop apprefcnt @ 0<= UNTIL ; [ELSE] Defer font-init ' noop IS font-init :noname font-init win-init ; atcold : minos-entry 2drop 2drop true to script? interpret-args false to script? WinI/O .cold quit ; ASSIGN minos-entry TO-DO entrypoint Create fds here $400 8 / dup allot erase Create >timeout 0 , 0 , extern: int select( int , void * , void * , void * , void * ); : unix-wait ( fid ms -- ) #1000 um* #1000000 um/mod >timeout 2! fds $80 erase fds swap +bit $400 fds 0 0 >timeout select drop ; : minos-idle screen handle-events ; :noname ( fid ms -- ) unix-wait minos-idle ; IS idle \ [defined] busy-idle [IF] ' minos-idle IS busy-idle [THEN] : event-loop ( -- ) BEGIN screen with handle-event invoke do-idle endwith apprefcnt @ 0= UNTIL ; [THEN] \ init sequence 10apr04py [defined] x11 [IF] : "geometry ( addr u -- ) scratch 0place 0 sp@ >r 0 0 0 scratch r> dup cell- dup cell- dup cell- XParseGeometry >r r@ [ WidthValue HeightValue or ] Literal tuck and = IF map-size 2! ELSE 2drop THEN r> [ XValue YValue or ] Literal tuck and = IF map-pos 2! ELSE 2drop THEN 2 ; : -geometry ( -- ) bl word count "geometry drop ; also -options definitions synonym -geometry "geometry previous definitions [defined] VFXFORTH 0= [IF] export minos -geometry ; [THEN] [THEN] [defined] unix [IF] include xstyle.fs toss toss toss toss toss [defined] VFXForth [IF] Forth definitions [ELSE] Module; [THEN] [THEN] [defined] win32 [IF] include xstyle.fs include w95style.fs toss toss toss Module; [THEN]