\ test testwin 18sep96py \ traceall minos also forth [IFUNDEF] noop sub-viewport \needs xconst | import xconst xconst also x11 also forth include viewport.fs ' sub-viewport alias viewport onlyforth minos also forth [THEN] screen self menu-window : win0 \ test testwin 24sep96py \ ' win0 Alias view0 \ backing : view0 1 1 viewport : view0 \ dbuf0 self doublebuffer : view0 \ view0 noback off 0 ' noop edit-action new s" " s" Text:" infotextfield : tfield0 \ 0 edit-action new s" " (textfield : tfield0 : .button button text @ @+ swap tfield0 assign ; : .pos base push decimal dup 0 <<# #s #> tfield0 assign #>> ; 0 :noname s" Test 0" tfield0 assign ; simple new s" Menu 0" menu-entry : menu0 0 :noname s" Test 1" tfield0 assign ; simple new s" Menu 1" menu-entry : menu1 0 :noname s" Test 2" tfield0 assign ; simple new s" Menu 2" menu-entry : menu2 menu0 self menu1 self menu2 self 3 vabox : test-menu0 2 test-menu0 borderw c! test-menu0 self s" Sub-Menu" sub-menu : sub0 0 :noname s" Test 0" tfield0 assign ; simple new s" Menu 0" menu-entry : menu0a 0 :noname s" Test 1" tfield0 assign ; simple new s" Menu 1" menu-entry : menu1a 0 :noname s" Test 2" tfield0 assign ; simple new s" Menu 2" menu-entry : menu2a 0 ' wood simple new s" Wood" menu-entry : menu-wood 0 ' water simple new s" Water" menu-entry : menu-water 0 ' water1 simple new s" Caustics" menu-entry : menu-water1 0 ' marble simple new s" Marble" menu-entry : menu-marble 0 ' cracle simple new s" Cracle" menu-entry : menu-cracle 0 ' paper simple new s" Paper" menu-entry : menu-paper 0 ' mono simple new s" Mono" menu-entry : menu-mono 0 ' gray-colors simple new s" Gray" menu-entry : menu-gray 0 ' red-colors simple new s" Red" menu-entry : menu-red 0 ' blue-colors simple new s" Blue" menu-entry : menu-blue 0 ' bisque-colors simple new s" Bisque" menu-entry : menu-bisque menu0a self menu1a self sub0 self menu2a self 4 vabox : test-menu1 2 test-menu1 borderw c! menu-wood self menu-water self menu-water1 self menu-marble self menu-cracle self menu-paper self menu-mono self hline menu-gray self menu-red self menu-blue self menu-bisque self &12 vabox : test-menu2 2 test-menu2 borderw c! test-menu0 self s" bigFORTH" menu-title : title0 test-menu1 self s" File" menu-title : title1 test-menu2 self s" Options" menu-title : title2 title0 self title1 self title2 self 2fill 4 hbox : menu-title0 menu-title0 self vfixbox drop 0 ' .button simple new s" Testbutton" lbutton : button0 0 ' .button simple new s" Button 1" button : button1 0 ' .button simple new s" But 2" button : button2 0 ' .button simple new s" Button 3" button : button3 0 ' .button simple new s" Button 4" button : button4 \ 0 ' .button simple new s" Button 5" button : button5 ficon: printer-icon ./icons/printer" 0 ' .button simple new printer-icon s" Printer-Icon" big-icon : button5 [IFUNDEF] win32s doublebuffer : dbuf1 [ELSE] ' view0 alias dbuf1 [THEN] Variable cv1task : xto ( x y n1 n2 -- ) 2dup >= IF - $100 min tuck * 8 >> >r * 8 >> r> canvas to ELSE 2drop 2drop THEN ; : draw-cv1 ( o -- flag ) canvas with $300 $400 steps 0 1 textpos timer@ $E << $1000 um* nip >r clear 2 linewidth $00 $00 $FF rgb> drawcolor $FF $00 $00 rgb> fillcolor $080 $380 home! path $000 $200 r@ $100 xto $100 $100 r@ $200 xto $100 -$100 r@ $300 xto -$200 $000 r@ $400 xto $200 -$200 r@ $500 xto $000 $200 r@ $600 xto -$200 -$200 r@ $700 xto $200 $000 r@ $800 xto r@ $900 >= IF fill THEN stroke r@ $000 $200 within IF s" wer" THEN r@ $200 $300 within IF s" malt" THEN r@ $300 $400 within IF s" das" THEN r@ $400 $500 within IF s" Haus" THEN r@ $500 $600 within IF s" vom" THEN r@ $600 $700 within IF s" Ni-" THEN r@ $700 $800 within IF s" Niko-" THEN r@ $800 >= IF s" Nikolaus" THEN text 0 linewidth r> $900 >= endwith ; :noname cv1task @ IF draw-cv1 drop EXIT THEN 1 $1000 dup NewTask dup cv1task ! pass canvas with shown on BEGIN ^ draw-cv1 dpy sync IF BEGIN -1 &30 idle timer@ $E << &1000 um* nip $100 < UNTIL ELSE -1 &30 idle THEN shown @ 0= UNTIL endwith cv1task off ; 0 :noname 2drop 2drop ; simple new $41 $2 *fill $61 $3 *fill canvas : canvas1 canvas1 self dbuf1 assign Forward show-it 0 :noname s" Bisque" show-it bisque-colors ; simple new s" Bisque" menu-entry : info0a 0 :noname s" Gray" show-it gray-colors ; simple new s" Gray" menu-entry : info0b 0 :noname s" Red" show-it red-colors ; simple new s" Red" menu-entry : info0c 0 :noname s" Blue" show-it blue-colors ; simple new s" Blue" menu-entry : info0d 0 :noname s" Paper" show-it paper ; simple new s" Paper" menu-entry : info1 0 :noname s" Wood" show-it wood ; simple new s" Wood" menu-entry : info2 0 :noname s" Water" show-it water ; simple new s" Water" menu-entry : info3 0 :noname s" Caustics" show-it water1 ; simple new s" Caustics" menu-entry : info4 0 :noname s" Red Marble" show-it marble ; simple new s" Red Marble" menu-entry : info5 0 :noname s" Cracle" show-it cracle ; simple new s" Cracle" menu-entry : info6 0 :noname s" Mono" show-it mono ; simple new s" Mono" menu-entry : info7 info0a self info0b self info0c self info0d self hline info1 self info2 self info3 self info4 self info5 self info6 self info7 self &12 vabox : info-menu0 2 info-menu0 borderw c! info-menu0 self s" Coolness:" info-menu : info-m0 : show-it ( addr u -- ) info-m0 assign ; \ ' (show-it IS show-it button1 self 2skip button2 self 2fill button3 self 5 hatbox : box0 2 box0 borderw c! Variable pos Variable pos1 Variable pos2 Variable pos3 : par! .pos pos ! ; : slpar $40 $10 pos @ ; : par1! .pos pos1 ! ; : slpar1 $40 $10 pos1 @ ; : par2! .pos pos2 ! ; : slpar2 &10000 pos2 @ ; : par3! pos3 ! ; : slpar3 &1000 pos3 @ ; 0 ' par! ' slpar toggle-state new hslider : slider0 0 ' par1! ' slpar1 toggle-state new hslider : slider1 0 ' par3! ' slpar3 toggle-state new hscaler : scaler0 -&500 scaler0 offset ! slider0 self slider1 self 2 habox new scaler0 self 2 vabox : box1 0 ' par2! ' slpar2 toggle-state new vscaler : slider2 2skip 2skip 0 ' .button simple new s" Sub-Topic A.0" lbutton new 0 ' .button simple new s" Sub-Topic A.1" lbutton new 0 ' .button simple new s" Sub-Topic A.2" lbutton new 3 vabox new tuck 2 habox new ( vflip new dup ) swap flipbox combined ' flip simple new s" Topic A" lbutton new swap 0 ' .button simple new s" Topic B" lbutton new 0 ' .button simple new s" Topic C" lbutton new 4 vabox new flipbox tuck 2 habox : fbox0 \ boxl self vflip : fbox0 \ fbox0 self fbox0 ' flip S" Flip It!" lbutton : fbutton 0 hbox ' +flip hbox ' -flip toggle new s" -" t" +" togglebutton : fbutton0 0 ' .button simple new s" Flip It!" lbutton : fbutton1 fbutton0 self 1 vabox new hfixbox fbutton1 self 2 habox : fbutton \ variants minos 0 ' .button simple new s" Index0" button : bvar0a 0 ' .button simple new s" Klick mal" button : bvar0b bvar0a self bvar0b self 2fill 3 habox : var0l var0l self panel drop 0 ' .button simple new s" Index 1" button : bvar1a 0 ' .button simple new s" Kuck mal" button : bvar1b bvar1a self bvar1b self 2fill 3 hatbox : var1l var1l self panel drop 0 ' .button simple new s" Kuck" button : bvar2a 0 ' .button simple new s" mal" button : bvar2b 0 ' .button simple new s" wer" button : bvar2c 0 ' .button simple new s" da" button : bvar2d 0 ' .button simple new s" spricht" button : bvar2e bvar2a self bvar2b self bvar2c self bvar2d self bvar2e self 5 habox : var2l var2l self panel drop forth : -flip vbox attribs c@ :flip or vbox attribs c! ; var0l self 1 vabox new dup -1 vabox ' +flip ' -flip toggle new s" Index 0" topindex : tindex0 var1l self 1 vabox new flipbox dup 0 vabox ' +flip ' -flip toggle new s" Index 1" topindex : tindex1 var2l self 1 vabox new flipbox dup 0 vabox ' +flip ' -flip toggle new s" Index 2" topindex : tindex2 3 vabox : variant0 tindex0 self tindex1 self tindex2 self 3 harbox : variant1 variant0 self 2 borderbox :notshadow noborderbox drop variant1 self variant0 self 2 vabox : variants button0 self box0 self info-m0 self variants self button4 self button5 self [IFDEF] win32 dbuf1 self [ELSE] :beamer beamer : beam1 dbuf1 self beam1 assign beam1 self [THEN] 1 habox new -2 borderbox 2 habox new tfield0 self ( 1 habox new -2 borderbox ) box1 self fbutton self fbox0 self 2 vabox new 9 vabox : box2: box2: self panel drop box2: self 1 habox : box2 \ box2 self vfixbox drop \ Radiobuttons 03oct96py 1 1 vviewport : view1 \ view1 noback off ficon: exclam-icon ./icons/mini-exclam" ficon: cross-icon ./icons/mini-cross" ficon: ball-icon ./icons/red-dot" ficon: rball-icon ./icons/green-dot" : noop-sw 0 ['] noop dup toggle new ; 0 noop-sw cross-icon exclam-icon s" Toggle 0" ticonbutton : rbutton0 0 noop-sw cross-icon exclam-icon s" Toggle 1" ticonbutton : rbutton1 0 noop-sw cross-icon exclam-icon s" Toggle 2" ticonbutton : rbutton2 0 noop-sw cross-icon exclam-icon s" Toggle 3" ticonbutton : rbutton3 0 noop-sw s" Toggle 4" rbutton : rbutton4 0 noop-sw s" Toggle 5" rbutton : rbutton5 0 noop-sw s" Toggle 6" rbutton : rbutton6 0 noop-sw s" Toggle 7" rbutton : rbutton7 0 noop-sw ball-icon rball-icon s" Toggle 8" ticonbutton : rbutton8 0 noop-sw ball-icon rball-icon s" Toggle 9" ticonbutton : rbutton9 0 noop-sw ball-icon rball-icon s" Toggle A" ticonbutton : rbuttonA 0 noop-sw ball-icon rball-icon s" Toggle B" ticonbutton : rbuttonB 0 noop-sw s" Toggle C" tbutton : rbuttonC 0 noop-sw s" Toggle D" tbutton : rbuttonD 0 noop-sw s" Toggle E" tbutton : rbuttonE 0 noop-sw s" Toggle F" tbutton : rbuttonF rbutton0 self rbutton1 self rbutton2 self rbutton3 self rbutton4 self rbutton5 self rbutton6 self rbutton7 self 8 varbox : boxT0 rbutton8 self rbutton9 self rbuttonA self rbuttonB self rbuttonC self rbuttonD self rbuttonE self rbuttonF self 8 vabox : boxT1 boxT0 self boxT1 self 2 habox : boxT2 boxT2 self vfixbox drop boxT2 self view1 assign \ view1 'vslide vslider0 : slider3 \ slider3 self view1 bind vspos \ test testwin 25sep96py box2 self slider2 self 2 habox : box3 view1 self asliderview : box3- box3- self 1 vabox : box3-+ box3 self vrtsizer new 2 vasbox : box3+ box3+ self \ vsiz0 self $0 1 *fill 2dup glue new \ vsiz1 self vrtsizer new $0 1 *fil 2dup glue new hrtsizer new 2 hasbox new box3-+ self \ vsiz1 self box3-+ self 2 vabox new hrtsizer new 2 hasbox new $0 1 *fil 2dup glue new 3 habox new 2 vasbox new 3 vabox : box3'' box3'' self view0 assign \ dbuf0 assign menu-title0 self view0 self s" bigFORTH" win0 assign 0 0 &300 &400 win0 resize win0 show \ win0 sync [IFDEF] beam1 : beam-clone screen self window new window with beam1 clone s" Clone" assign show endwith ; beam-clone [THEN] \ Another window: Add two numbers screen self window : win1 0 ' noop number-action new 0. s" A:" infotextfield : a 0 ' noop number-action new 0. s" B:" infotextfield : b 0 ' noop number-action new 0. s" R:" infotextfield : result 0 :noname a get b get d+ result assign ; simple new s" +" button : add 0 :noname a get b get d- result assign ; simple new s" -" button : sub 0 :noname a get b get d* result assign ; simple new s" *" button : mul 0 :noname result get a assign ; simple new s" A" button : toa 0 :noname result get b assign ; simple new s" B" button : tob add self 2skip sub self 2skip mul self 2skip toa self 2skip tob self 9 hatbox : box4 a self b self box4 self hline result self 5 vabox : box5 box5 self panel drop box5 self s" Calculator" win1 assign 0 0 &200 &100 win1 resize win1 show \ test testwin 25sep96py \ : get-event screen handle-event &20 idle ; \ : get-events $1000 dup NewTask activate BEGIN get-event AGAIN ;