\ component 04mar00py : get-win ( -- win ) & displays @ object class? IF displays get-win ELSE widget dpy get-win THEN ; modal class component early open immediate early dialog immediate early open-app immediate early menu immediate early open-win method params method widget how: : widget s" Nothing" text-label new ; : params DF[ 0 ]DF s" No Title" ; : init ( -- ) ^>^^ assign widget 1 ^ params 2drop nip super init ; : open-win ( -- ) self params rot drop screen self window new window with assign show endwith ; : make ( o -- win ) new, dup >o params o> rot drop screen self window new window with assign ^ endwith ; : open, make window with show endwith ; : dialog, make get-win swap window with set-parent show endwith ; : open-app, make window with show up@ app ! 1 apprefcnt +! endwith ; : menu, ( o -- o ) >o widget o> ; : open ( -- ) o@ state @ IF postpone ALiteral postpone open, ELSE open, THEN ; : dialog ( -- ) o@ state @ IF postpone ALiteral postpone dialog, ELSE dialog, THEN ; : open-app ( -- ) o@ state @ IF postpone ALiteral postpone open-app, ELSE open-app, THEN ; : menu ( -- ) ^ state @ IF postpone ALiteral postpone menu, ELSE menu, THEN ; class; : new-component ( o od addr u -- o ) >r >r 1 swap modal new r> r> screen self window new window with assign ^ endwith ; : open-component ( o od addr u -- ) new-component window with show endwith ; : open-dialog ( o od addr u -- ) new-component get-win swap window with set-parent show endwith ; : open-application ( o od addr u -- ) new-component window with show up@ app ! 1 apprefcnt +! endwith ; \ empty menu stub component class how: : params DF[ 0 ]DF s" No Title" ; : widget ^^ S[ ]S ( MINOS ) s" --Stub--" menu-entry new #1 vabox new #2 borderbox ; class; \ empty box stub widget class cross how: : hglue parent self combined with n @ endwith 1 <= IF xM 1 *fill ELSE 0 0 THEN ; : vglue parent self combined with n @ endwith 1 <= IF xM 1 *fill ELSE 0 0 THEN ; : draw parent self combined with n @ endwith 1 > ?EXIT xywh defocuscol @ @ dpy box xywh 2over p+ 0 dpy line x @ y @ h @ + x @ w @ + y @ 0 dpy line ; class; menu-window class menu-component early open immediate early dialog immediate early open-app immediate method params method widget how: : widget s" Nothing" text-label new ; : params DF[ 0 ]DF s" No Title" ; : init ( -- ) screen self super init ^>^^ widget 1 ^ params 2>r nip modal new 2r> assign ; : open, new, window with show endwith ; : dialog, new, get-win swap window with set-parent show endwith ; : open-app, new, window with show up@ app ! 1 apprefcnt +! endwith ; : open ( -- ) o@ state @ IF postpone ALiteral postpone open, ELSE open, THEN ; : dialog ( -- ) o@ state @ IF postpone ALiteral postpone dialog, ELSE dialog, THEN ; : open-app ( -- ) o@ state @ IF postpone ALiteral postpone open-app, ELSE open-app, THEN ; class; \ OpenGL canvas 22jun02py also opengl also glconst [defined] win32 [IF] | Create pfd sizeof PIXELFORMATDESCRIPTOR w, 1 w, 0 ( PFD_DRAW_TO_WINDOW or ) PFD_DRAW_TO_BITMAP or PFD_SUPPORT_OPENGL or \ PFD_SUPPORT_GDI or ( PFD_DOUBLEBUFFER or ) , PFD_TYPE_RGBA c, &24 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, &32 c, 0 c, 0 c, PFD_MAIN_PLANE c, 0 c, 0 , 0 , 0 , | Create bih sizeof BITMAPINFOHEADER , 0 , 0 , 1 w, &24 w, BI_RGB , 0 , 0 , 0 , 0 , 0 , [THEN] \ OpenGL canvas 15aug99py 0 Value canvas-mode glue class glcanvas public: defer drawer method render cell var visinfo cell var pixmap cell var ctx cell var glxpm cell var glxwin cell var rendered window-stub ptr stub cell var shown [defined] win32 [IF] cell var oldbm cell var dibptr [THEN] [defined] x11 [IF] cell var cmap [THEN] widget ptr outer \ OpenGL canvas 08jul00py how: [defined] x11 [IF] | Create attrib GLX_DOUBLEBUFFER , GLX_RGBA , GLX_RED_SIZE , 1 , GLX_GREEN_SIZE , 1 , GLX_BLUE_SIZE , 1 , GLX_DEPTH_SIZE , $10 , 0 , : init ( exec actor w w+ h h+ -- ) super init >callback IS drawer ^^ bind outer ; : dpy! super dpy! dpy xrc with dpy @ screen @ endwith attrib canvas-mode 1 and cells + glXChooseVisual visinfo ! dpy xrc dpy @ visinfo @ 0 1 glXCreateContext ctx ! ; \ OpenGL canvas 09dec07py : destroy-pixmap ( -- ) dpy xrc dpy @ glxwin @ ?dup IF over swap XDestroyWindow drop glxwin off THEN glxpm @ ?dup IF over swap glXDestroyGLXPixmap glxpm off THEN pixmap @ ?dup IF over swap XFreePixmap pixmap off THEN cmap @ ?dup IF over swap XFreeColormap cmap off THEN drop ; : set-context ( -- ) dpy xrc dpy @ glxpm @ glxwin @ or ctx @ glXMakeCurrent drop ; : dpyscreen ( -- dpy screen ) dpy xrc dpy @ visinfo @ XVisualInfo screen @ ; \ OpenGL canvas 09jan00py : new-window xswa sizeof XSetWindowAttributes erase AllocNone visinfo @ XVisualInfo visual @ dup dpy xrc vis @ <> canvas-mode 4 and or IF dpy drawable drop 2swap swap XCreateColormap dup cmap ! ELSE 2drop dpy xrc cmap @ THEN xswa XSetWindowAttributes colormap ! dpyscreen BlackPixel dup xswa XSetWindowAttributes border_pixel ! xswa XSetWindowAttributes background_pixel ! event-mask xswa XSetWindowAttributes event_mask ! dpy xrc dpy @ dpy get-win x @ y @ w @ 1 max h @ 1 max 0 visinfo @ XVisualInfo depth @ InputOutput visinfo @ XVisualInfo visual @ glxvals xswa XCreateWindow self over window-stub new bind stub ; \ OpenGL canvas 09dec07py : new-pixmap ( -- ) glxwin @ ?EXIT glxpm @ ?EXIT dpy xwin @ dpy get-win = canvas-mode 2 and 0= and IF new-window glxwin ! rendered off EXIT THEN dpy xrc dpy @ dpy get-win w @ 4 max 3 + -4 and h @ 4 max visinfo @ XVisualInfo depth @ XCreatePixmap dup pixmap ! dpy xrc dpy @ visinfo @ rot glxCreateGLXPixmap glxpm ! rendered off ; : show ( -- ) shown @ shown on ?EXIT new-pixmap stub self 0= ?EXIT xywh stub resize stub show ; : hide ( -- ) shown @ shown off 0= ?EXIT stub self 0= ?EXIT stub hide ; [THEN] \ OpenGL canvas 23sep99py [defined] win32 [IF] : set-context ctx @ pixmap @ wglMakeCurrent ?err ; : add-dib-section h @ 1 max w @ 1 max bih cell+ 2! 0 0 0 DIB_RGB_COLORS bih pixmap @ CreateDIBSection dup ?err glxpm ! glxpm @ pixmap @ SelectObject dup ?err oldbm ! pfd dup pixmap @ ChoosePixelFormat dup ?err pixmap @ SetPixelFormat ?err ; : new-pixmap ( -- ) 0 0 wglMakeCurrent drop screen xrc dc @ CreateCompatibleDC dup ?err pixmap ! add-dib-section pixmap @ wglCreateContext dup ?err ctx ! rendered off ; : init ( exec actor w w+ h h+ -- ) super init >callback IS drawer ^^ bind outer ; \ OpenGL canvas 01nov06py : destroy-pixmap ( -- ) ctx @ ?dup IF 0 0 wglMakeCurrent drop wglDeleteContext drop ctx off THEN pixmap @ ?dup IF DeleteObject drop pixmap off THEN glxpm @ ?dup IF DeleteObject drop glxpm off THEN ; [THEN] \ OpenGL canvas 09dec07py : resize ( x y w h -- ) super resize rendered off [defined] win32 [IF] oldbm @ pixmap @ SelectObject ?err glxpm @ ?dup IF DeleteObject drop glxpm off THEN add-dib-section [ELSE] glxpm @ IF destroy-pixmap THEN new-pixmap stub self IF xywh stub resize stub show THEN [THEN] ; : dispose destroy-pixmap [defined] x11 [IF] ctx @ ?dup IF dpy xrc dpy @ swap glXDestroyContext THEN [THEN] stub self IF stub dispose THEN glFlush super dispose ; \ OpenGL canvas 08dec07py : render ( -- ) \ ." render " pixmap @ glxwin @ or 0= IF new-pixmap THEN set-context ^ drawer glFlush [defined] x11 [IF] glxpm @ IF dpy xrc dpy @ glxpm @ glXSwapBuffers THEN [THEN] rendered on ; \ OpenGL canvas 22oct06py : draw ( -- ) rendered @ 0= IF render THEN [defined] x11 [IF] pixmap @ IF 0 0 xywh 2swap pixmap @ dpy image ELSE glxwin @ IF dpy xrc dpy @ glxwin @ glXSwapBuffers rendered off THEN THEN [THEN] [defined] x11_ximage [IF] 0 0 xywh 2swap 0 sp@ >r 0 sp@ r> pixmap @ dpy xrc dpy @ XMesaFindBuffer XMesaGetBackBuffer drop nip dpy ximage [THEN] [defined] win32 [IF] 0 0 xywh 2swap pixmap @ dpy image [THEN] ; \ OpenGL canvas 04aug05py boxchar :: clicked ( x y b n -- ) boxchar :: keyed ( key sh -- ) : moved ( x y -- ) 2drop stub self IF mouse_cursor stub set-cursor ^ stub set-rect ELSE mouse_cursor dpy set-cursor ^ dpy set-rect THEN callback enter ; boxchar :: leave ( -- ) class; \ canvas 11jul99py previous previous : GL[ postpone [: glcanvas postpone with ; immediate : ]GL glcanvas postpone endwith postpone ;] ; immediate : CV[ postpone [: canvas postpone with ; immediate : ]CV canvas postpone endwith postpone ;] ; immediate \ helper words for Theseus 21sep07py : T" postpone S" ; immediate [defined] VFXFORTH [IF] Variable ^^bind-string : ^^bind postpone dup postpone bind2 ; immediate [ELSE] : ^^bind postpone dup postpone bind ; immediate restrict [THEN] \ IO-Window 26oct99py : scan8 ( addr u -- addr u' ) 2dup bounds ?DO I c@ $80 and IF drop I over - LEAVE THEN LOOP ; : scan16 ( addr u -- addr' u' ) bounds scratch 0 2swap ?DO I c@ $80 and 0= ?LEAVE 2dup + I c@ $7F and 8 << I 1+ c@ or swap w! 2+ 2 +LOOP ; \ IO-Window 12mar00py 0 Value do-scroll boxchar class terminal public: cell var cols cell var rows cell var color cell var cursor# cell var pos cell var selw cell var keys cell var start cell var scrolls cell var typebuf cell var maxrows cell var minrows cell var addr cell var u 1 var resize! 1 var flush! 2 var text-color cell var sizew font ptr fnt16 & dpy viewport asptr vdpy \ IO-Window 24oct99py method type method page method emit method flush method decode method clrline method cr method c method atxy? method drawcur method at? method at method curoff method curon method key? method key method 'start method 'line method scrollup method scrollback method paste-selection early showtext early curpos early .text \ IO-Window 06feb00py how: 6 colors focuscol ! 1 colors defocuscol ! : assign ( w h -- ) 1 max rows ! 1 max cols ! rows @ maxrows ! rows @ minrows ! typebuf HandleOff start HandleOff cols @ cell+ typebuf Handle! typebuf @ off rows @ 1+ cols @ * start 2dup Handle! @ swap bl fill 1 selw ! dpy self IF resized THEN ; \ IO-Window 05jan07py : 'start ( -- addr ) start @ scrolls @ cols @ * + ; : 'line ( n -- addr u ) scrolls @ cols @ * dup >r + rows @ cols @ * modf r> - 'start + cols @ -trailing ; : !resized s" n" !textwh 4 dpy xrc font@ bind fnt16 ; : !tile 0 scrolls @ texth @ * negate dpy txy! ; : focus focuscol @ @ dup 8 >> swap $FF and 8 << or color ! drawcur super focus ; : defocus defocuscol @ @ color ! drawcur ; : dpy! ( dpy -- ) widget :: dpy! fnt self 0= IF 1 dpy xrc font@ font! THEN fnt16 self 0= IF 4 dpy xrc font@ bind fnt16 THEN ; \ mixed font output 24oct99py : .texts ( addr u x y dpy -- ) fnt16 self 0= IF fnt draw EXIT THEN { x y dpy } BEGIN dup WHILE 2dup scan8 dup IF tuck x y dpy fnt draw dup textwh @ * x + to x safe/string ELSE 2drop THEN 2dup scan16 dup IF tuck x y dpy fnt16 draw dup textwh @ * x + to x safe/string ELSE 2drop THEN REPEAT 2drop ; \ mixed font output 16jan05py : font-color! ( c dpy -- ) over fnt color ! displays with set-color endwith ; : display-texts ( x y dpy -- ) >r text-color @ r@ font-color! addr @ u @ 2swap r> .texts ; : .text ( addr u x y c -- ) text-color ! 2swap u ! addr ! ^ ['] display-texts dpy drawer ; \ mixed font output 05may07py : expand16 ( -- ) maxascii $80 = IF pos @ 'line drop dup 1+ xchar- tuck - negate pos +! dup selw @ + xchar- xchar+ swap - selw ! EXIT THEN fnt16 self 0= ?EXIT pos @ 1- 0max 'line drop c@ $80 and IF -1 pos +! 1 selw +! THEN pos @ selw @ 1- + 0max 'line drop c@ $80 and IF 1 selw +! THEN ; : csize ( s i -- size ) dup >r - 0max r> 'line rot 2dup swap - 0max >r min x-width r> + textwh @ * ; \ IO-Window 20oct06py : drawcur dpy self 0= ?EXIT !tile expand16 cursor# @ IF 6 colors @ ELSE color @ THEN pos @ typebuf @ @ + dup selw @ + 2dup min -rot max { color s e } x @ y @ cols @ rows @ * 0 ?DO s I - cols @ u< e I - cols @ u< or I s e within or IF over s I csize dup >r + over r> w @ e I csize min swap - 1 max texth @ color dpy box I 'line e I - 0max min s I - 0max safe/string 2over swap s I csize + swap color 8 >> .text THEN texth @ + cols @ +LOOP 2drop ; \ IO-Window 16jun02py : draw-io ( x y dpyo -- ) dup displays with clipy endwith over + { dpyo sclip eclip } cols @ rows @ * 0 ?DO dup sclip eclip within IF 2dup w @ texth @ 6 colors @ dpyo displays with box endwith I 'line 2over 6 colors @ 8 >> dpyo font-color! dpyo .texts THEN texth @ + cols @ +LOOP 2drop ; : draw ( -- ) !tile x @ y @ ^ ['] draw-io dpy drawer drawcur 0 0 dpy txy! ; \ IO-Window 12mar00py : resize-it2 ( -- ) 0 resize! c! sizew off parent resized show-you ; : resize-it ( -- ) vdpy sw @ cols @ textwh @ * min sizew ! parent resized dpy set-hints ['] resize-it2 ^ /step @ after dpy schedule ; : screen-resize start rows @ $20 + $-20 and cols @ * SetHandleSize resize! c@ ?EXIT 1 resize! c! ['] resize-it ^ /step @ after dpy schedule ; : xinc ( -- o inc ) sizew @ textwh @ ; : yinc ( -- o inc ) 0 texth @ ; \ IO-Window 12mar00py : redraw-it ( -- ) 0 resize! c! draw ; : screen-redraw resize! c@ ?EXIT 1 resize! c! ['] redraw-it ^ /step @ after dpy schedule ; \ IO-Window 12mar00py : scrollup ( -- ) rows @ maxrows @ < IF 1 rows +! screen-resize cols @ rows @ 1- * 'line drop cols @ bl fill EXIT THEN scrolls @ 1+ rows @ modf scrolls ! cols @ dup negate pos +! cols @ rows @ 1- * 'line drop swap bl fill do-scroll IF x @ y @ texth @ dup >r + dpy transback w @ h @ r> - x @ y @ dpy get-win dpy image !tile x @ y @ texth @ rows @ 1- * + w @ texth @ 6 colors @ dpy box dpy >exposed 0 0 dpy txy! ELSE screen-redraw THEN ; : scrollback ( n -- ) rows @ max maxrows ! ; \ IO-Window 16jan05py : showtext ( addr u1 u2 -- ) resize! c@ IF drop 2drop EXIT THEN !tile drop cols @ >r x @ y @ at? drop 0 swap texth @ * p+ 2dup textwh 2@ r> * swap 6 colors @ dpy box pos @ at? nip - 'line 2swap 6 colors @ 8 >> .text 2drop ; : linetype ( addr u -- ) tuck pos @ 'line drop swap 2dup -trailing >r drop move >r pos @ r@ + cols @ rows @ * >= IF scrollup THEN pos @ 'line drop r> r> over >r showtext r> pos +! ; : vglue rows @ texth @ * 0 ; : hglue cols @ textwh @ * 0 ; : ?flush ( -- ) flush! c@ ?EXIT 1 flush! c! ['] flush ^ /step @ after dpy schedule ; \ IO-Window 06jan05py : win-type ( addr len -- ) cols @ >r BEGIN dup pos @ r@ modf r@ - + dup 0>= WHILE tuck - >r over r@ + swap rot r> linetype REPEAT drop linetype rdrop ; : type ( addr len -- ) typebuf @ @ over + cols @ >= IF flush curoff win-type curon ELSE ?flush tuck typebuf @ @+ + swap move typebuf @ +! THEN ; : emit ( char -- ) char$ type ; : flush ( -- ) 0 flush! c! typebuf @ @ IF typebuf @ @+ swap curoff typebuf @ off win-type curon THEN ; : moved ( x y -- ) 2drop ^ dpy set-rect [defined] x11 [IF] XC_xterm [THEN] [defined] win32 [IF] IDC_IBEAM [THEN] dpy set-cursor ; \ IO-Window 12mar00py : page ( -- ) flush curoff pos off typebuf @ off scrolls off minrows @ rows ! screen-resize 'start cols @ rows @ * bl fill curon draw ; : at ( r c -- ) flush 0max cols @ 1- min swap 0max rows @ 1- min cols @ * + curoff pos ! curon ; : at? ( -- r c ) pos @ typebuf @ @ + cols @ /modf swap ; : show-you ( -- ) dpy self 0= ?EXIT at? textwh 2@ rot * -rot * x @ y @ p+ dpy show-me ; : ?sel-scroll ( c r -- c r ) over textwh @ * over texth @ * x @ y @ p+ dpy scroll ; : curpos ( -- x y ) at? textwh @ * swap 1+ texth @ * ; \ IO-Window 24oct99py : at-sel ( r c -- ) 0max cols @ 1- min swap 0max rows @ 1- min ?sel-scroll cols @ * + pos @ - cursor# @ pos @ selw @ { s1 c# p s } s s1 xor 0< IF 1 cursor# ! drawcur p s1 0 ELSE s1 0max s 0max < IF p s1 + s s1 - 1 ELSE s1 0max s 0max > IF p s + s1 s - 0 ELSE s1 0min s 0min < IF p s1 + s s1 - 0 ELSE s1 0min s 0min > IF p s + s1 s - 1 ELSE p 0 1 THEN THEN THEN THEN THEN cursor# ! selw ! pos ! drawcur c# cursor# ! p pos ! s1 selw ! ; \ IO-Window 30dec99py : clrline flush curoff pos @ dup cols @ modf - pos ! pos @ 'line drop cols @ 2dup -trailing >r drop 2dup bl fill r> showtext curon ; : curon ( -- ) -1 cursor# +! cursor# @ 0> ?EXIT 1 selw ! drawcur show-you cursor# off ; : curoff ( -- ) cursor# @ 1 cursor# +! 0> ?EXIT drawcur 0 selw ! 1 cursor# ! ; : c ( n -- ) flush curoff pos @ + 0max pos ! BEGIN pos @ cols @ rows @ * >= WHILE scrollup REPEAT curon ; : cr ( -- ) flush cols @ pos @ over modf - c resize! c@ ?EXIT show-you ; : curup cols @ negate c ; : curdown cols @ c ; \ IO-Window 09mar99py : selecting ( -- ) flush textwh 2@ swap DOPRESS x @ y @ p- 2swap swap >r /f swap r> /f at-sel ; : (dpy [defined] x11 [IF] dpy get-win dpy xrc dpy @ [ELSE] 0 0 [THEN] ; : mark-selection ( x y -- ) defocus at? >r >r swap at pos @ >r selecting -select selw @ pos @ + r> 2dup max -rot min 0 -rot ?DO drop cols @ I over modf - I 'line ( drop over -trailing ) I' I - min tuck +select over I' I - min <> swap +LOOP IF s" " +select THEN (dpy !select curoff r> r> at focus curon ; : paste-selection ( addr u -- ) bounds ?DO I xc@+ 0 keyed pause I - +LOOP ; \ IO-Window 21aug99py : copyline >r >r at? drop cols @ * 'line r@ swap 4 pick min dup 3 pin move r> over r> min ; : >atxy ( msap xy -- msap ) at? >r >r $100 /modf swap 2dup at r> rot <> IF >r copyline r> rdrop over >r THEN r> - + dup 0min dup negate c - 2 pick over - 0min dup c + ; \ IO-Window 07jun03py : keyed ( key state -- ) over shift-keys? IF 2drop EXIT THEN BEGIN keys @ @ $1F >= WHILE pause REPEAT $18 lshift or keys @ dup @ 1+ $1F min dup keys @ ! cells + ! ; boxchar :: handle-key? : key? ( -- flag ) keys @ @ 0= IF pause THEN keys @ @ 0> ; : getkey ( -- key ) keys @ @ IF keys @ cell+ @ keys @ 8 + dup cell- $78 move -1 keys @ +! dup $18 rshift kbshift ! $FFFFFF and ELSE 0 THEN ; : key ( -- key ) flush 1 cursor# ! curon BEGIN key? 0= WHILE dpy xrc fid [defined] VFXFORTH [IF] #1 [ELSE] #50 [THEN] idle REPEAT getkey curoff ; \ IO-Window 06jan05py : decode ( m s addr pos char -- m s addr pos flag ) kbshift @ $40 and IF drop 0 EXIT THEN [defined] (Ftast [IF] dup $FFBE $FFCA within IF $FFBE - cells (Ftast + -rot >r >r -rot >r >r perform r> r> r> r> prompt cr save-cursor over 3 pick type row over at 0 EXIT THEN [THEN] $FF51 case? IF ctrl B THEN $FF52 case? IF ctrl P THEN $FF53 case? IF ctrl F THEN $FF54 case? IF ctrl N THEN dup $007F = IF drop ctrl D THEN dup $FF00 and $FF00 = IF drop 0 EXIT THEN [defined] VFXFORTH [IF] PCdecode [ELSE] [defined] utf-8 [IF] xdecode [ELSE] PCdecode [THEN] [THEN] ; \ IO-Window 01jan05py : init ( w h -- ) $80 keys Handle! keys @ off ^ CK[ 2swap y @ - texth @ /f swap x @ - textwh @ /f swap 2swap 1 and IF drop mark-selection EXIT THEN 1 and 0= IF 2drop (dpy @select paste-selection EXIT THEN 8 << or kbshift @ $40 or keyed ]CK >callback assign defocuscol @ @ color ! ; : close #cr 0 keyed S" bye" bounds ?DO i c@ 0 keyed LOOP ; : dispose start HandleOff keys HandleOff typebuf HandleOff ^ dpy cleanup super dispose ; class; [defined] VFXFORTH [IF] Defer WinI/O Defer terminal-menu ' noop IS terminal-menu 2Variable map-size 80 24 map-size 2! 2Variable map-pos #1000 Value MaxScroll terminal ptr term hbox ptr term-menu rule ptr term-last : openw screen self menu-window new menu-window with term-w set-icon 0 1 *fill 0 1 *fil rule new dup F bind term-last 1 hbox new vfixbox dup F bind term-menu 1 vbox new 1 1 viewport new D[ map-size 2@ terminal new dup F bind term ]D s" VFX Forth Dialog" assign terminal-menu map-size 2@ geometry map-pos 2@ d0= 0= IF map-pos 2@ repos THEN show endwith map-size 2@ c/cols ! c/line ! MaxScroll term scrollback WinI/O ; [ELSE] \ Window IO words 10apr04py terminal uptr term Forward openw [THEN] | : term? term self 0= IF openw THEN ; : WINtype ( addr l -- ) term? term type pause ; : WINemit ( char -- ) term? term emit ; : WINflush ( -- ) term? term flush ; : WINcr ( -- ) term? term cr pause ; : WINpage ( -- ) term? term page ; : WINat ( rol col -- ) term? term at ; : WINat? ( -- row col ) term? term at? ; : WINform ( -- rs cs ) term? term rows @ term cols @ ; : WINcuron ( -- ) term? term curon ; : WINcuroff ( -- ) term? term curoff ; : WINcurleft ( -- ) term? -1 term c ; : WINcurrite ( -- ) term? 1 term c ; : WINclrline ( -- ) term? term clrline ; : WINkey? ( -- flag ) term? term key? ; : WINkey ( -- key ) term? term key ; : WINdecode term? term decode ; [defined] VFXFORTH [IF] ' WINdecode IS decode [THEN] \ Window IO words 05jan05py [defined] VFXFORTH [IF] : >out WINat? out ! op-line# ! ; : WINsetpos' ( x y mode sid -- ior ) 2drop swap WINat 0 >out ; : WINgetpos' ( mode sid -- x y ior ) 2drop WINat? swap 0 ; : WINflush' ( sid -- ior ) drop WINflush 0 ; : WINkey' drop WINkey ; : WINkey?' drop WINkey? ; : WINemit' drop WINemit >out ; : WINtype' drop WINtype >out ; : WINcr' drop WINcr >out ; \ : WINlf' drop WINclrline >out ; : WINpage' drop WINpage >out ; : WINcurleft' drop WINcurleft >out ; : WINemit?' drop true ; : WINaccept' drop PCaccept ; Create WINio-table ' .s , \ open ' false , \ close ' drop , \ read ' drop , \ write ' WINkey' , ' WINkey?' , ' WINkey' , ' WINkey?' , ' WINaccept' , \ accept ' WINemit' , ' WINemit?' , ' WINtype' , ' WINcr' , ' WINcr' , \ line feed ' WINpage' , \ form feed ' WINcurleft' , ' noop , ' WINsetpos' , ' WINgetpos' , ' 2drop , \ ioctl ' WINflush' , ' noop , \ readex Create WINio-sid 0 , WINio-table , 0 , : WINdisplay ( -- ) WINio-sid dup op-handle ! to PauseConsole ; : WINkeyboard ( -- ) WINio-sid ip-handle ! ; :noname WINdisplay WINkeyboard ; IS WinI/O [ELSE] Output: WINdisplay WINemit true WINcr WINtype PCdel WINpage WINat WINat? WINform noop noop WINflush WINcuron WINcuroff WINcurleft WINcurrite WINclrline [ [defined] xaccept [IF] Input: WINkeyboard WINkey WINkey? WINdecode xaccept false [ [ELSE] Input: WINkeyboard WINkey WINkey? WINdecode PCaccept false [ [THEN] : WINi/o WINdisplay WINkeyboard ; \ openw 10apr04py 2Variable map-size PCform swap map-size 2! 2Variable map-pos &1000 Value MaxScroll hbox uptr term-menu rule uptr term-last Defer terminal-menu ' noop IS terminal-menu minos \ openw 21jun05py : openw ( -- ) screen self menu-window new menu-window with term-w set-icon 0 1 *fill 0 1 *fil rule new dup F bind term-last 1 hbox new vfixbox dup F bind term-menu 1 vbox new 1 1 viewport new D[ map-size 2@ terminal new dup F bind term ]D s" bigFORTH Dialog" assign terminal-menu map-size 2@ geometry map-pos 2@ d0= 0= IF map-pos 2@ repos THEN sync show endwith MaxScroll term scrollback event-task' task's term dup @ 0= IF term self swap ! ELSE drop THEN ['] WINi/o IS standardi/o WINi/o ; [THEN] \ terminal menu operations 10apr04py : add-menu ( menu -- ) term-last self term-menu add ; : add-help ( menu -- ) 'nil term-menu add ; : hide-menu ( -- ) term-menu parent self vbox with -flip endwith ; : show-menu ( -- ) term-menu parent self vbox with +flip endwith ; : send-string ( addr u -- ) bounds ?DO i c@ 0 displays keyed LOOP ; \ terminal menu operations 10apr04py actor class key-actor public: cell var string how: : init ( o addr u -- ) string $! super init ; : fetch ( -- n ) 0 ; : store ( n -- ) string $@ ['] send-string called send drop ; class; : key" state @ IF postpone ^ postpone S" key-actor postpone new ELSE ^ '"' parse key-actor new THEN ; immediate \ : term-dpy term dpy dpy self ; \ file widget 10apr04py DOS also lbutton class file-widget public: cell var size cell var time cell var attr cell var wsize cell var wtime cell var wdate how: \ 6 colors defocuscol ! : dispose 0 bind callback super dispose ; : assign ( size time attr addr len -- ) base push super assign attr ! time ! size ! ; : !resized super !resized decimal size @ 0 <<# #s #> 0 textsize drop wsize ! #>> S" 00may99" 0 textsize drop wdate ! S" 00:00:00" 0 textsize drop wtime ! ; [defined] x11 [IF] : dir@ attr @ $C >> ; [THEN] [defined] win32 [IF] : dir@ attr @ $10 and 0<> 4 and ; [THEN] \ file widget 10apr04py : draw ( -- ) base push decimal push? 1 and >r xywh color @ dpy box r@ IF shadow swap xS xywh drawshadow THEN text $@ xywh nip texth @ - 2/ + xS 1+ 0 p+ r@ r@ p+ x @ xS + r@ + y @ xS + r@ + dir@ r> 4 << or ficons icon-pixmap with draw-at w @ endwith xS + xM color @ 8 >> { iw m cc } dpy mask 2swap 2over iw 0 p+ cc .text w @ wdate @ - 6 - 0 p+ time @ >date 2over cc .text m wtime @ + 0 p- time @ >time 2over cc .text m wsize @ + 0 p- size @ 0 <<# #s #> 2swap cc .text #>> ; \ file widget 10apr04py : hglue ( -- glue ) super hglue xM 3 * wdate @ wtime @ wsize @ + + + dir@ ficons >o icon-pixmap w @ o> + 8 + 0 p+ ; : vglue ( -- glue ) super vglue swap dir@ ficons >o icon-pixmap h @ o> xS 2* + 1+ max swap ; : clicked ( click -- ) dup 0= IF 2drop 2drop EXIT THEN dup 2/ 1 > >r >released ( cc ) 0= IF rdrop EXIT THEN 0 text $@ callback store r> IF #cr 0 dpy dpy keyed THEN ; : keyed ( key sh -- ) drop bl = IF xywh 2drop 1 2 clicked THEN ; class; \ file listbox 10apr04py [defined] x11 [IF] : dir? @attr $C >> 4 = ; [THEN] [defined] win32 [IF] : dir? @attr $10 and 0<> ; [THEN] component class file-listbox public: actor ptr file actor ptr path cell var file<= early name<= early date<= early length<= how: : read-files ( addr attr -- w1 .. wn n ) fsfirst 0 >r BEGIN pause 0= WHILE dir? 0= IF \ cr ." file " dtaname >file type file self @length @time @attr dtaname >len file-widget new r> 1+ >r THEN fsnext REPEAT r> ; \ file listbox 10apr04py : read-dir ( addr attr -- w1 .. wn n ) over >len '/' -scan + dup push '*' swap w! fsfirst 0 >r BEGIN pause 0= WHILE dir? dtaname >len s" ." compare 0<> dtaname >len s" .." compare 0<> and and IF \ cr ." dir " dtaname >file type path self @length @time @attr dtaname >len file-widget new r> 1+ >r THEN fsnext REPEAT r> ; : close dpy close ; \ file listbox sort methods 10apr04py : name<= ( w1 w2 -- flag ) >r file-widget with text $@ endwith r> file-widget with text $@ endwith compare 0>= ; : date<= ( w1 w2 -- flag ) 2dup file-widget with time @ endwith swap file-widget with time @ endwith 2dup = IF 2drop name<= ELSE u>= nip nip THEN ; : length<= ( w1 w2 -- flag ) 2dup file-widget with size @ endwith swap file-widget with size @ endwith 2dup = IF 2drop name<= ELSE u>= nip nip THEN ; \ file listbox 10apr04py : widget ( addr len -- object ) scratch 0place file<= @ F IS lex scratch $1C0 read-dir >r sp@ r@ sort scratch $0C0 read-files >r sp@ r@ sort r> r> + dup 0= IF s" -Empty Directory-" text-label new swap 1+ THEN 0 1 *filll 2dup rule new swap 1+ vresize new ['] <= F IS lex ; : assign ( addr u file-act path-act <= -- ) file<= ! bind path bind file ; : dispose path dispose file dispose super dispose ; class; \ file selector box 22sep07py window class file-selector public: icon-but ptr reloader button ptr oker infotextfield ptr path infotextfield ptr file viewport ptr file-list cell var ok? vabox ptr sort-menu info-menu ptr sort-title modal ptr close-it actor ptr do-ok early by-name early by-date early by-length method reload how: AVariable file<= : cancel ( -- ) ok? off hide :: close ; : ok ( -- ) ok? on hide 0 path get file get do-ok store :: close ; : close cancel ; : !file ( addr len -- ) file assign ; \ file selector box 10apr04py : !path ( addr len -- ) 2dup s" ." compare IF path get >r scratch r@ move scratch r@ '/' -scan 2over s" .." compare 0= IF 2swap 2drop 2dup + >r 1- '/' -scan over + r> over - r@ swap dup >r F delete r> r> swap - ELSE 2 pick 1+ r> + >r r@ swap safe/string s" /" 2over insert insert scratch r> THEN [defined] x11 [IF] over c@ '/' = IF path assign ELSE 2drop THEN [ELSE] path assign [THEN] ELSE 2drop THEN sort-title get reload ; \ file selector box 10apr04py : newdir ( addr len -- object ) \ dta fsetdta ^ S[ !file ]S ^ S[ !path ]S file<= @ file-listbox new ; : reload ( addr len -- ) sort-title assign path get newdir file-list with assign resized endwith ; : by-name file-listbox ' name<= file<= ! s" name" reload ; : by-date file-listbox ' date<= file<= ! s" date" reload ; : by-length file-listbox ' length<= file<= ! s" length" reload ; \ file selector box 10apr04py : >real-path ( addr n1 -- addr' n2 ) [defined] win32 [IF] over 1+ c@ ': <> [ELSE] over c@ '/' <> [THEN] IF 2dup pad dup 0 dgetpath drop >len [defined] win32 [IF] 2dup bounds ?DO I c@ '\' = IF '/' I c! THEN LOOP [THEN] dup IF 2dup + '/' swap c! 1+ THEN dup >r + swap move r> + nip pad swap THEN ; : sort-menu: ( -- o ) ^ ['] by-name simple new s" name" menu-entry new ^ ['] by-date simple new s" date" menu-entry new ^ ['] by-length simple new s" length" menu-entry new 3 vabox new widget :: xS borderbox ; \ file selector window 10apr04py : panel-line ( info l file l path l -- widget ) >real-path ^ ST[ reloader self close-it default! ]ST s" Path:" tableinfotextfield new bind path 2swap ^ ST[ oker self close-it default! ]ST -rot tableinfotextfield new bind file path self file self sort-title self 2fill ^ S[ s" ." !path ]S dot-dir icon-but new dup bind reloader ^ S[ s" .." !path ]S dotdot-dir icon-but new 2 hatbox new 2 hskips 2skip ^ ['] ok simple new s" OK" button new dup >r dup bind oker 2skip ^ ['] cancel simple new s" Cancel" button new 3 hatbox new \ file selector window 10apr04py 5 habox new 3 r> modal new panel dup bind close-it 1 habox new vfixbox path get 1 1 viewport new D[ newdir ]D dup bind file-list asliderview new 2 vabox new ; \ file selector window 10apr04py : assign ( info len file len path len -- ) sort-menu self s" Sort by" info-menu new bind sort-title panel-line s" File Selector" super assign ; : init ( action dpy -- ) super init bind do-ok file-listbox ' name<= file<= ! sort-menu: bind sort-menu diro-icon set-icon ; : keyed over #cr = IF close-it keyed ELSE super keyed THEN ; class; \ fsel-input 10apr04py minos : path+file ( path len file len -- file len ) >r >r tuck scratch 2+ swap move scratch 2+ swap r> r> 2swap '/' -scan + swap 2dup + 0 swap c! move scratch 2+ >len ; : fsel-action ( info len file1 len1 path1 len1 simple -- ) screen self file-selector new file-selector with assign 0 $10 geometry show endwith ; : fsel-dialog ( info len file1 len1 path1 len1 simple -- ) screen self file-selector new get-win swap file-selector with set-parent assign 0 $10 geometry show endwith ; \ fsel-input 10apr04py : ?suffix ( path len suffix len -- path len' ) \ 2swap tuck scratch 2+ move scratch 2+ swap 2swap dup >r 2over dup r> - 0max safe/string 2over compare IF >r >r tuck scratch 2+ swap move scratch 2+ swap r> r> 2swap + swap 2dup + 0 swap c! move scratch 2+ >len ELSE 2drop THEN ; previous minos [ELSE] : path+file ( path len file len -- file len ) >r >r tuck scratch 2+ swap move scratch 2+ swap r> r> 2swap '/' -scan + swap 2dup + 0 swap c! move scratch 2+ >len ; [THEN]