\ viewport 02jan05py $20 Value /mslide backing class viewport public: 0 var org private: cell var orgy cell var orgx 2 cells var steps public: cell var sw cell var sh cell var hstep cell var vstep cell var minw cell var minh 2 cells var cliprec method 'hslide method 'vslide method slided hslider ptr hspos vslider ptr vspos early hslide early vslide method xpos! method ypos! \ viewport 28mar99py how: : init ( sx sy -- ) noback on super init 2dup steps 2! vstep ! hstep ! ; : trans ( x y -- x' y' ) orgx @ hstep @ * x @ - orgy @ vstep @ * y @ - p+ ; : trans' ( x y -- x' y' ) orgx @ hstep @ * x @ - orgy @ vstep @ * y @ - p- ; : r xrc dpy @ xwin @ dummy dup dup r> dup cell+ dummy over cell+ XGetGeometry drop * * 3 >> maxpixmap + TO maxpixmap xrc dpy @ xwin @ XFreePixmap THEN xwin off noback @ ?EXIT xrc depth @ dup h @ w @ * * 3 >> dup maxpixmap > IF 2drop EXIT THEN maxpixmap swap - TO maxpixmap h @ 1 max w @ 1 max screen xwin @ xrc dpy @ XCreatePixmap xwin ! ; [THEN] \ viewport 21oct99py : ?incbase ( b i -- ) dup 1 = IF 2drop 0 1 THEN ; : !steps child xinc ?incbase steps cell+ @ * hstep ! minw ! child yinc ?incbase steps @ * vstep ! minh ! ; : resized ( -- ) get-glues hglues cell+ @ sw @ max w ! vglues cell+ @ sh @ max h ! !steps parent resized ( dpy resized ) ; : resize ( x y w h -- ) sh ! sw ! y ! x ! hglues cell+ @ sw @ max w ! vglues cell+ @ sh @ max h ! & glue @ child class? 0= IF 0 0 w @ h @ child resize create-pixmap xwin @ IF flags #draw 2dup bit@ >r -bit child draw r> IF flags #draw +bit THEN THEN THEN hslide -rot - min vslide -rot - min org 2! ; \ viewport 28mar99py : hglue ( -- g ) hstep @ hglues 2@ + over - over minw @ - 0min + swap minw @ max swap ; : vglue ( -- g ) vstep @ vglues 2@ + over - over minh @ - 0min + swap minh @ max swap ; : dpy! bind dpy xrc self IF xrc dispose THEN dpy xrc clone bind xrc create-pixmap [defined] x11 [IF] get-win xrc get-gc [THEN] 0 clip-rect flags #draw +bit self child dpy! child hglue 2dup hglues 2! drop child vglue 2dup vglues 2! drop !steps 2dup h ! w ! 0 0 2swap child resize ; \ viewport 09nov97py : clipx ( -- x w ) xwin @ 0= IF orgx @ hstep @ * sw @ cliprec 2@ d0= 0= IF 0 and cliprec w@+ 2+ w@ p+ THEN ELSE 0 w @ THEN ; : clipy ( -- y h ) xwin @ 0= IF orgy @ vstep @ * sh @ cliprec 2@ d0= 0= IF 0 and cliprec 2+ w@+ 2+ w@ p+ THEN ELSE 0 h @ THEN ; : clipxywh ( -- x y w h ) cliprec 2@ d0= IF xywh ELSE cliprec w@+ w@+ w@+ w@ 2swap x @ y @ p+ 2swap THEN ; \ viewport 27mar99py : clipxy ( x y d -- x' y' ) clipxywh { d x y w h } x y p- swap w d + min d max swap h d + min d max x y p+ ; : clip ( x y w h -- x y w h ) >xyxy 2swap 0 clipxy 2swap -1 clipxy >xywh ; : !resized super !resized !steps ; : inclip? ( x y -- flag ) trans' $-8000 $8000 within swap $-8000 $8000 within and ; \ viewport 17dec00py : draw ( -- ) clip-should @ IF xrect w@+ w@+ >r trans' r> w@+ w@ clip 2swap 2drop 0= swap 0= or ?EXIT THEN xwin @ IF orgx @ hstep @ * orgy @ vstep @ * xywh 2swap xwin @ dpy image ELSE child draw THEN ; : assign ( widget -- ) set-child self child dpy! child hglue 2dup hglues 2! drop child vglue 2dup vglues 2! drop !steps 2dup h ! w ! 0 0 2swap child resize parent resized ; \ viewport 24jan98py : r trans' r> w@+ w@ clip ELSE clipxywh THEN swap 2swap dpy with clip-should @ dpy clip-is @ = IF xwin @ 0= IF transback THEN THEN endwith swap dpy xrect w!+ w!+ w!+ w! dpy xrect dpy clip-rect clip-should @ clip-is ! dpy clip-should @ dpy clip-is ! ; \ viewport 25jul98py : clip> ( -- ) dpy clip-should off 0 0 dpy txy! xwin @ 0= ?EXIT 0 clip-rect clip-is off clip-should off dpy clip-is off ; : xinc 0 hstep @ ; : yinc 0 vstep @ ; : >exposed xwin @ 0= IF dpy >exposed THEN ; : xywh ( -- x y w h ) x @ y @ sw @ sh @ ; : clipback ( x y w h -- x' y' w' h' ) dpy with xwin @ 0= IF 2swap trans' 2swap clip recurse 2swap trans 2swap THEN endwith ; \ viewport 02jan05py : (xpos! { o x0 y0 x y w h } x o 0max + y dpy transback w o abs - h x o 0min - y dpy get-win dpy image \ dpy >exposed h o abs 0 y y0 - 0max o 0> IF w + o - THEN x x0 - 0max + cliprec w!+ w!+ w!+ w! ; : xpos! ( p -- ) orgx @ case? 0= IF orgx @ over orgx ! - hstep @ * dup abs sw @ < IF clipxywh 2over 2swap clipback (xpos! ELSE drop THEN draw 0. cliprec 2! THEN ; \ viewport 02jan05py : (ypos! { o x0 y0 x y w h } x y o 0max + dpy transback w h o abs - x y o 0min - dpy get-win dpy image \ dpy >exposed o abs w 0 o 0> IF h + o - THEN y y0 - 0max + x x0 - 0max cliprec w!+ w!+ w!+ w! ; : ypos! ( p -- ) orgy @ case? 0= IF orgy @ over orgy ! - vstep @ * dup abs sh @ < IF clipxywh 2over 2swap clipback (ypos! ELSE drop THEN draw 0. cliprec 2! THEN ; : 'hslide self ['] xpos! ['] hslide toggle-state new ; : 'vslide self ['] ypos! ['] vslide toggle-state new ; \ viewport 20oct99py : line ( x y x y color -- ) >r 2dup inclip? IF xwin @ IF 2over 2over r@ super super line THEN flags #draw bit@ IF 2over trans' 2over trans' r@ THEN THEN rdrop 2drop 2drop ; : text ( addr u x y color -- ) >r 2dup inclip? IF xwin @ IF 2over 2over r@ super super text THEN flags #draw bit@ IF 2over 2over trans' r@ THEN THEN rdrop 2drop 2drop ; : box ( x y w h color -- ) >r xwin @ IF 2over 2over r@ super super box THEN flags #draw bit@ IF 2over trans' 2over clip r@ THEN rdrop 2drop 2drop ; \ viewport 28jun98py : image ( x y w h x y win -- ) >r 2dup inclip? IF xwin @ IF [ 5 ] [FOR] 5 pick [NEXT] r@ super super image THEN flags #draw bit@ IF r@ xwin @ = IF draw ELSE [ 5 ] [FOR] 5 pick [NEXT] trans' r@ THEN THEN THEN rdrop 2drop 2drop 2drop ; : mask ( x y w h x y win1 win2 -- ) 2over inclip? IF xwin @ IF [ 7 ] [FOR] 7 pick [NEXT] super super mask THEN flags #draw bit@ IF [ 5 ] [FOR] 7 pick [NEXT] trans' 7 pick 7 pick THEN THEN 2drop 2drop 2drop 2drop ; \ viewport 28jun98py : fill ( x y addr n color -- ) >r 2over inclip? IF xwin @ IF 2over 2over r@ super super fill THEN flags #draw bit@ IF 2over trans' 2over r@ THEN THEN rdrop 2drop 2drop ; : stroke ( x y addr n color -- ) >r 2over inclip? IF xwin @ IF 2over 2over r@ super super stroke THEN flags #draw bit@ IF 2over trans' 2over r@ THEN THEN rdrop 2drop 2drop ; : drawer ( x y o xt -- ) xwin @ IF 2over 2over super super drawer THEN flags #draw bit@ IF 2over trans' 2over THEN 2drop 2drop ; \ viewport 09nov97py : inside? ( x y -- ) y @ - sh @ u< swap x @ - sw @ u< and ; : xlegal ( x -- x' ) w @ sw @ - hstep @ /f min 0max ; : ylegal ( y -- y' ) h @ sh @ - vstep @ /f min 0max ; : slided ( -- ) hspos self IF hspos draw THEN vspos self IF vspos draw THEN ; : show-me ( x y -- ) sw @ sh @ { x y w h } y orgy @ vstep @ * - h u>= dup IF y h 2/ - vstep @ /f ylegal ypos! THEN x orgx @ hstep @ * - w u>= dup IF x w 2/ - hstep @ /f xlegal xpos! THEN or IF slided THEN x y trans' dpy show-me ; \ viewport 02jan05py : scroll ( x y -- ) sw @ 4- sh @ 4- { x y w h } y orgy @ vstep @ * - dup 0< IF drop y ELSE h >= IF y h - orgy @ 1+ vstep @ * max BUT THEN vstep @ /f ylegal ypos! true ELSE false THEN x orgx @ hstep @ * - dup 0< IF drop x ELSE w >= IF x w - orgx @ 1+ hstep @ * max BUT THEN hstep @ /f xlegal xpos! true ELSE false THEN or IF slided moved! THEN x y trans' dpy scroll ; : focus child focus ; : defocus child defocus ; \ viewport 22jan05py : ud ( -- n ) /mslide vstep @ /f 1+ ; : clicked ( x y b n -- ) over $18 and over 1 and 0= and sh @ h @ < and IF \ scroll over $10 and IF orgy @ ud + ylegal ypos! THEN over $08 and IF orgy @ ud - ylegal ypos! THEN over $18 and IF slided THEN 2drop 2drop ELSE super clicked THEN ; \ viewport 22jan05py : /vpage ( -- n ) sh @ vstep @ /f 1- 1 max ; : /hpage ( -- n ) sw @ hstep @ /f 1- 1 max ; : keyed ( key sh -- ) dup 1 and IF over $FF55 = IF orgy @ /vpage - ylegal ypos! slided 2drop EXIT THEN over $FF56 = IF orgy @ /vpage + ylegal ypos! slided 2drop EXIT THEN THEN super keyed ; class; \ viewport variants 12nov06py viewport class hviewport 2 cells var yincs how: : vglue ( -- g ) vglues 2@ ; : resized child vglue nip 0= IF 0 1 ELSE child yinc THEN yincs 2! super resized ; : yinc yincs 2@ ; : clicked ( x y b n -- ) over $18 and over 1 and 0= and sw @ w @ < and IF \ scroll over $10 and IF orgx @ ud + xlegal xpos! THEN over $08 and IF orgx @ ud - xlegal xpos! THEN over $18 and IF slided THEN 2drop 2drop ELSE super super clicked THEN ; \ viewport variants 22jan05py : keyed ( key sh -- ) dup 1 and IF over $FF55 = IF orgx @ /hpage - xlegal xpos! slided 2drop EXIT THEN over $FF56 = IF orgx @ /hpage + xlegal xpos! slided 2drop EXIT THEN THEN super super keyed ; class; viewport class vviewport 2 cells var xincs how: : hglue ( -- g ) hglues 2@ ; : resized child hglue nip 0= IF 0 1 ELSE child xinc THEN xincs 2! super resized ; : xinc xincs 2@ ; class; \ Sskip 11nov06py vviewport class clipper how: : vglue ( -- g ) vglues 2@ ; : resized super super resized ; : init 1 1 super init ; backing :: xinc backing :: yinc class; Mskip class Sskip public: widget ptr vsize widget ptr hsize how: : init ( ho vo -- ) super init bind vsize bind hsize ; : hglue hsize hglue drop 0 ; : vglue vsize vglue drop 0 ; class; \ Container object 03jan98py vbox class sliderview cell var glues public: gadget ptr inner & inner viewport asptr viewp static border-at how: 0 border-at v! \ Container object 08apr00py : init ( viewport -- ) dup bind inner 1 hbox new rzbox -2 border-at @ IF borderw c! ELSE borderbox THEN & viewport @ inner class? IF & hviewport @ viewp class? 0= IF viewp 'vslide vslider0 new dup viewp bind vspos 2 hbox new rzbox THEN & vviewport @ viewp class? 0= IF viewp 'hslide hslider0 new dup viewp bind hspos & hviewport @ viewp class? 0= IF viewp vspos self viewp hspos self Sskip new 2 hbox new rzbox THEN 2 ELSE 1 THEN ELSE 1 THEN super init ; \ Container object 14sep97py : glue-off 0. hglues 2! 0. vglues 2! & viewport @ inner class? IF & hviewport @ viewp class? 0= IF childs hglue 2drop childs vglue 2drop THEN & vviewport @ viewp class? 0= IF childs widgets hglue 2drop childs widgets vglue 2drop THEN THEN ; : glues? ( -- n ) & vviewport @ viewp class? 0= IF viewp hspos vglue drop 0= 1 and ELSE 0 THEN & hviewport @ viewp class? 0= IF viewp vspos hglue drop 0= 2 and ELSE 0 THEN or ( dup . ) dup glues ! ; \ Container object 28mar99py : ?portwin viewp hslide -rot - min viewp vslide -rot - min viewp org 2! viewp xwin @ IF viewp noback @ IF viewp draw THEN ELSE viewp noback @ 0= IF viewp create-pixmap viewp flags #draw dup push off viewp child draw THEN THEN ; : sresize ( x y w h -- x y w h ) viewp org 2@ >r >r 2over 2over super resize glue-off r> r> viewp org 2! ; \ Container object 03oct98py : >parent dpy counter @ 4 < IF 1 dpy counter +! parent resized -1 dpy counter +! THEN ; \ Container object 28mar99py \ : >parent parent resized ; : resize ( x y w h -- ) & viewport @ inner class? IF viewp noback dup @ >r on viewp flags #draw -bit glues @ >r viewp org 2@ >r >r 2over 2over xS xywh- viewp resize glue-off r> r> viewp org 2! glues? dup r@ or IF >r sresize glues? r> <> IF sresize THEN glues? r> <> r> viewp noback ! viewp flags #draw +bit IF >parent parent draw THEN 2drop 2drop ?portwin EXIT THEN drop rdrop r> viewp noback ! viewp flags #draw +bit THEN super resize ; class; \ Container object 03jan98py sliderview class asliderview how: vabox :: (clicked vabox :: show-you vabox :: focus vabox :: defocus vabox :: keyed vabox :: handle-key? 0 border-at v! \ Container object 08apr00py : init ( viewport -- ) dup bind inner 1 habox new rzbox -2 border-at @ IF borderw c! ELSE borderbox THEN & viewport @ inner class? IF & hviewport @ viewp class? 0= IF viewp 'vslide vslider0 new dup viewp bind vspos 2 habox new rzbox THEN & vviewport @ viewp class? 0= IF viewp 'hslide hslider0 new dup viewp bind hspos & hviewport @ viewp class? 0= IF viewp vspos self viewp hspos self Sskip new 2 habox new rzbox THEN 2 ELSE 1 THEN ELSE 1 THEN super super init ; class; \ display simplicifacionts 06feb00py : D[ postpone >r ; immediate restrict | : (]D r> r> swap >r displays with assign self endwith ; restrict : DS[ postpone >r ; immediate restrict | : (]DS r> r> swap >r viewport with assign self endwith asliderview new ; restrict [defined] loffset [IF] : ]D -cell loffset +! postpone (]D ; immediate restrict : ]DS -cell loffset +! postpone (]DS ; immediate restrict [ELSE] : ]D postpone (]D ; immediate restrict : ]DS postpone (]DS ; immediate restrict [THEN] \ Container object 03aug98py vabox class vresize how: : yinc 0 childs vglue drop ; class; habox class hresize how: : xinc 0 childs hglue drop ; class; \ Container object 21oct99py : /glue ( glue addr -- glue' ) >r over swap + r@ @ min max dup r> ! 0 ; Variable do-size vabox class vasbox public: cell var hsize cell var vsize method oglue how: : vglue ( -- glue ) super vglue vsize /glue ; : vglue@ ( -- glue ) super vglue@ vsize /glue ; : oglue ( -- glue ) super vglue ; : yinc ( -- inc ) 0 1 ; : resized do-size @ IF dpy counter @ 2 > ?EXIT THEN super resized vglue 2drop ; : init super init ; class; \ Container object 21oct99py habox class hasbox public: cell var hsize cell var vsize method oglue how: : hglue ( -- glue ) super hglue hsize /glue ; : hglue@ ( -- glue ) super hglue@ hsize /glue ; : oglue ( -- glue ) super hglue ; : xinc ( -- inc ) 0 1 ; : resized do-size @ IF dpy counter @ 2 > ?EXIT THEN super resized hglue 2drop ; : init super init ; class; \ vsizer 28mar99py boxchar class vrtsizer public: method drawxorline & parent vasbox asptr vsized early relation? method how: : init ( -- ) noop-act 0 ( rot) super init ; Variable vsize' : relation? ( -- flag ) widgets self 'nil = ; : hglue ( -- glue ) xN 1 *filll ; : vglue ( -- glue ) xN 0 ; : draw ( -- ) shadedbox ; : moved ( x y -- ) 2drop [defined] x11 [IF] relation? IF XC_bottom_side ELSE XC_top_side THEN [THEN] [defined] win32 [IF] IDC_SIZENS [THEN] dpy set-cursor ^ dpy set-rect ; \ vsizer 27mar99py : maxsize ( -- m ) vsized parent with h @ vglue drop - endwith ; : ( h -- h' ) vsized oglue over >r + min 0max maxsize vsized vsize @ + min r> max 0max ; : size! ( h -- ) dup vsized vsize dup @ -rot ! = ?EXIT do-size on vsized resized do-size off ; : drawxorline vsized vsize @ vsize' @ <> IF vsize' @ size! THEN ; : >released ( x y -- ) vsized vsize @ relation? IF - ELSE + THEN DOPRESS drawxorline nip relation? IF swap THEN - vsize' ! drop drawxorline ; \ vsizer 27mar99py : keyed ( key sh -- ) drop relation? IF $FF57 ELSE $FF50 THEN case? IF maxsize vsized vsize @ + size! EXIT THEN relation? IF $FF50 ELSE $FF57 THEN case? IF 0 size! EXIT THEN relation? IF $FF54 ELSE $FF52 THEN case? IF vsized vsize @ vsized yinc nip + size! EXIT THEN relation? IF $FF52 ELSE $FF54 THEN case? IF vsized vsize @ vsized yinc nip - size! EXIT THEN drop ; : clicked ( x y b n -- ) 2over moved nip 1 and 0= IF 2drop EXIT THEN vsized vsize @ vsize' ! drawxorline >released ( cc ) drawxorline vsize' @ size! ; class; \ hsizer 28mar99py boxchar class hrtsizer public: method drawxorline & parent hasbox asptr hsized early relation? method how: : init ( -- ) noop-act 0 ( rot) super init ; Variable hsize' : relation? ( -- flag ) widgets self 'nil = ; vrtsizer :: draw : hglue ( -- glue ) xN 0 ; : vglue ( -- glue ) xN 1 *filll ; : moved ( x y -- ) 2drop [defined] x11 [IF] relation? IF XC_right_side ELSE XC_left_side THEN [THEN] [defined] win32 [IF] IDC_SIZEWE [THEN] dpy set-cursor ^ dpy set-rect ; \ hsizer 27mar99py : maxsize ( -- m ) hsized parent with w @ hglue drop - endwith ; : ( w -- w' ) hsized oglue over >r + min 0max maxsize hsized hsize @ + min r> max 0max ; : size! ( w -- ) dup hsized hsize dup @ -rot ! = ?EXIT do-size on hsized resized do-size off ; : drawxorline hsized hsize @ hsize' @ <> IF hsize' @ size! THEN ; : >released ( x y -- ) swap hsized hsize @ relation? IF - ELSE + THEN DOPRESS drawxorline drop relation? IF swap THEN - hsize' ! drop drawxorline ; \ hsizer 27mar99py : keyed ( key sh -- ) drop relation? IF $FF57 ELSE $FF50 THEN case? IF maxsize hsized hsize @ + size! EXIT THEN relation? IF $FF50 ELSE $FF57 THEN case? IF 0 size! EXIT THEN relation? IF $FF53 ELSE $FF51 THEN case? IF hsized hsize @ hsized yinc nip + size! EXIT THEN relation? IF $FF51 ELSE $FF53 THEN case? IF hsized hsize @ hsized yinc nip - size! EXIT THEN drop ; : clicked ( x y b n -- ) nip 1 and 0= IF 2drop EXIT THEN hsized hsize @ hsize' ! drawxorline >released ( cc ) drawxorline hsize' @ size! ; class; \ vsizer 14nov98py vrtsizer class vsizer how: : drawxorline [defined] x11 [IF] dpy drawable nip 9 XSetFunction drop [THEN] x @ y @ vsized vsize @ vsize' @ relation? IF - ELSE swap - THEN - h @ 2/ + w @ 1 color @ 8 >> dpy box [defined] x11 [IF] dpy drawable nip 3 XSetFunction drop [THEN] ; class; vrtsizer class vxrtsizer how: : ( h -- ) vsized oglue + min 0max ; class; \ hsizer 14nov98py hrtsizer class hsizer how: : drawxorline [defined] x11 [IF] dpy drawable nip 9 XSetFunction drop [THEN] x @ hsized hsize @ hsize' @ relation? IF - ELSE swap - THEN - w @ 2/ + y @ 1 h @ color @ 8 >> dpy box [defined] x11 [IF] dpy drawable nip 3 XSetFunction drop [THEN] ; class; hrtsizer class hxrtsizer how: : ( w -- ) hsized oglue + min 0max ; class;