Celestin Apprentice 5

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / CGIshell 1.3.2 / Pocket 6.5 / Examples / Reader.pf < prev next >

Wrap

Text File | 1995-11-11 | 22.3 KB | 538 lines | [TEXT/McSk]

( Reader application for Pocket Forth 0.6.5 ) : .. ( -- ) key 13 = 0= IF bye ?terminal drop THEN 0 28 +md ! ; page ( ******************* W A R N I N G ******************** ) ( This file creates the ReadMe application. Do NOT run ) ( this file on a normal copy of Pocket Forth. Instead make ) ( a SPECIAL copy using ResEdit: ) ( 1} Open a copy of ReadMe with ResEdit ) ( 2} Delete the DICT 257 resource from ReadMe ) ( 3} Open a copy of Pocket Forth with ResEdit ) ( 4} Copy the DICT 257 resource from Pocket Forth ) ( 5} Paste the DICT 257 resource into ReadMe ) ( 6} Save ReadMe with ResEdit ) ( 7} Quit ResEdit and Open ReadMe ) ( 8} Type "open" and open Reader ) ( 9} Press the return key, wait until ReadMe quits. ) ( 10} Restart ReadMe. ) ( Type return to continue, anything else to quit. ) .. forget task : task ; : !FONT ( n -- ) >r ,$ A887 ; macro ( _TextFont ) : !FSIZE ( n -- ) >r ,$ A88A ; macro ( _TextSize ) : !FACE ( face -- ) >r ,$ A888 ; macro ( _TextFace ) : SFONT ( -- ) 0 !font 12 !fsize ; ( 12 point Chicago ) : NFONT ( -- ) 4 !font 12 !fsize ; \ 12 point Monaco : AFONT ( -- ) 1 !font 10 !fsize ; \ 10 point Geneva : LFONT ( -- ) nfont 9 !fsize ; \ 9 point Monaco : CLS ( -- ) 4 +md a>r ,$ A8A3 20 20 !pen ; ( CLear Screen ) ( old style colors ) : BLACK 33 0 2>r ,$ A862 ; ( black _ForeColor ) : RED 205 0 2>r ,$ A862 ; ( red _ForeColor ) : BLUE 409 0 2>r ,$ A862 ; ( blue _ForeColor ) ( rect words ) : RECT ( compile: -- ) ( run: -- addr ) variable 6 allot ; : !RECT ( t l b r rect -- ) >r swap r 4 + 2! swap r> 2! ; : @RECT ( rect -- t l b r ) dup 2@ swap rot 4 + 2@ swap ; : ROFFSET ( h v rect -- ) a>r 2>r ,$ A8A8 ; ( _OffsetRect ) : RINSET ( h v rect -- ) a>r 2>r ,$ A8A9 ; ( _InsetRect ) : ?EMPTY ( rect -- flag ) 0 >r a>r ,$ A8AE r> ; ( _EmptyRect ) : RERASE ( rect -- ) a>r ,$ A8A3 ; ( _EraseRect ) : ?PHIT ( h v poly -- flag ) ( true if h,v is in polyBBox ) 0 >r 2@ dl@ 2 0 d+ 2swap 2>r 2>r ,$ A8AD r> ; ( _PtInRect ) : POLYGON ( addr -- ) 0 0 2>r ,$ A8CB 2r> rot 2! ; ( _OpenPoly ) ( print PICT resources from this file ) : GETPICT ( id -- dhandle ) 0 0 2>r >r ,$ A9BC 2r> ; ( _GetPict ) : PDRAW ( rect dhandle -- ) ( draw a picture in rect ) 2>r a>r ,$ A8F6 ; ( _DrawPicture ) : DPICT ( rect id -- ) getpict pdraw ; ( create and destroy pictures ) : PICTURE ( rect -- dhandle ) ( open a picture ) 0 0 2>r a>r ,$ A8F3 2r> ; ( _OpenPicture ) : PCLOSE ,$ A8F4 ; macro ( _ClosePicture ) : PKILL ( addr -- ) 2@ 2>r ,$ A8F5 ; ( _KillPicture at addr ) \ color availability testing : ?COLOR ( -- f ) \ true if color is available and system>6.0.4 ,s qd ?gestalt dup IF 2drop 256 < 0= THEN ; ( icons ) : CIGET ( id -- d.handle ) ( call once per icon ) 0 0 2>r >r \ push room and id ?color IF ,$ AA1E ( _GetCIcon ) ELSE ,$ A9BB THEN 2r> ; ( _GetIcon ) : CIPLOT ( rect d.handle -- ) \ draw icon in rect rot a>r 2>r ?color IF ,$ AA1F ( _PlotCIcon ) ELSE ,$ A94B THEN ; ( _PlotIcon ) ( polygons for the 'NEXT' and 'PREV' "buttons" ) 2variable APOLY ( aft button poly handle ) 2variable FPOLY ( fore button poly handle ) : +APOLY ( -- ) apoly polygon 5 225 !pen 20 210 -to 50 210 -to 50 240 -to 20 240 -to 5 225 -to ,$ A8CC ; ( _ClosePgon ) : +FPOLY ( -- ) fpoly polygon 440 225 !pen 425 210 -to 390 210 -to 390 240 -to 425 240 -to 440 225 -to ,$ A8CC ; ( _ClosePgon ) ( display "buttons" ) : .POLY ( addr -- ) blue 2@ 2>r ,$ A8C6 black ; ( _FramePoly ) : .AARROW ( -- ) 015 230 !pen ." Prev" apoly .poly ; : .FARROW ( -- ) 396 230 !pen ." Next" fpoly .poly ; : .ARROWS ( -- ) .aarrow .farrow ; \ display icons variable ICONTABLE 0 iconTable ! 12 allot \ room for 2 icons ( no.of.entries id#1 handle#1 id#2 handle#2 ) : >ICON ( index -- addr ) 6 * iconTable 2+ + ; \ icon list entry (0 based) : +ICON ( id -- ) \ loads icon from disk and stores data in table iconTable @ >icon \ get entry address 2dup ! \ store id into table swap ciget rot 2+ 2! \ get & store handle 1 iconTable +! ; : .ICON ( id rect -- ) \ display icon in rect SWAP iconTable @ 0 DO \ search the icon table .. r >icon @ over = IF \ .. for the id wanted drop r >icon 2+ 2@ ciplot LEAVE THEN LOOP ; \ Flying Bird stuff rect BRECT 0 0 14 28 brect !rect ( the bird's rect ) rect OBRECT 0 0 0 0 obrect !rect ( old brect ) 2variable B1PICT ( hold b1's pict handle ) 2variable B2PICT ( hold b2's pict handle ) 2variable B3PICT ( hold b3's pict handle ) ( draw the three bird positions ) : .B1 red 2 0 !pen 6 0 -to 12 6 -to 18 0 -to 22 0 -to black ; : .B2 red 0 6 !pen 24 6 -to black ; : .B3 red 2 12 !pen 6 12 -to 12 6 -to 18 12 -to 22 12 -to black ; : +BIRD \ initialize the birds pictures & store the handles brect picture .b1 pclose b1pict 2! brect picture .b2 pclose b2pict 2! brect picture .b3 pclose b3pict 2! 0 0 0 0 brect !rect 0 0 0 0 obrect !rect ; : -BIRD b1pict pkill b2pict pkill b2pict pkill ; : B1 brect b1pict 2@ pdraw ; : B2 brect b2pict 2@ pdraw ; : B3 brect b3pict 2@ pdraw ; create .BS ' b1 , ' b2 , ' b3 , ( bird draw array ) variable BTHIS 0 bthis ! ( offset to the current routine ) 4 constant #BIRDS \ (number_of_birds-1)*2 : THISBIRD ( -- n ) bthis @ ; \ the current bird : NEXTBIRD ( -- ) 2 bthis +! ; \ set bthis to the next bird : FIRSTBIRD ( -- ) 0 bthis ! ; \ first picture in sequence : .BIRD ( n -- ) .bs + @ execute ; \ draw bird n : MOVEBIRD 3 -1 brect roffset ; \ translate brect down1 for 3right : SHRINKBIRD 1 1 brect rinset ; \ shrink brect by 2 pixels : ANIMATE ( -- ) ( draw the flying red bird ) brect ?empty IF \ if bird has shrunk to oblivion... 48 291 60 309 brect !rect THEN \ ...restore its origonal size obrect rerase \ erase the old rect brect @rect obrect !rect \ set old rect to current rect 0 -1 obrect rinset \ expand old rect for full erasure thisBird .bird \ draw the bird thisBird #birds < IF \ if its bird 1 or 2 nextBird moveBird \ increment bird and move rect ELSE \ its bird 3 firstBird moveBird shrinkBird \ cycle, move & shrink THEN ; ( rects for pictures ) rect PRECT 15 48 212 405 prect !rect ( title picture rect ) rect SRECT 192 222 221 370 srect !rect ( signature rect ) rect IRECT 170 194 203 227 irect !rect ( icon rect ) : SCR ( -- ) @pen swap drop 16 + 50 swap !pen ; ( special cr ) : LCR ( -- ) @pen swap drop 12 + 50 swap !pen ; ( little scr ) : BCR ( -- ) @pen swap drop 50 swap !pen ; ( cr without lf ) : .CONT ( -- ) 175 230 !pen ." ( continued ... )" ; ( P1 - P? are page drawing routines. They have no stack effect.) : P1 cls prect 4000 dpict .farrow ; : P2 cls scr ." Its FAST, its FUN and its FREE!" scr scr ." Its Pocket Forth, a programming language for" scr ." writing Macintosh applications and DAs." cr scr ." You can take advantage of many new features" scr ." in this release such as Apple Events*, Floating" scr ." Point, Gestalt** and Drag & Drop* programming." cr scr ." Learn Forth programming with the contents of" scr ." the Starting folder (inside the Extensions folder.)" scr scr scr ." * System 7 ** System 6.0.4+" srect 4001 dpict ( draw signature picture ) .arrows ; : P3 cls scr ." Code produced by Pocket Forth is compact and fast." cr scr ." Pocket Forth produces 68K machine code, so" scr ." you have complete control over your program." cr scr ." Examine and run the example, extension and" scr ." contributed files for programming suggestions." cr scr ." If you have system 7 you can load text files by" scr ." dragging a text file icon onto Pocket Forth's icon." cr scr ." All systems can use the menu to “Open” a file." 143 392 176 425 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) .arrows ; : P4 cls scr ." Print and read the Manual and the Glossary." cr scr ." The Manual consists of three TeachText documents" scr ." suitable for use as a reference to Pocket Forth." cr scr ." The Glossary, also a TeachText document, is a" scr ." list of the words in the Pocket Forth dictionary." scr ." Stack effects, pronunciation and usage are shown." cr scr ." User written code and documents are included" scr ." as examples and for your use." .arrows ; : P5 cls scr ." Major changes since release 5:" scr scr ." • Floating point numbers!" cr scr ." Numeric input containing a decimal point is" scr ." interpreted as an extended floating point" scr ." number. Floating Point numbers are kept on" scr ." the stack as ten byte entities." cr scr ." SANE is used along with three dozen new" scr ." words that manipulate floating point numbers." .cont .arrows ; : P6 cls scr ." Floating point continued ..." cr scr ." Stack words: " 2 !face ." fdrop fdup fswap fpick" scr ." fpack froll f>d d>f" cr scr 0 !face ." Memory words: " 2 !face ." f@ f! fliteral f," scr ." fconstant fvariable" cr scr 0 !face ." I/O words: " 2 !face ." fnumber sci fix f." cr scr 0 !face ." Math words: " 2 !face ." fcompare f+ f- f* f/" scr ." frem f^ fint fabs fsqrt" scr ." fsin fcos ftan fatn" scr ." fexp fln" 0 !face .arrows ; : P7 cls scr ." • Apple Events:" cr scr 21 352 54 385 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) ." Apple Events (System 7 required) are the" scr ." standard conduit for inter-application" scr ." communication. Pocket Forth programs may" scr ." define new Apple event handlers. The four" scr ." required events and all user defined events" scr ." are installed automatically when Pocket" scr ." Forth starts." cr scr ." HyperCard, Frontier and AppleScript examples" scr ." are in the 'Extensions:Apple Events' folder." .cont .arrows ; : P8 cls scr ." New words and variables control Apple Events:" cr scr 2 !face ." AE: " 0 !face ." and " 2 !face ." AE: " 0 !face ." begin and end event definitions" scr 2 !face ." ,S " 0 !face ." compile (or stack) 4 bytes from ASCII" scr afont ." (also useful in many other contexts)" sfont cr scr 2 !face ." +Md " 0 !face ." variables:" scr ." 136 Apple Event handler routine" scr ." 188 Address of installation list" scr ." 190 Error handler routine (" 2 !face ." drop " 0 !face ." )" scr ." 198 Reply record handle holder" scr ." 202 Apple Event record handle" .arrows ; : P9 cls scr ." • Use " 2 !face ." ?gestalt " 0 !face ." to query the system." cr scr ." Using this new system trap, available since" scr ." late system 6, you can determine much about" scr ." the system software and hardware." scr scr ." • A color conscious window is created if a" scr ." color machine is in use. This has no visual" scr ." effect but allows your programs to use color." scr scr ." • A new color icon and signature is used." 336 216 !pen lfont ." p4TH" sfont 175 335 207 367 irect !rect ( set icon rect ) 129 irect .icon ( draw the icon ) .arrows ; : P10 cls scr ." New for 6.3:" cr scr ." • The word \ makes comments more effecitve." cr scr ." • " 2 !face ." Warm " 0 !face ." restarts Pocket Forth, but leaves" scr ." the dictionary intact." cr scr ." • " 2 !face ." Depth " 0 !face ." lets you know how many items are" scr ." on the stack." scr scr ." • Check out the Balloon Help." 164 261 197 294 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) .arrows ; : P11 cls scr ." Bug fixes:" cr scr ." • The manual has been updated." cr scr ." • " 2 !face ." Back " 0 !face ." now compiles correct branches." cr scr ." • A 32 bit address error in the update" scr ." routine has been fixed." cr scr ." • " 2 !face ." Bye " 0 !face ." does not use _ExitToShell." cr scr ." • " 2 !face ." QUIT " 0 !face ." leaves the stack untouched." cr scr .cont .arrows ; : P12 cls scr ." Bug fixes, continued ... (New in 6.3)" cr scr ." • Tabs are now converted to spaces before" scr ." interpreting, so they no longer cause errors." cr scr ." • Now works with AppleScript (6.4) in" scr ." addition to Userland's Frontier." cr scr ." • " 2 !face ." +LOOP " 0 !face ." now works correctly (6.5)." cr scr ." • " 2 !face ." TYPE " 0 !face ." handles zero length strings (6.5)." 96 315 129 348 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) .arrows ; : P13 cls scr ." Notes:" cr scr ." • A DA version is included. Version 1.6.5" scr ." includes all of the new features except for" scr ." Apple Events support." cr scr ." • " 2 !face ." Grow " 0 !face ." has been removed from the application." scr ." Allocated memory is 32K for both application" scr ." and DA." cr scr ." • Choosing “Save” from the menu confirms your" scr ." choice before overwriting the dictionary." cr scr .cont .arrows ; : P14 cls scr ." Notes, continued ..." cr scr ." • 68040's instruction cache must be off to" scr ." compile code correctly." cr scr ." • Power Macs compile and run Pocket Forth" scr ." in emulation without problems." cr scr ." • The floating point interpreter will attempt" scr ." to convert any undefined token to a number." scr ." If the token begins with a number, it will" scr ." be converted causing unexpected results." .arrows ; : P15 cls scr ." Packing list for Pocket Forth, release 6.5:" scr scr ." • The application, Pocket Forth version 0.6.5" scr ." • The desk accessory, PocketDA version 1.6.5" cr scr ." Text files:" scr ." • The Manual parts 1, 2, 3 and a FAQ." scr ." • The Glossary of Pocket Forth words" scr ." • Source code with assembly instructions" scr ." and an assembly script for Frontier." scr ." • Source and Manual Addendum for the DA." cr scr scr .cont .arrows ; : P16 cls scr ." • Example folder: (Packing list cont.)" cr scr ." create this application" bcr ." Reader" scr ." the guts of a text editor" bcr ." TextEdit" scr ." converse with your computer" bcr ." Eliza" scr ." the Sieve of Erastothanes" bcr ." Sieve" scr ." demonstrate them" bcr ." Window&Menu" scr ." floating point trig. functions" bcr ." SANETrig" scr ." 16/32 bit math functions" bcr ." IntegerTrig" scr ." QuickDraw routines with demo" bcr ." Graphics" scr ." an RPN scientific calculator" bcr ." Calculator" cr scr scr .cont .arrows ; : P17 cls scr ." • Extension folder: (Packing list cont.)" cr scr ." Make Pocket Forth mostly" bcr ." Starting folder" scr ." compatable with " 4 !face ." Starting" bcr nfont 2 !face ." ATTENTION" 0 !face sfont scr ." " 4 !face ." Forth" 0 !face ." by Leo Brodie!" bcr nfont 2 !face ." BEGINNERS!" 0 !face sfont cr scr ." A folder with new event" bcr ." Apple Events" scr ." definitions and interface files for" scr ." Frontier, HyperCard & AppleScript." cr scr ." A library of utility and" bcr ." Misc" scr ." debugging routines." 128 94 161 127 irect !rect ( set icon rect ) 128 irect .icon ( draw the icon ) .cont .arrows ; : P18 cls scr ." • Extension folder cont: (Packing list cont.)" cr scr ." Words to manipulate null" bcr ." Strings" scr ." terminated strings." cr scr ." The Forth Vendors Group" bcr ." fvgFloatingPoint" scr ." floating point standard." cr scr ." Create, delete and manipulate" bcr ." DataFiles" scr ." text files by name or dialog." .cont .arrows ; : P19 cls scr ." • Contributions: (Packing list cont.)" cr scr ." How to use sound and pop-up" bcr ." From Consuegra" scr ." menus in your programs." cr scr ." A fractal drawing program." bcr ." From Gates" scr ." Double click on the Mandelbrot" scr ." icon to run the program." cr scr ." Control the World Wide Web" bcr ." From Kneusel" scr ." with this CGI Shell." .cont .arrows ; : P20 cls scr ." • Contributions cont.: (Packing list cont.)" cr scr ." Documentation in Japanese and" bcr ." From Nagasawa" scr ." some nice animation." cr scr ." Case and object oriented" bcr ." From Peters" scr ." extensions to Pocket Forth." cr scr ." Forth written in Forth!" bcr ." From Webb" cr scr ." Other files from M. Roberts, R. Chuo and others" scr ." are included. Thanks to all of you!" .arrows ; : P21 cls scr ." If you find a bug, need help, or want to talk" scr ." about this, write. I'd like to hear from you and" scr ." I'll attempt to answer your mail." afont ." *" sfont cr scr ." Contact me at any of the following addresses:" scr ." Email heilman@pc.maricopa.edu" scr ." U.S. Mail PO box 8345" scr ." Phoenix AZ 85066-8345" cr scr ." or on the World Wide Web at the following URL:" scr ." http://chemlab.pc.maricopa.edu/pocket.html" cr lcr lcr ." " afont ." * Be patient though, it takes some time " ." for me to make up an answer." lcr sfont ." " afont ." If you haven't heard from me in a week " ." or so, write again. Thanks." sfont .aarrow ; \ page list variable PWHICH 0 pwhich ! ( page-1 to be drawn ) 20 constant PNO ( number of pages-1 ) create PLIST ( ordered list of routines or "pages" ) ' p1 , ' p2 , ' p3 , ' p4 , ' p5 , ' p6 , ' p7 , ' p8 , ' p9 , ' p10 , ' p11 , ' p12 , ' p13 , ' p14 , ' p15 , ' p16 , ' p17 , ' p18 , ' p19 , ' p20 , ' p21 , ( update, menu, button and idle handlers ) : DOUP pwhich @ 2* plist + @ execute ; ( draw the pwhichth page ) : DON ( n -- ) pwhich ! doup ; ( go to nth page ) : DOAFT pwhich @ 1 - 0 max don ; ( decrement pwhich ) : DOFOR pwhich @ 1+ pno min don ; ( increment pwhich ) : DOFIRST 0 don ; ( go to first page ) : DOLAST pno don ; ( go to last page ) : DONEW 4 don ; \ go to "whats new" page : DOBUG 10 don ; \ go to "bug fixes" page : DONOTE 12 don ; \ go to "notes" page : DOPACK 14 don ; \ go to "packing list" page : STOP -bird bye ; ( stop animating ) \ menu list create GMENU ' dofirst , ' doaft , ' dofor , ' dolast , ' null , ' donew , ' dobug , ' donote , ' dopack , ' dolast , create FMENU ' stop , create MBAR fmenu , 18 +md @ 2+ @ , gmenu , 2variable GMENUH 0 0 gmenuh 2! ( holder for goMenuHandle ) ' beep 18 +md @ ( get pointer to menu list ) 2+ @ ( get pointer to Edit menu from menu list ) 8 + ! ( set paste handler to beep ) : +MENU ( -- ) ( Turn the new menu on.) 0 0 2>r 4 >r ,$ A9BF ( _GetRMenu ) 2r> 2dup 2>r 0 >r ,$ A935 ( _InsertMenu ) gmenuh 2! ,$ A937 ; ( _DrawMenuBar ) : DOBUTT ( -- ) ( button handler ) @mouse apoly ?phit IF apoly 2@ 2>r ,$ A8C9 doaft ELSE @mouse fpoly ?phit IF fpoly 2@ 2>r ,$ A8C9 dofor THEN THEN ; \ Idle procedure variable TLAST 0 tlast ! ( timer ) 10 constant DELAY : TICKS ( -- n ) 364 0 l@ ; : ?TIME ( -- flags ) ( true if 1/delay seconds has elapsed ) ticks tlast @ - abs delay > ; : DOIDLE ( do the first page animation ) pwhich @ 0= IF ( if its the title page ) ?time IF ticks tlast ! animate THEN THEN ; \ startup procedure : START sfont \ Set to 12 point Chicago 2 >r ,$ A889 \ SrcXor _TextMode +apoly +fpoly \ This is stuff that must +menu +bird \ be set up at runtime, 128 +icon 129 +icon \ because it uses handles. BEGIN ?terminal drop AGAIN ; ( event loop ) \ This is event handlers and data to set up when this is loaded. ' doup 14 +md ! \ set update handler ' dobutt 16 +md ! \ set button handler mbar 18 +md ! \ set the menu handlers ' doidle 20 +md ! \ set idle handler ' stop 22 +md ! \ set quit handler ' start 26 +md ! \ set startup handler ' null 136 +md ! \ disable Apple Events 450 250 8 +md 2! \ set window size save bye