home *** CD-ROM | disk | FTP | other *** search
- ( Color Graphics Extensions 01/12/84 ) ;S Copyright (c) 1982, 1983, 1984 Ray Duncan and Rick Wilton Laboratory Microsystems, Inc. 4147 Beethoven Street Los Angeles, CA 90066 (213) 306-7412 modified Nov 15 1983 for PC/FORTH 2.0 modified Jan 11 1984 for PC/FORTH+ 2.0 and version independence ( Master load screen for graphics extensions 01/12/84 ) FORTH DEFINITIONS CR CR .( Wait ... loading graphics extensions) CR DECIMAL 2 LOAD CR .( Version dependence) DECIMAL 8 LOAD CR .( Disk save/load) DECIMAL 11 LOAD CR .( Graphics hard copy) DECIMAL 18 LOAD CR .( Graphics commands) DECIMAL 28 LOAD CR .( Window management) DECIMAL 32 LOAD CR .( Turtle graphics) CR CR .( Graphics extensions loaded.) CR CR ( Version dependence 01/12/84 ) DECIMAL ( 16_par 32_par --- correct_par ) : VSel WSIZE 2 <> IF SWAP THEN DROP ; 59 60 VSel LOAD ( System messages ) empty stack dictionary full has incorrect address mode is redefined is undefined disk address out of range stack overflow disk error BASE must be DECIMAL missing decimal point PC/FORTH 2.0 Laboratory Microsystems( System messages ) compilation only, use in definition execution only conditionals not paired definition not finished in protected dictionary use only when loading off current editing screen declare vocabulary illegal dimension in array definition negative array index array index too large ( 8086 Assembler messages ) 16 bit register not allowed 8 bit register not allowed address out of range immediate data value not allowed missing source register missing destination register illegal operation illegal operand instruction not implemented illegal destination register illegal source register illegal condition code register mismatch destination address missing ( Memory dump, byte format, intersegment 02/26/82 ) FORTH DEFINITIONS DECIMAL : DUMP ( segment offset length --- ) DEPTH 3 < 1 ?ERROR BASE @ >R HEX CR CR 10 SPACES 16 0 DO I 3 .R LOOP 2 SPACES 16 0 DO I 0 <# # #> TYPE LOOP CR OVER + SWAP DUP 15 AND XOR DO CR DUP 0 <# # # # # #> TYPE 58 EMIT ( segment ) I 0 <# # # # # #> TYPE SPACE ( offset ) I 16 + I DO DUP I C@L 0 <# # # #> SPACE TYPE LOOP 2 SPACES I 16 + I DO DUP I C@L DUP 32 < OVER 126 > OR IF DROP 46 THEN EMIT LOOP ?TERMINAL IF KEY DROP LEAVE THEN 16 +LOOP DROP CR R> BASE ! ; ( Save and load video image from disk file 01/12/84 ) FORTH DEFINITIONS DECIMAL VARIABLE IMAGE-FCB 35 ALLOT : SET-IMG-EXT LIT" IMG" COUNT IMAGE-FCB 9 + SWAP CMOVE ; : SET-FILENAME IMAGE-FCB DUP 37 ERASE 1+ DUP 11 BLANK BL WORD 1+ SWAP HERE C@ 8 MIN CMOVE SET-IMG-EXT ; --> ( Save and load video image from disk file 01/12/84 ) DECIMAL : WOPEN-IMAGE SET-FILENAME 22 IMAGE-FCB ADDR>FDOS DROP 255 AND 255 = IF ." Cannot create " IMAGE-FCB .FCB QUIT THEN 16384 IMAGE-FCB 14 + W! ; : ROPEN-IMAGE SET-FILENAME 15 IMAGE-FCB ADDR>FDOS DROP 255 AND 255 = IF ." Can't find " IMAGE-FCB .FCB QUIT THEN 16384 IMAGE-FCB 14 + W! ; --> ( Save and load video image from disk file 01/12/84 ) : CLOSE-IMAGE 16 IMAGE-FCB ADDR>FDOS 2DROP ; : SAVE-IMAGE WOPEN-IMAGE SET-DTA 34 IMAGE-FCB ADDR>FDOS DROP 255 AND IF CR 7 EMIT ." Not enough room on disk " CR CR THEN CLOSE-IMAGE ; : GET-IMAGE ROPEN-IMAGE SET-DTA 33 IMAGE-FCB ADDR>FDOS 2DROP CLOSE-IMAGE ; DECIMAL ;S ( High res graphics hard copy 07/05/82 ) FORTH DEFINITIONS HEX B800 CONSTANT cgmap ( seg. addr of memory map) VARIABLE BIT-BUFFER 1DE ALLOT ( build printer output here ) VARIABLE HBIT-TABLE -2 ALLOT ( bit masks ) 80 C, 40 C, 20 C, 10 C, 8 C, 4 C, 2 C, 1 C, ( Fetch dot value from memory. Stack effect: x y --- f ) : @HDOT DUP 1 AND ( calc byte addr,if y odd) IF 2000 ELSE 0 THEN ( then offset by 2000h) SWAP 2/ 50 * + OVER 8 / + ( each dot row=80 bytes) cgmap SWAP C@L SWAP 7 AND ( get mask from table to) HBIT-TABLE + C@ AND ( test dot position ) IF 1 ELSE 0 THEN ; ( return 1 if dot on,else 0) --> ( High res graphics hard copy 07/05/82 ) ( after a pattern has been built into BIT-BUFFER ) ( corresponding to X=0 to 479 and Y=Y to Y+3 by ) ( DUMP-MAP, this routine sends it to the printer ) : SEND-LINE 0A EMIT ( line feed) ( make sure something is in buffer ) 0 1E0 0 DO I BIT-BUFFER + C@ OR LOOP IF 1B EMIT 4B EMIT ( graphics mode ) E0 EMIT 01 EMIT ( 480 bytes will be sent) 1E0 0 DO ( transmit this byte ) BIT-BUFFER I + C@ EMIT LOOP THEN ; --> ( High res graphics hard copy 07/05/82 ) : HDUMP-MAP C8 0 DO ( for y=0 to 199 step 4 ) 1E0 0 DO 0 ( for x=0 to 479 ) I J @HDOT IF 80 OR THEN ( x,y ) I J 1+ @HDOT IF 20 OR THEN ( x,y+1 ) I J 2+ @HDOT IF 8 OR THEN ( x,y+2 ) I J 3 + @HDOT IF 2 OR THEN ( x,y+3 ) BIT-BUFFER I + C! LOOP ( next x ) SEND-LINE ?TERMINAL IF KEY DROP LEAVE THEN 4 +LOOP ; ( next y ) : HDUMP PRINTER 1B EMIT 41 EMIT 08 EMIT ( set spacing) HDUMP-MAP CONSOLE ; --> ( Color medium resolution graphics hard copy 07/05/82 ) VARIABLE CBIT-TABLE -2 ALLOT ( bit masks ) C0 C, 30 C, 0C C, 03 C, ( Fetch dot value from memory. Stack effect: x y --- f ) : @CDOT DUP 1 AND ( calc byte addr,if y odd) IF 2000 ELSE 0 THEN ( then offset by 2000h) SWAP 2/ 50 * + OVER 4 / + ( each dot row=80 bytes) cgmap SWAP C@L SWAP 3 AND ( get mask from table to) CBIT-TABLE + C@ AND ( test dot position ) IF 1 ELSE 0 THEN ; ( return 1 if dot on,else 0) --> ( Color medium resolution graphics hard copy 07/05/82 ) : CDUMP-MAP C8 0 DO ( for y=0 to 199 step 8 ) 140 0 DO 0 ( for x=0 to 319 ) I J @CDOT IF 80 OR THEN ( x,y ) I J 1+ @CDOT IF 40 OR THEN ( x,y+1 ) I J 2+ @CDOT IF 20 OR THEN ( x,y+2 ) I J 3 + @CDOT IF 10 OR THEN ( x,y+3 ) I J 4 + @CDOT IF 08 OR THEN ( x,y+4 ) I J 5 + @CDOT IF 04 OR THEN ( x,y+5 ) I J 6 + @CDOT IF 02 OR THEN ( x,y+6 ) I J 7 + @CDOT IF 01 OR THEN ( x,y+7 ) BIT-BUFFER I + C! LOOP ( next x ) SEND-LINE ?TERMINAL IF KEY DROP LEAVE THEN 8 +LOOP ; ( next y ) --> ( Color medium resolution graphics hard copy 07/05/82 ) : CDUMP BIT-BUFFER 1E0 ERASE PRINTER 1B EMIT 41 EMIT 08 EMIT ( set spacing) CDUMP-MAP CONSOLE ; --> ( Sideways graphic dump RJW 12/07/83 ) FORTH DEFINITIONS HEX : SDUMP PRINTER CR 0C EMIT ( clear out buffer, form feed) 1B EMIT 33 EMIT 18 EMIT CR CR CR ( dot graphics) HERE 200 + 196 ERASE FF DUP HERE 200 + C! HERE 395 + C! ( output vector ) 50 0 DO ( do over 80 cols) HERE 392 + 1F40 0 DO B800 I J + C@L 2DUP SWAP C! OVER 1- C! 2- ( even line ) BA00 I J + C@L 2DUP SWAP C! OVER 1- C! 2- ( odd line ) 50 +LOOP 5 SPACES 1B EMIT 4B EMIT 96 EMIT 1 EMIT HERE 200 + 196 TYPE CR DROP LOOP 1B EMIT 33 EMIT CA EMIT CR CR ( reset printer ) 1B EMIT 32 EMIT 1B EMIT 40 EMIT 0C EMIT CONSOLE ; DECIMAL ;S ( misc primitives 12/08/83 ) DECIMAL : 4DUP 3 PICK 3 PICK 3 PICK 3 PICK ; : 8DUP 7 PICK 7 PICK 7 PICK 7 PICK 7 PICK 7 PICK 7 PICK 7 PICK ; ( : AUDIT4 PRINTER 4DUP CR SWAP ." X=" . ." Y=" . SWAP ." X=" . ." Y=" . CONSOLE ; ) ( xul yul xlr ylr color --- ) : BOX >R 1 PICK 3 PICK 5 PICK 5 PICK R@ LINE ( top ) 3 PICK 1 PICK 5 PICK 5 PICK R@ LINE ( left) 1 PICK 3 PICK 3 PICK 3 PICK R@ LINE ( right ) 3 PICK 1 PICK 3 PICK 3 PICK R> LINE ( bottom) 4DROP ; --> ( rectangle 12/08/83 ) ( xul yul xlr ylr color --- ) : XBOX >R 1 PICK 3 PICK 5 PICK 5 PICK R@ XLINE ( top ) 3 PICK 1 PICK 5 PICK 5 PICK R@ XLINE ( left) 1 PICK 3 PICK 3 PICK 3 PICK R@ XLINE ( right ) 3 PICK 1 PICK 3 PICK 3 PICK R> XLINE ( bottom) 4DROP ; ( points must be specified in order around the edge ) ( x1 y1 x2 y2 x3 y3 x4 y4 color --- ) : RECTANGLE DEPTH 9 < 1 ?ERROR >R 4DUP R@ line ( 3,4 side ) 7 PICK 7 PICK R@ line ( 1,4 side ) 3 PICK 3 PICK R@ line ( 2,3 side ) R> line ; ( 1,2 side ) --> ( triangle 05/04/82 ) ( points may be specified in any order ) ( x1 y1 x2 y2 x3 y3 color --- ) : TRIANGLE DEPTH 7 < 1 ?ERROR >R 4DUP R@ line ( 2,3 side ) 5 PICK 5 PICK R@ line ( 1,3 side ) R> line ; ( 1,2 side ) --> ( arc 07/13/82 ) 0 CONSTANT XOFS 0 CONSTANT YOFS 0 CONSTANT CHUE 60 CONSTANT CMAG 0 CONSTANT XPREV 0 CONSTANT YPREV 0 CONSTANT CINCR : CADJ ?MODE 6 < IF 92 ELSE 48 THEN ['] CMAG 2+ ! ; ( x y x' y' --- ) : QCPLOT 3 PICK XOFS + 3 PICK YOFS + 3 PICK XOFS + 3 PICK YOFS + CHUE ARCSEG 3 PICK NEGATE XOFS + 3 PICK YOFS + 3 PICK NEGATE XOFS + 3 PICK YOFS + CHUE ARCSEG 3 PICK XOFS + 3 PICK NEGATE YOFS + 3 PICK XOFS + 3 PICK NEGATE YOFS + CHUE ARCSEG 3 PICK NEGATE XOFS + 3 PICK NEGATE YOFS + 3 PICK NEGATE XOFS + 3 PICK NEGATE YOFS + CHUE ARCSEG 4DROP ; --> ( arc 08/21/82 ) ( radius degrees --- x y ) : <ARC> ARCXY CMAG 100 */ NEGATE YOFS + SWAP XOFS + SWAP ; ( deg-start deg-end x y r color --- ) : ARC DEPTH 6 < 1 ?ERROR ['] CHUE 2+ ! CADJ ROT ROT ['] YOFS 2+ ! ['] XOFS 2+ ! ROT ROT 2DUP > IF SWAP THEN 1+ SWAP 2 PICK OVER <ARC> ['] YPREV 2+ ! ['] XPREV 2+ ! DO DUP I <ARC> 2DUP XPREV YPREV CHUE ARCSEG ['] YPREV 2+ ! ['] XPREV 2+ ! LOOP DROP ; --> ( ellipse 12/17/83 ) ( x y r e color --- r ) : (ELLIPSE) DEPTH 4 < 1 ?ERROR ['] CHUE 2+ ! CADJ CMAG M* 100 UM/MOD SWAP DROP ['] CMAG 2+ ! ROT ROT ['] YOFS 2+ ! ['] XOFS 2+ ! 0 ['] YPREV 2+ ! DUP ['] XPREV 2+ ! DUP 100 < IF 3 ELSE 2 THEN ['] CINCR 2+ ! ; ( x y r e color --- ) : ELLIPSE (ELLIPSE) 90 CINCR + 0 CINCR + DO DUP I ARCXY CMAG 100 */ NEGATE 2DUP XPREV YPREV QCPLOT ['] YPREV 2+ ! ['] XPREV 2+ ! CINCR +LOOP DROP ; --> ( circle 12/17/83 ) DECIMAL ( x y r color --- ) : CIRCLE 100 SWAP ELLIPSE ; --> ( cube 05/05/82 ) ( A cube is defined by the usual coordinates for a box and ) ( the xd,yd which gives the displayed depth of the sides. ) ( For the routine to work properly, the corners of the box ) ( must be defined in clockwise order around the edge, where) ( x1,y1 is the upper left corner of the box; ) ( x2,y2 is upper right corner of box; x3,y3 is lower ) ( right corner of box; x4,y4 is lower left corner of box. ) ( yd < 0 => top view, yd > 0 => bottom view ) ( xd < 0 => left view, xd > 0 => right view ) : XD@ RP@ WSIZE + @ ; : YD@ RP@ WSIZE 2* + @ ; --> ( cube 05/04/82 ) ( x1 y1 x2 y2 x3 y3 x4 y4 xd yd color --- ) : CUBE DEPTH 11 < 1 ?ERROR ['] CHUE 2+ ! >R >R 8DUP CHUE RECTANGLE YD@ 0< IF 7 PICK 7 PICK 7 PICK 7 PICK ELSE 3 PICK 3 PICK 3 PICK 3 PICK THEN 4DUP 2SWAP 3 ROLL XD@ + 3 ROLL YD@ + 3 ROLL XD@ + 3 ROLL YD@ + CHUE RECTANGLE XD@ 0< IF 2DUP 09 PICK 09 PICK ELSE 5 PICK 5 PICK 5 PICK 5 PICK THEN 4DUP 2SWAP 3 ROLL XD@ + 3 ROLL YD@ + 3 ROLL XD@ + 3 ROLL YD@ + CHUE RECTANGLE R> R> 2DROP 2DROP 2DROP 2DROP 2DROP ; ;S ( light pen support 07/10/82 ) HEX : @lightpen 0 0 0 0400 video-io ; : ?lightpen @lightpen 100 AND 100 = ; ( --- f f=0 light pen not down/triggered, =1 triggered) : ?LIGHTPEN ?lightpen >R 2DROP DROP R> ; ( --- x y leave graphics address ) ( range of x,y depends on current mode ) : @GRAPHXY BEGIN ?lightpen 0= WHILE 2DROP DROP REPEAT ROT DROP SWAP 0 100 UM/MOD SWAP DROP ; ( --- x y leave cursor address ) : @CURSORXY BEGIN ?lightpen 0= WHILE 2DROP DROP REPEAT DROP DROP DUP 0FF AND SWAP 0 100 UM/MOD SWAP DROP ; DECIMAL ;S ( window support Ray Duncan 07/12/82 ) HEX ( create wpb compilation: xul yul xlr ylr --- ) ( execution: --- wpb-addr ) : WINDOW CREATE 100 * + , 100 * + , 700 , DOES> ; ( fetch parameters for VIDEO-IO call: wpb --- dx cx bx ) : WPAR@ DUP @ SWAP WSIZE + DUP @ SWAP WSIZE + @ ; ( change initializing attribute: attrib wpb --- ) : W-ATTRIB SWAP 100 * SWAP WSIZE 2* + ! ; ( execute window function: dx cx bx ax --- ) : W-EXEC video-io 4DROP ; --> ( window support, continued 07/12/82 ) ( initialize window: wpb --- ) : W-CLEAR WPAR@ 0600 W-EXEC ; ( scroll window up: wpb --- ) : W-UP WPAR@ 0601 W-EXEC ; ( scroll window down: wpb --- ) : W-DOWN WPAR@ 0701 W-EXEC ; ( cursor addressing within window: x y wpb --- ) : W-GOTOXY WSIZE + @ DUP 0FF AND SWAP 100 / D+ GOTOXY ; --> ( window support, continued 07/12/82 ) ( move cursor to window home position: wpb --- ) : W-HOME WSIZE + @ DUP 0FF AND SWAP 100 / GOTOXY ; ( move cursor to window lower left corner: wpb --- ) : W-LLC DUP WSIZE + @ 0FF AND SWAP @ 100 / GOTOXY ; --> ( window support, continued 07/12/82 ) ( draw border around window: wpb --- ) : W-BORDER DUP >R WSIZE + @ DUP 0FF AND SWAP 0 100 UM/MOD SWAP DROP R> @ DUP 0FF AND SWAP 0 100 UM/MOD SWAP DROP ( top ) 1 PICK 1+ 4 PICK DO I 3 PICK 1- GOTOXY C4 EMIT LOOP ( bottom) 1 PICK 1+ 4 PICK DO I 1 PICK 1+ GOTOXY C4 EMIT LOOP ( right ) DUP 1+ 3 PICK DO 1 PICK 1+ I GOTOXY B3 EMIT LOOP ( left ) DUP 1+ 3 PICK DO 3 PICK 1- I GOTOXY B3 EMIT LOOP ( ur ) 1 PICK 1+ 3 PICK 1- GOTOXY 0BF EMIT ( ll ) 3 PICK 1- 1 PICK 1+ GOTOXY 0C0 EMIT ( lr ) 1+ SWAP 1+ SWAP GOTOXY 0D9 EMIT ( ul ) 1- SWAP 1- SWAP GOTOXY DA EMIT ; DECIMAL ;S ( turtle graphics for IBM Ray Duncan 12/07/83 ) VOCABULARY TURTLE IMMEDIATE TURTLE DEFINITIONS DECIMAL VARIABLE turtleX ( Turtle current X coordinate ) VARIABLE turtleY ( Turtle current Y coordinate ) VARIABLE turtleD ( Turtle's direction, degrees ) VARIABLE turtleP ( Turtle's pen, 0=pen up, <>0=pen down) VARIABLE turtleC ( Turtle's color ) 1 turtleP ! ( default turn on pen ) 1 turtleC ! ( default turn on color ) --> ( turtle graphics for IBM RGD 12/07/83 ) ( math redefinitions without flooring for turtle graphics ) : tM/MOD ?DUP IF 2DUP XOR >R >R DABS R@ ABS UM/MOD SWAP R> 0< IF NEGATE THEN SWAP R> 0< IF NEGATE THEN THEN ; : t/MOD >R S>D R> tM/MOD ; : t/ t/MOD SWAP DROP ; : tMOD OVER 0< IF SWAP ABS SWAP t/MOD DROP NEGATE ELSE t/MOD DROP THEN ; : t*/MOD >R M* R> tM/MOD ; : t*/ >R M* R> tM/MOD SWAP DROP ; : moveTurtle ( units --- x' y' ) DUP turtleD @ COS 10000 t*/ turtleX @ + SWAP turtleD @ SIN 10000 t*/ ?MODE 6 < IF 92 ELSE 48 THEN 100 t*/ turtleY @ + ; --> ( turtle graphics for IBM RGD 12/07/83 ) : FORWARD ( units --- ) moveTurtle turtleP @ IF 2DUP turtleX @ turtleY @ turtleC @ line THEN turtleY ! turtleX ! ; : BACKWARD ( units --- ) NEGATE FORWARD ; : RIGHT ( degrees --- ) turtleD @ + 360 tMOD turtleD ! ; : LEFT ( degrees --- ) NEGATE RIGHT ; : CENTER ( put turtle in center of screen ) ?MODE 6 = IF 320 ELSE 160 THEN turtleX ! 100 turtleY ! 0 turtleD ! ; --> ( turtle graphics for IBM RGD 12/07/83 ) ( put turtle in upper left corner ) : HOME 0 turtleX ! 0 turtleY ! 0 turtleD ! ; ( return current direction in degrees ) : ?DIRECTION turtleD @ ; ( set direction in degrees ) : DIRECTION turtleD ! ; ( set current location of turtle ) : SETXY turtleY ! turtleX ! ; ( lift pen --- ie turtle movements do not leave a trail ) : PENUP 0 turtleP ! ; --> ( turtle graphics for IBM RGD 12/07/83 ) ( lower pen --- movements by turtle leave a trail ) : PENDOWN 1 turtleP ! ; ( set color of pen ) : COLOR turtleC ! ; ( return true flag if turtle has gone outside bounds ) : ?QUIT turtleX @ DUP ?MODE 6 = IF 639 ELSE 319 THEN > SWAP 0< OR turtleY @ DUP 199 > SWAP 0< OR OR ; : SQUARE ( size --- ) DUP FORWARD 90 RIGHT DUP FORWARD 90 RIGHT DUP FORWARD 90 RIGHT FORWARD 90 RIGHT ; FORTH DEFINITIONS ( Keypad Mouse Rick Wilton 08/20/82 ) ( The keypad mouse allows the convenient entry of points ) ( in high or medium resolution graphics mode. When MOUSE ) ( is called, it puts a dot in the middle of the screen and ) ( waits for keypad commands. The arrow keys can be used ) ( to move the dot in increments of one, shift/arrow will ) ( jump the dot 10 positions. To select a point push ENTER, ) ( the point will be marked with an X. You can select as ) ( many points as you wish. To leave the MOUSE, push ESC. ) ( When MOUSE returns control to its caller, the coordinates ) ( of selected points are on the stack as 2 word X,Y pairs. ) ( Use DEPTH/2 to determine the number of pairs on the stack. ) --> ( Keypad Mouse, cont 08/20/82 ) : INC-XY ( x y dx dy -- x y ) 3 PICK 3 PICK 0 !dot ROT + 0 MAX 199 MIN >R + 0 MAX ?MODE 6 < IF 319 ELSE 639 THEN MIN R> 2DUP 1 !dot 2DUP 0 0 GOTOXY SWAP 3 .R 4 .R ; : SAVE-XY ( x y -- ) OVER 1+ OVER 1+ 1 !dot OVER 1- OVER 1- 1 !dot OVER 1+ OVER 1- 1 !dot OVER 1- OVER 1+ 1 !dot OVER 2+ OVER 2+ 1 !dot OVER 2- OVER 2- 1 !dot OVER 2+ OVER 2- 1 !dot OVER 2- OVER 2+ 1 !dot 7 EMIT ; --> ( Keypad Mouse, cont 08/20/82 ) : PARSE-PENMOVE ( x y n -- x y ) CASE 72 OF 0 -1 INC-XY ENDOF 56 OF 0 -10 INC-XY ENDOF 77 OF 1 0 INC-XY ENDOF 54 OF 10 0 INC-XY ENDOF 80 OF 0 1 INC-XY ENDOF 50 OF 0 10 INC-XY ENDOF 75 OF -1 0 INC-XY ENDOF 52 OF -10 0 INC-XY ENDOF 13 OF 2DUP SAVE-XY ENDOF ENDCASE ; : AWAIT-PENMOVE ( -- ) BEGIN BEGIN ?TERMINAL UNTIL KEY ?DUP IF ELSE KEY THEN DUP 27 = IF 2DROP DROP EXIT THEN PARSE-PENMOVE AGAIN ; --> ( Keypad Mouse, cont 08/20/82 ) : MOUSE ( --- x,y-pairs ) CLEARSCREEN ?MODE 6 < IF 160 ELSE 319 THEN 99 0 0 INC-XY AWAIT-PENMOVE ; ;S ( Microsoft Mouse 16 Bit version Ray Duncan 12/08/83 ) FORTH DEFINITIONS HEX ( M4 M3 M2 M1 --- M4 M3 M2 M1 ) ( dx cx bx ax --- dx cx bx ax ) CODE mouse-io AX POP BX POP CX POP DX POP SI PUSH BP PUSH 33 INT BP POP SI POP DX PUSH CX PUSH BX PUSH AX PUSH NEXT, END-CODE --> ( Microsoft Mouse interface 12/08/83 ) DECIMAL ( --- flag : -1 installed, 0 not installed ) : MOUSE-RESET 0 0 0 0 mouse-io >R 3DROP R> ; ( --- ) : SHOW-CURSOR 0 0 0 1 mouse-io 4DROP ; ( --- ) : HIDE-CURSOR 0 0 0 2 mouse-io 4DROP ; ( --- x y ) : @POSITION 0 0 0 3 mouse-io 2DROP SWAP ; --> ( Microsoft Mouse interface 12/08/83 ) DECIMAL ( --- n : bits 0 and 1 represent left and right buttons ) : @BUTTONS 0 0 0 3 mouse-io DROP >R 2DROP R> ; ( x y --- ) : !POSITION SWAP 0 4 mouse-io 4DROP ; ( button --- x y press_count button_status ) ( button=0 left,=1 right) : @PRESSES 0 0 ROT 5 mouse-io 3 ROLL 3 ROLL SWAP 3 ROLL 3 ROLL ; --> ( Microsoft Mouse interface 12/08/83 ) DECIMAL ( button --- x y release_count button_status ) ( button=0 left,=1 right) : @RELEASES 0 0 ROT 6 mouse-io 3 ROLL 3 ROLL SWAP 3 ROLL 3 ROLL ; ( min max --- ) : HORIZ-LIMITS SWAP 0 7 mouse-io 4DROP ; ( min max --- ) : VERT-LIMITS SWAP 0 8 mouse-io 4DROP ; --> ( Microsoft Mouse interface 12/08/83 ) DECIMAL ( pointer x y --- ) : SET-GCUR SWAP 9 mouse-io 4DROP ; ( hardware: scan_line_start scan_line_stop cursor_select --- ) ( software: screen_mask cursor_mask cursor_select --- ) : SET-TCUR ROT ROT SWAP ROT 10 mouse-io 4DROP ; ( --- x_count y_count ) : @COUNTERS 0 0 0 11 mouse-io 2DROP SWAP ; --> ( Microsoft Mouse interface 12/08/83 ) DECIMAL ( address mask --- ) : SET-SUBR 0 12 mouse-io 4DROP ; ( --- ) : ENABLE-PEN 0 0 0 13 mouse-io 4DROP ; ( --- ) : DISABLE-PEN 0 0 0 14 mouse-io 4DROP ; ( horizontal_ratio vertical_ratio --- ) : SET-MICKEY SWAP 0 15 mouse-io 4DROP ; ;S ( Optical mouse 16 Bit version RJW 01/29/83 ) ;S This routine monitors and demonstrates the MSC M-1 Optical Mouse, sold by Mouse Systems Corp., 2336H Walsh Ave., Santa Clara, CA 95051. The software assumes that the Mouse is on the first serial port --- COM0. There are 2 code defs -- one call to the ROM BIOS to initialize the first comm port, and one code def which reads data directly from the port (no handshaking). To run the demo, enter: 83 LOAD DEMO Pressing the left button causes the mouse to leave a trail. Pressing all 3 at once ends the demo. ( Optical mouse 16 Bit version 12/07/83 ) HEX CODE INT14 ( AX DX -- AX ) ( see Tech Ref p. A-20 ) DX POP AX POP 14 INT AX PUSH NEXT, END-CODE : INIT-MOUSE ( -- AX ) ( set commo port 0 to 1200 baud .. ) 083 0 INT14 ; ( .. no parity, 1 stopbit, 8-bit data ) DECIMAL --> ( Optical mouse 16 Bit version 01/29/83 ) FORTH DEFINITIONS HEX CODE @MOUSE ( -- dX dY dX dY LMR ) CX, # 3 MOV ( # bits for shift ) 1$: DX, # 3FD MOV AL, DX IN ( read RS-232 LSR port ) AL, # 01 AND ( wait for Data Ready ) 1$ JZ DX, # 3F8 MOV AL, DX IN ( read RS-232 data port ) AH, AL MOV ( copy to hi-order byte ) AX, CL SHR ( put flag in AH, LMR in AL ) AH, # 10 CMP ( 1st byte of data packet? ) 1$ JNE ( try again if not ) BL, AL MOV ( save LMR for later ) --> ( Optical mouse 16 bit version 12/07/83 ) CX, # 4 MOV ( count for loop ) 2$: DX, # 3FD MOV AL, DX IN ( read RS-232 LSR port ) AL, # 01 AND ( wait for Data Ready ) 2$ JZ DX, # 3F8 MOV AL, DX IN ( read RS-232 data port ) CBW ( sign extend ) AX PUSH ( push onto stack ) 2$ LOOP BH, BH XOR ( zero hi-order byte ) CL, # 5 MOV ( set # bits to shift ) BL, CL SHR ( shift LMR flags to right ) BX PUSH ( push the result ) NEXT, END-CODE ( c'est tout ) DECIMAL ( Lo Res 16 bit version 12/27/82 ) FORTH DEFINITIONS HEX ( initialize video controller chip ) : TR 3D4 PC! 3D5 PC! ; : CRT_LRC_INIT 9 3D8 PC! 07F 4 TR 64 6 TR 70 7 TR 1 9 TR ; ( initialize video memory map for low res graphics ) : CLEAR_BUFF 4000 0 DO 0DE B800 I !L 2 +LOOP ; ( set operating mode for low resolution color graphics ) : LRCG 2 MODE CRT_LRC_INIT CLEAR_BUFF ; --> ( Lo Res 16 Bit version 01/12/84 ) ( plot point in low res graphics: x y color --- ) : !DOT ROT DUP 1 AND IF ROT 0A0 * + B800 SWAP 2DUP C@L 0F0 AND >R ROT R> OR ROT ROT C!L ELSE 1 OR SWAP 10 * SWAP ROT 0A0 * + B800 SWAP 2DUP C@L 0F AND >R ROT R> OR ROT ROT C!L THEN ; DECIMAL ( Lo Res 16 Bit version 12/07/83 ) FORTH DEFINITIONS HEX ( initialize video controller chip ) : TR 3D4 PC! 3D5 PC! ; : CRT_LRC_INIT 9 3D8 PC! 07F 4 TR 64 6 TR 70 7 TR 1 9 TR ; ( initialize video memory map for low res graphics ) CODE CLEAR_BUFF CX, # B800 MOV DX, ES MOV ES, CX MOV DI, # 0 MOV CX, # 4000 MOV AX, # DE MOV REP WORD STOS ES, DX MOV NEXT, END-CODE ( set operating mode for low resolution color graphics ) : LRCG 2 MODE CRT_LRC_INIT CLEAR_BUFF ; --> ( Lo Res 16 Bit version 12/07/83 ) HEX ( plot point in low res graphics: x y color --- ) CODE !DOT CX, # B800 MOV DX, DS MOV DS, CX MOV BX POP AX POP CL, # 0A0 MOV CL MUL CX POP AX, BX XCHG BX, CX ADD BX, # 1 OR AH, [BX] MOV CX, # 1 AND 1$ JNZ AH, # 0F AND AL, 1 SHL AL, 1 SHL AL, 1 SHL AL, 1 SHL 2$ JMP 1$: AH, # 0F0 AND 2$: AL, AH OR [BX], AL MOV DS, DX MOV NEXT, END-CODE DECIMAL --> ( Lo Res 16 Bit version 12/07/83 ) VARIABLE INCR 2 ALLOT VARIABLE COLOR : 4DUP 3 PICK 3 PICK 3 PICK 3 PICK ; : LINE ( x1 y1 x2 y2 color --- ) COLOR ! 4DUP ROT - ABS ROT ROT SWAP - ABS < IF 3 PICK 2 PICK > IF 2SWAP THEN 4DUP ROT - ROT ROT SWAP - SWAP 1000 M* ROT M/MOD S>D INCR 2! DROP DROP SWAP 1000 M* 3 ROLL 3 ROLL SWAP DO 2DUP 1000 M/MOD SWAP DROP I SWAP COLOR @ !DOT INCR 2@ D+ LOOP --> ( Lo Res 16 Bit version 12/07/83 ) ELSE 2 PICK 1 PICK > IF 2SWAP THEN 4DUP ROT - ROT ROT SWAP - 1000 M* ROT M/MOD S>D INCR 2! DROP SWAP DROP ROT 1000 M* 3 ROLL 3 ROLL SWAP DO 2DUP 1000 M/MOD SWAP DROP I COLOR @ !DOT INCR 2@ D+ LOOP THEN 2DROP ; ( Joystick 16 Bit J. Marxer 4/01/83 ) HEX CODE STICK ( bit number 0-3 --- reading ) ( reading of 12CH = 300 decimal means stick not connected ) CX POP ( bit number from stack ) CX, # 3 CMP ( bits 0-3 allowed here ) 1$ JLE ( too large ? ) CX, CX XOR ( yes set to zero ) 1$: BX, # 1 MOV ( BX will be bit mask ) BL, CL ROL DX, # 201 MOV ( port address to DX ) CX, CX XOR ( zero counter ) DX, AL OUT ( fire the one-shot) 2$: CX INC ( increment counter ) CX, # 12B CMP ( count = 300 decimal?) --> ( Joystick 16 Bit 12/07/83 ) 4$ JG ( yes, stick not connected) AL, DX IN ( read game adapter port ) AL, BL AND ( isolate bit ) 2$ JNZ ( if zero, finished ) CX, CX XOR ( zero counter again ) DX, AL OUT ( fire the one-shot ) 3$: CX INC ( increment counter ) AL, DX IN ( read game adapter port) AL, BL AND ( isolate bit ) 3$ JNZ ( if zero, finished ) 4$: CX PUSH ( put counter on stack ) NEXT, END-CODE DECIMAL ;S ( Version dependent parameters for 16 Bit Forth 01/12/84 ) FORTH DEFINITIONS HEX B800 CONSTANT C/G-MAP : SET-DTA C/G-MAP 0 set-dta ; : W! ! ; ( aliases ) : W@ @ ; : ADDR>FDOS FDOS ; : W, , ; DECIMAL ( Version dependent parameters for 32 Bit Forth 01/12/84 ) FORTH DEFINITIONS HEX HEX B8000000 CONSTANT C/G-MAP : SET-DTA C/G-MAP S&O>ADDR set-dta ; DECIMAL ( MS Mouse 32 Bit Ray Duncan 01/12/84 ) FORTH DEFINITIONS HEX ( M4 M3 M2 M1 --- M4 M3 M2 M1 ) ( dx cx bx ax --- dx cx bx ax ) CODE mouse-io SP, # 2 ADD AX POP SP, # 2 ADD BX POP SP, # 2 ADD CX POP SP, # 2 ADD DX POP DS PUSH SI PUSH BP PUSH 33 INT BP POP SI POP DS PUSH DI, AX MOV AX, DX MOV CWD AX PUSH DX PUSH AX, CX MOV CWD AX PUSH DX PUSH AX, BX MOV CWD AX PUSH DX PUSH AX, DI MOV CWD AX PUSH DX PUSH NEXT, END-CODE DECIMAL 42 LOAD ( load remainder of words ) ( Optical Mouse 32 bit 01/12/84 ) HEX CODE INT14 ( AX DX -- AX ) ( see Tech Ref p. A-20 ) SP, # 2 ADD DX POP SP, # 2 ADD AX POP 14 INT CWD AX PUSH DX PUSH NEXT, END-CODE : INIT-MOUSE ( -- AX ) ( set commo port 0 to 1200 baud .. ) 083 0 INT14 ; ( .. no parity, 1 stopbit, 8-bit data ) DECIMAL --> ( Optical Mouse 32 bit 01/29/83 ) FORTH DEFINITIONS HEX CODE @MOUSE ( -- dX dY dX dY LMR ) CX, # 3 MOV ( # bits for shift ) 1$: DX, # 3FD MOV AL, DX IN ( read RS-232 LSR port ) AL, # 01 AND ( wait for Data Ready ) 1$ JZ DX, # 3F8 MOV AL, DX IN ( read RS-232 data port ) AH, AL MOV ( copy to hi-order byte ) AX, CL SHR ( put flag in AH, LMR in AL ) AH, # 10 CMP ( 1st byte of data packet? ) 1$ JNE ( try again if not ) BL, AL MOV ( save LMR for later ) --> ( Optical Mouse 32 Bit 12/07/83 ) CX, # 4 MOV ( count for loop ) 2$: DX, # 3FD MOV AL, DX IN ( read RS-232 LSR port ) AL, # 01 AND ( wait for Data Ready ) 2$ JZ DX, # 3F8 MOV AL, DX IN ( read RS-232 data port ) CBW CWD ( sign extend ) AX PUSH DX PUSH ( push onto stack ) 2$ LOOP BH, BH XOR ( zero hi-order byte ) CL, # 5 MOV ( set # bits to shift ) BL, CL SHR ( shift LMR flags to right ) BX PUSH BX, BX SUB BX PUSH ( push the result ) NEXT, END-CODE ( c'est tout ) DECIMAL ( Lo Res Graphics 32 bit 12/07/83 ) FORTH DEFINITIONS HEX ( initialize video controller chip ) : TR 3D4 PC! 3D5 PC! ; : CRT_LRC_INIT 9 3D8 PC! 07F 4 TR 64 6 TR 70 7 TR 1 9 TR ; ( initialize video memory map for low res graphics ) CODE CLEAR_BUFF CX, # B800 MOV DX, ES MOV ES, CX MOV DI, # 0 MOV CX, # 4000 MOV AX, # 0DE MOV REP WORD STOS ES, DX MOV NEXT, END-CODE ( set operating mode for low resolution color graphics ) : LRCG 2 MODE CRT_LRC_INIT CLEAR_BUFF ; --> ( Lo Res Graphics 32 bit 12/07/83 ) HEX ( plot point in low res graphics: x y color --- ) CODE !DOT CX, # B800 MOV DX, DS MOV DS, CX MOV SP, # 2 ADD BX POP SP, # 2 ADD AX POP CL, # 0A0 MOV CL MUL SP, # 2 ADD CX POP AX, BX XCHG BX, CX ADD BX, # 1 OR AH, [BX] MOV CX, # 1 AND 1$ JNZ AH, # 0F AND AL, 1 SHL AL, 1 SHL AL, 1 SHL AL, 1 SHL 2$ JMP 1$: AH, # 0F0 AND 2$: AL, AH OR [BX], AL MOV DS, DX MOV NEXT, END-CODE DECIMAL 55 LOAD ( get implementation independent words ) ( Joystick 32 Bit J. Marxer 4/01/83 ) HEX CODE STICK ( bit number 0-3 --- reading ) ( reading of 12CH = 300 decimal means stick not connected ) SP, # 2 ADD ( drop upper 16 bits) CX POP ( bit number from stack ) CX, # 3 CMP ( bits 0-3 allowed here ) 1$ JLE ( too large ? ) CX, CX XOR ( yes set to zero ) 1$: BX, # 1 MOV ( BX will be bit mask ) BL, CL ROL DX, # 201 MOV ( port address to DX ) CX, CX XOR ( zero counter ) DX, AL OUT ( fire the one-shot) 2$: CX INC ( increment counter ) CX, # 12B CMP ( count = 300 decimal?) --> ( Joystick 32 Bit 12/07/83 ) 4$ JG ( yes, stick not connected) AL, DX IN ( read game adapter port ) AL, BL AND ( isolate bit ) 2$ JNZ ( if zero, finished ) CX, CX XOR ( zero counter again ) DX, AL OUT ( fire the one-shot ) 3$: CX INC ( increment counter ) AL, DX IN ( read game adapter port) AL, BL AND ( isolate bit ) 3$ JNZ ( if zero, finished ) 4$: CX PUSH ( put counter on stack ) CX, CX SUB CX PUSH NEXT, END-CODE DECIMAL ;S ( Color PC drawing demo 05/15/82 ) VARIABLE DCOUNT : DEMO 4 MODE 0 PALETTE 2 FOREGROUND 1 BACKGROUND 5 1 GOTOXY ." Laboratory Microsystems PC/FORTH" 105 40 205 40 205 120 105 120 10 -10 3 CUBE ( monitor) 110 45 185 45 185 115 110 115 3 RECTANGLE ( screen) 147 80 3 2 FLOOD 147 80 9 1 CIRCLE 147 80 1 1 FLOOD 147 80 20 20 1 ELLIPSE 147 80 20 15 1 ELLIPSE 195 100 3 3 CIRCLE 195 90 3 3 CIRCLE ( knobs ) 195 100 3 3 FLOOD 195 90 3 3 FLOOD --> ( Color PC drawing demo 05/15/82 ) 80 125 230 125 230 160 80 160 3 RECTANGLE 80 125 95 110 3 LINE 230 125 245 110 3 LINE 230 160 245 145 3 LINE 245 145 245 110 3 LINE 95 110 103 110 3 LINE 216 110 245 110 3 LINE 120 90 DO I 145 I 2 + 145 ( vent slots) I 2 + 155 I 155 3 RECTANGLE 5 +LOOP 130 130 225 130 225 155 130 155 3 RECTANGLE 176 130 176 155 3 LINE ( divider ) 178 130 178 155 3 LINE ( divider ) 131 142 175 142 175 145 131 145 3 RECTANGLE 151 133 156 133 156 150 151 150 3 RECTANGLE --> ( Color PC drawing demo 05/15/82 ) 180 142 223 142 223 145 180 145 3 RECTANGLE 199 133 204 133 204 150 199 150 3 RECTANGLE 80 165 230 165 215 185 65 185 3 RECTANGLE 81 170 221 170 212 182 72 182 3 RECTANGLE 83 174 208 174 3 LINE 79 178 205 178 3 LINE 215 85 DO I 172 I 6 - 180 3 LINE 5 +LOOP 0 0 GOTOXY ; ( window examples 07/12/82 ) 5 5 30 10 WINDOW W1 40 7 70 15 WINDOW W2 10 21 70 23 WINDOW W3 : DEMO CLEARSCREEN W1 W-BORDER W2 W-BORDER W3 W-BORDER W1 W-CLEAR W2 W-CLEAR W3 W-CLEAR W3 W-HOME ." We will scroll the left window up" 0 1 W3 W-GOTOXY ." and the right window down" 100 0 DO W1 W-UP W1 W-LLC ." Line # " I . W2 W-DOWN W2 W-HOME ." Line # " I . LOOP W3 W-CLEAR W3 W-HOME ." Demonstration is finished." 0 0 GOTOXY ; ( Color trig demo for integer trig functions 08/01/82 ) DECIMAL -50 CONSTANT SCALING : AXES 20 20 20 180 3 line 20 180 300 180 3 line 300 20 DO I 180 I 175 3 line 45 +LOOP 600 0 DO I 16 / 2 + 24 GOTOXY I . 90 +LOOP ; --> ( Color trig demo for integer trig functions 08/01/82 ) : DEMO 4 MODE AXES 560 0 DO I SIN SCALING 10000 */ 100 + I 2/ 20 + SWAP 1 !dot LOOP 560 0 DO I COS SCALING 10000 */ 100 + I 2/ 20 + SWAP 2 !dot LOOP 1 FOREGROUND 8 20 GOTOXY ." Sine" 2 FOREGROUND 4 12 GOTOXY ." Cosine" 0 0 GOTOXY ; ( POLYSPI demo for Turtle Graphics 08/07/82 ) FORTH DEFINITIONS DECIMAL : POLYSPI ( distance angle change --- ) TURTLE ?QUIT IF EXIT THEN 2 PICK FORWARD 1 PICK RIGHT ROT OVER + ROT ROT MYSELF FORTH ; : DEMOX TURTLE 6 MODE CENTER FORTH ; : DEMO1 DEMOX 10 60 3 POLYSPI ; : DEMO2 DEMOX 10 61 3 POLYSPI ; : DEMO3 DEMOX 10 62 3 POLYSPI ; : DEMO4 DEMOX 10 91 3 POLYSPI ; : DEMO5 DEMOX 10 121 3 POLYSPI ; : DEMO9 TURTLE 135 10 DO CLEARSCREEN ." Angle = " I . 0 DIRECTION CENTER 10 I 3 POLYSPI LOOP FORTH ; ( STAR demo for Turtle Graphics 08/07/82 ) FORTH DEFINITIONS DECIMAL : STAR ( distance angle change --- ) TURTLE ?QUIT IF EXIT THEN 320 turtleX ! 99 turtleY ! 2 PICK FORWARD 1 PICK RIGHT ROT OVER + ROT ROT MYSELF FORTH ; : DEMOX TURTLE 0 turtleX ! 0 turtleY ! 6 MODE FORTH ; : DEMO1 DEMOX 10 59 1 STAR ; : DEMO2 DEMOX 10 61 1 STAR ; : DEMO3 DEMOX 10 65 1 STAR ; ( Bi-Tree Demo for Turtle Graphics 08/07/82 ) FORTH DEFINITIONS DECIMAL : DRAW-TREE ( size --- ) TURTLE DUP 5 < IF DROP EXIT THEN DUP FORWARD 45 RIGHT DUP 5 - FORWARD DUP 5 - MYSELF DUP 5 - BACKWARD 90 LEFT DUP 5 - FORWARD DUP 5 - MYSELF DUP 5 - BACKWARD 45 RIGHT BACKWARD FORTH ; : DEMO TURTLE 6 MODE 320 199 SETXY -90 DIRECTION 50 FORWARD 40 DRAW-TREE FORTH ; ( SPINSQUARE demo for turtle graphics 08/07/82 ) FORTH DEFINITIONS DECIMAL : SPINSQUARE ( size angle difference --- ) TURTLE 2 PICK 150 > IF EXIT THEN 2 PICK SQUARE 1 PICK RIGHT ROT OVER + ROT ROT MYSELF FORTH ; : DEMOX TURTLE 6 MODE CENTER FORTH ; : DEMO1 DEMOX 10 5 3 SPINSQUARE ; : DEMO2 DEMOX 10 10 3 SPINSQUARE ; : DEMO3 DEMOX 10 45 3 SPINSQUARE ; : DEMO4 DEMOX 10 60 3 SPINSQUARE ; ( Lo Res Color Graphics demonstration 12/07/83 ) VARIABLE COLOR 3 COLOR ! VARIABLE CSEQ 2 , 4 , 6 , 8 , 10 , 12 , 14 , 1 , 3 , 5 , 7 , 9 , 11 , 13 , 15 , : SQUARE DUP 0= IF DROP EXIT THEN DUP 80 + OVER 80 SWAP - 2 PICK DUP 50 + 50 ROT - SWAP 1+ SWAP DO DUP I COLOR @ !DOT OVER I COLOR @ !DOT LOOP 2DROP DUP 50 + OVER 50 SWAP - 2 PICK DUP 80 + 80 ROT - SWAP 1+ SWAP DO DUP I SWAP COLOR @ !DOT OVER I SWAP COLOR @ !DOT LOOP 2DROP DROP ; : DEMO1 LRCG 50 0 DO I 15 AND 2* CSEQ + @ COLOR ! I SQUARE LOOP KEY DROP 3 MODE ; --> ( Lo Res Color Graphics demonstration 12/07/83 ) : DEMO2 LRCG 100 0 DO 0 0 160 I I 2/ 16 MOD LINE 2 +LOOP 0 160 DO 0 0 I 99 I 2/ 16 MOD LINE -2 +LOOP KEY DROP 2 MODE ; : DEMO3 LRCG 100 0 DO 0 I 159 I I 2 / 16 MOD LINE LOOP KEY DROP 2 MODE ; ( demo for optical mouse 01/29/83 ) VARIABLE LEFT ( button status flag ) : DEMO ( -- ) INIT-MOUSE DROP ( set comm port, ignore status ) 6 MODE 320 100 2DUP 1 !dot ( start at center of screen ) BEGIN @MOUSE ?DUP WHILE 4 AND 4 = LEFT ! ( update button ) LEFT @ IF 5 PICK 5 PICK 0 !dot THEN ( erase old x,y ) >R >R NEGATE ROT + >R + R> ( 1st x,y ) LEFT @ 0= IF 2DUP 1 !dot THEN ( mark 1st x,y ) R> R> NEGATE ROT + >R + R> 2DUP 1 !dot ( 2nd x,y ) REPEAT ( until all 3 buttons are down ) 2 MODE 2DROP 2DROP 2DROP ; ( Demo for fast FLOOD routine 05/28/83 ) FORTH DEFINITIONS DECIMAL : (DEMO) TURTLE DUP 5 < IF 150 100 1 2 FLOOD 0 0 1 3 FLOOD 0 PALETTE 0 199 1 2 FLOOD QUIT THEN DUP FORWARD 45 RIGHT 1 - MYSELF MYSELF FORTH ; : DEMO TURTLE 4 MODE 120 15 SETXY 0 DIRECTION 80 (DEMO) FORTH ; ( joystick test routine 05/28/83 ) : TEST CLEARSCREEN ." push any key to terminate test" 0 12 GOTOXY ." Game adapter port bit 0 --" 0 14 GOTOXY ." bit 1 --" 0 16 GOTOXY ." bit 2 --" 0 18 GOTOXY ." bit 3 --" BEGIN 0 STICK 27 12 GOTOXY . 1 STICK 27 14 GOTOXY . 2 STICK 27 16 GOTOXY . 3 STICK 27 18 GOTOXY . ?TERMINAL IF KEY DROP CLEARSCREEN QUIT THEN AGAIN ; ;S ( COLORS for mode 4 FLOOD 05/28/83 ) : COLORS ( [ HEX ] B800 GBUFSEG ! ( used if ghost buffer available) [ DECIMAL ] 4 MODE 0 BACKGROUND 6 1 DO 200 I 6 */ >R 0 R@ 319 R> 3 LINE LOOP 100 20 3 1 FLOOD 14 2 GOTOXY ." color = 1 " 100 50 3 2 FLOOD 14 6 GOTOXY ." color = 2 " 100 80 3 3 FLOOD 14 10 GOTOXY ." color = 3 " 100 110 3 102 FLOOD 14 14 GOTOXY ." color = 66h " 100 140 3 119 FLOOD 14 18 GOTOXY ." color = 77h " 100 170 3 187 FLOOD 14 22 GOTOXY ." color = BBh " 5 1 DO I 1 AND PALETTE 32000 0 DO LOOP LOOP ; ( Demo for FLOOD routine 05/28/83 ) VARIABLE SEED 1 SEED ! : (RAND) SEED @ 259 * 3 + 32767 AND DUP SEED ! ; : RANDOM ( n1 -- n2 ) (RAND) 32767 */ ; : XMAX ?MODE 4 = IF 320 ELSE 640 THEN ; : RX XMAX RANDOM ; : RY 200 RANDOM ; : DEMO 4 MODE BEGIN CLEARSCREEN XMAX 2/ 20 - 80 ( 100) 70 RANDOM 20 + 3 CIRCLE RX RY RX RY RX RY 3 TRIANGLE XMAX 2/ 20 + 120 100 RANDOM 30 + 50 RANDOM 50 + 3 ELLIPSE RX RY RX RY RX RY 3 TRIANGLE RX RY 3 2 FLOOD RX RY 3 1 FLOOD RX RY 3 3 FLOOD 32000 0 DO LOOP ?TERMINAL IF KEY DROP QUIT THEN AGAIN ; ( Animation demo RJW 06/13/83 ) FORTH DEFINITIONS DECIMAL VARIABLE AX VARIABLE BX VARIABLE TILE 32 ALLOT VARIABLE GHOST 1000 ALLOT : BULLET ( -- ) 102 100 100 102 2 LINE 103 100 102 102 2 LINE 103 101 101 103 2 LINE 94 100 103 108 TILE @block TILE 94 100 Xblock ; : AIRPLANE ( -- ) 100 103 2 !dot 101 102 101 104 2 LINE 102 102 120 102 1 LINE 102 104 130 104 1 LINE 102 103 120 103 1 LINE 121 103 125 103 2 LINE 102 101 102 98 1 LINE 103 98 106 101 1 LINE 97 98 130 104 GHOST @block GHOST 97 98 Xblock ; --> ( Animation demo, cont. 06/13/83 ) : MOVE-BULLET ( -- ) TILE BX @ 6 + DUP BX ! 192 OVER 2* 3 / - !block ; : MOVE-AIRPLANE ( -- ) GHOST AX @ 2 + DUP AX ! 11 !block ; : GUN ( -- ) 10 189 0 195 3 LINE 0 195 0 199 3 LINE 0 199 5 199 3 LINE 5 199 13 192 3 LINE 13 192 10 189 3 LINE 0 199 2 !dot 1 198 3 3 FLOOD ; --> ( Animation demo, cont. 06/13/83 ) : SPRITE-BANNER ( -- ) 2 FOREGROUND 21 22 GOTOXY ." ANIMATION using" 1 FOREGROUND 17 23 GOTOXY ." Laboratory Microsystems" 3 FOREGROUND 24 24 GOTOXY ." PC/FORTH" ; : RESET-BULLET ( -- ) TILE BX @ 192 OVER 2* 3 / - Xblock 13 BX ! ; : RESET-AIRPLANE ( -- ) GHOST AX @ 11 Xblock 0 AX ! ; --> ( Animation demo, cont. 06/13/83 ) : OUTLINE-BOX ( x y x y -- ) 600 0 DO 3 PICK 3 PICK OVER 3 PICK 1 Xline 3 PICK OVER 3 PICK 3 PICK 1 Xline 2DUP 3 PICK 5 PICK 1 Xline OVER 3 PICK 5 PICK 5 PICK 1 Xline LOOP 2DROP 2DROP ; --> ( Animation demo, cont. 06/13/83 ) : BANG ( -- ) RESET-BULLET RESET-AIRPLANE 2 FOREGROUND 35 1 GOTOXY ." bang!" 275 5 319 18 OUTLINE-BOX ; : DEMO ( -- ) 4 MODE 0 PALETTE BULLET AIRPLANE GUN SPRITE-BANNER 0 AX ! 13 BX ! BEGIN BX @ 280 < IF MOVE-BULLET ELSE RESET-BULLET THEN AX @ 280 < IF MOVE-AIRPLANE ELSE RESET-AIRPLANE THEN AX @ BX @ > AX @ BX @ 30 + < AND BX @ 275 > AND UNTIL BANG ; ( PAC-MAN demo RGD 12/07/83 ) FORTH DEFINITIONS DECIMAL : MAKE-PAC1 4 MODE 150 100 25 3 CIRCLE 160 92 5 3 CIRCLE 150 100 3 1 FLOOD ; : MAKE-PAC2 4 MODE -20 325 150 100 25 3 ARC 150 100 173 106 3 LINE 150 100 171 113 3 LINE 160 92 5 3 CIRCLE 140 100 3 1 FLOOD ; : MAKE-PAC3 4 MODE -18 310 150 100 25 3 ARC 150 100 173 106 3 LINE 150 100 166 117 3 LINE 160 92 5 3 CIRCLE 140 100 3 1 FLOOD ; --> ( PAC-MAN demo 07/06/83 ) VARIABLE PAC1 750 ALLOT VARIABLE PAC2 750 ALLOT VARIABLE PAC3 750 ALLOT : STORE-PAC1 MAKE-PAC1 122 75 175 125 PAC1 @block ; : STORE-PAC2 MAKE-PAC2 122 75 175 125 PAC2 @block ; : STORE-PAC3 MAKE-PAC3 122 75 175 125 PAC3 @block ; --> ( PAC-MAN demo 07/06/83 ) : INIT-PACMAN STORE-PAC1 STORE-PAC2 STORE-PAC3 ; : SHOW-PACMAN ( x y --- ) PAC1 2 PICK 2 PICK !block PAC2 2 PICK 1+ 2 PICK !block PAC3 2 PICK 2+ 2 PICK !block 2DROP ; : DEMO INIT-PACMAN 4 MODE 265 0 DO I 75 SHOW-PACMAN 3 +LOOP 4 MODE 265 0 DO I 75 SHOW-PACMAN 5 +LOOP 4 MODE 160 0 DO 265 0 DO PAC3 I J !block 55 +LOOP 50 +LOOP 160 0 DO 265 0 DO PAC3 I J Xblock 55 +LOOP 50 +LOOP ; ( Binary tree #2 01/17/84 ) TURTLE DEFINITIONS DECIMAL VARIABLE 'LBR VARIABLE 'RBR VARIABLE LEVEL 8 LEVEL ! VARIABLE ANGLE 20 ANGLE ! : LBR 'LBR @ EXECUTE ; : RBR 'RBR @ EXECUTE ; : NODE LEVEL @ 1 < IF EXIT THEN -1 LEVEL +! ANGLE @ LEFT LBR ANGLE @ 2* RIGHT RBR ANGLE @ LEFT 1 LEVEL +! ; --> ( Binary tree #2 01/17/84 ) : (LBR) DUP 2* PENDOWN FORWARD NODE DUP 2* PENUP BACKWARD ; : (RBR) DUP PENDOWN FORWARD NODE DUP PENUP BACKWARD ; ' (LBR) 'LBR ! ' (RBR) 'RBR ! FORTH DEFINITIONS : DEMO TURTLE 4 MODE 1 FOREGROUND 160 199 SETXY -90 DIRECTION 8 LEVEL ! 12 LBR DROP ;
