Category : Forth Source Code
Archive   : FPCHERC.ZIP
Filename : HGFRACT.SEQ

 
Output of file : HGFRACT.SEQ contained in archive : FPCHERC.ZIP
\ Koopman's Fractal Landscape routines, by Mark Smiley 5-22-88

comment:
Based on Phil
Koopman Jr.'s routines for MVP-FORTH
from FORTH Dimensions, Vol. IX, No.1, p. 12-16.

Translated to F83
with menu and screen saving added by:
Mark Smiley
8-14-87

Translated to FF and F88 forths by:
Mark Smiley
5-22-88

F.A.T. Math Dept.
218 Parker Hall
Auburn University
Auburn, AL 36849-3501
(205)-826-7301
--------------------------------------------------------
MODIFIED TO WORK WITH HERCULES GRAPHICS CARD
BY PAUL SNYDER 2-4-90
--------------------------------------------------------
comment;

NEEDS HGTEXT.SEQ

ONLY FORTH ALSO

WARNING OFF
2 CONSTANT #COLORS
: TEXT ( --) te txt ;
: hgcs ( --) hgdark hghome ;
WARNING ON

199 CONSTANT YMAX

: MOVE-CURSOR ( x y -- ) LASTY ! LASTX ! ;
: D#IN ( -- d ) QUERY BL WORD NUMBER ;
: HALT ( -- ) KEY DROP ;
: .HALT ( -- ) cr cr ." Hit any key to continue..." ;


: XD* ( ud1 ud2 -- ud3 )
OVER 4 PICK UM* >R >R
3 ROLL UM* DROP >R
UM* DROP
0 SWAP R> 0 SWAP D+
R> R> D+ ;


POSTFIX

CODE (RANDOMIZE) ( -- d )
0 # AH MOV 26 INT DX PUSH CX PUSH NEXT END-CODE

PREFIX


DECIMAL
2VARIABLE SEED \ 3141592653. SEED 2!

: RNDF1 ( -- n )
SEED 2@ 3141592621. XD* 1. D+
TUCK SEED 2! ;

: RNDF2 ( -- n )
[ SEED 1+ ] LITERAL @ 31417 UM* 1. D+ TUCK
SEED 2! ;

DEFER RNDF ' RNDF1 IS RNDF

: RANDOMIZE (RANDOMIZE) SEED 2! RNDF1 RNDF1 2DROP ;
RANDOMIZE

: WALL ;

: CELL* 2* ;
: CELL+ 2+ ;


5 CONSTANT #LEVELS
65 CONSTANT SIZE \ 2^(#levels+1)+1
SIZE SIZE * CELL* CONSTANT SQ-SIZE

CREATE SQUARE-P1 SQ-SIZE ALLOT
SIZE 1- CELL* SQUARE-P1 + CONSTANT SQUARE-P2
SIZE SIZE * 1- CELL* SQUARE-P1 + CONSTANT SQUARE-P3
SIZE SIZE 1- * CELL* SQUARE-P1 + CONSTANT SQUARE-P4

: SCALE ( n1 -- n2 ) 2* 2* ;
1 SCALE CONSTANT DELTA

: AVE ( u1 u2 -- uave )
0 TUCK D+ D2/ ( 2 UM/MOD NIP ) DROP ;


: Y-CONVERT ( height y1 -- y2 )
+ 2/ NEGATE YMAX + ;

: F-MOVE ( x height y-index -- )
SCALE Y-CONVERT MOVE-CURSOR ;

: F-LINE ( x height y-index -- )
SCALE Y-CONVERT DUP 0<
IF ( Clip line that is off screen ) 2DROP
ELSE PLOT.TO THEN ;

HEX
: INITIALIZE-SQUARE ( -- )
SQUARE-P1 SIZE 0
DO DUP SIZE CELL* 81 FILL SIZE CELL* + LOOP DROP
20 SQUARE-P3 !
18 SQUARE-P4 !
-15 SQUARE-P1 ! -10 SQUARE-P2 ! ;
DECIMAL

DEFER MENU?
: DRAW-SURFACE ( -- )
SIZE 2- 0 DO ( column ) I SIZE + CELL* SQUARE-P1 +
10000 ( initial min Y value )
SIZE 1- 1 DO ( row )

OVER @ I SCALE Y-CONVERT 2DUP >
IF NIP
J SCALE
DUP DELTA + 3 PICK SIZE CELL* - CELL+ @ I
1- F-MOVE
DUP 3 PICK @ I F-LINE
DELTA + 2 PICK SIZE CELL* + CELL+ @ I 1+ F-LINE
ELSE ( hidden ) DROP THEN
SWAP SIZE CELL* + SWAP LOOP
2DROP LOOP ;

HEX

: +- ( n1 n2 -- n3 ) 0< IF NEGATE THEN ;

: SET-HEIGHT ( dh level px value yp value -- dh level )
ROT + 2/ -ROT AVE
DUP @ 8181 =
IF ( store ) SWAP 3 PICK RNDF +- + SWAP !
ELSE 2DROP THEN ;

DECIMAL


: SET-HEIGHTS ( p1 p2 p3 p4 delta-h level# -- )
( ave P1/P2 ) 5 PICK DUP @ 6 PICK DUP @ SET-HEIGHT
( ave P2/P3 ) 4 PICK DUP @ 5 PICK DUP @ SET-HEIGHT
( ave P3/P4 ) 3 PICK DUP @ 4 PICK DUP @ SET-HEIGHT
( ave P1/P4 ) 5 PICK DUP @ 4 PICK DUP @ SET-HEIGHT
( ave P1/P3 ) 5 PICK DUP @ 5 PICK DUP @ SET-HEIGHT ;

: SQUARE1 ( p1 p2 p3 p4 delta-h level# -- <2.copies> )
5 PICK DUP 6 PICK AVE
OVER 6 PICK AVE 8 PICK 6 PICK AVE
5 PICK 2/ 5 PICK 1- ;

: SQUARE2 ( p1 p2 p3 p4 delta-h level# -- <2.copies> )
5 PICK 5 PICK AVE 5 PICK
DUP 6 PICK AVE OVER 6 PICK AVE
5 PICK 2/ 5 PICK 1- ;

: SQUARE3 ( p1 p2 p3 p4 delta-h level# -- <2.copies> )
5 PICK 4 PICK AVE 5 PICK 5 PICK AVE
5 PICK DUP 6 PICK AVE
5 PICK 2/ 5 PICK 1- ;

: SQUARE4 ( p1 p2 p3 p4 delta-h level# -- <2.copies> )
5 PICK 3 PICK AVE 5 PICK 4 PICK AVE
5 PICK 5 PICK AVE 5 PICK
5 PICK 2/ 5 PICK 1- ;

: CALCULATE-SURFACE ( p1 p2 p3 p4 delta-h level# -- )
SET-HEIGHTS DUP
IF ( non-zero level )
SQUARE1 RECURSE
SQUARE2 RECURSE
SQUARE3 RECURSE
SQUARE4 RECURSE
THEN
2DROP 2DROP 2DROP ;

: SEA-LEVEL ( -- )
SQUARE-P1 SIZE 0 DO
SIZE 0 DO
DUP @ DUP 0<
IF ( below sea level -- add fudge factor for waves )
1 AND I J + + 7 AND OVER !
ELSE DROP THEN
CELL+ LOOP
LOOP DROP ;

: .M-KEY ( -- )
cgs cr cr ." Hit any Key to get the Menu" ;

: 3S ( -- ) 3 SPACES ;
: .WAIT ( --) cr ." PLEASE WAIT" ;

2VARIABLE SEED-SAVE

: .SEED SEED-SAVE 2@ <# #S #> TYPE 5 spaces ;

: SEED-OUTPUT cr cr cr ." SEED:" .SEED ;

: LANDSCAPE ( -- )
SEED 2@ SEED-SAVE 2! INITIALIZE-SQUARE
SQUARE-P1 SQUARE-P2 SQUARE-P3 SQUARE-P4
YMAX 2/ #LEVELS CALCULATE-SURFACE
SEA-LEVEL
.M-KEY SEED-OUTPUT DRAW-SURFACE ;

comment:
\ 14jul87mds


.SEED is used again to be sure the surface does not overwrite
the first digit of the displayed seed.

comment;

\ Routines to save a graphics screen 14jul87mds

2VARIABLE !SEED

: !CALC ( store the calculation array and saved seed )
( SQ>BUF ) SEED-SAVE @ !SEED ! ;

: @CALC ( restore the calculation array and saved seed )
( BUF>SQ ) !SEED @ SEED-SAVE ! ;


\ Fractal Landscape routines 14jul87mds

: INSTRUCTIONS ( -- ) hgcs cr
." This program draws random FRACTAL LANDSCAPES. " cr
." It was written in FORTH. " cr
." The picture's seed is displayed in the lower " cr
." right corner." cr cr
." The seed is all you need " cr
." to recreate the picture later !" cr cr
." While it is drawing, hit any key to see the menu." cr
." Once it has finished, it will pause to allow you" cr
." to hit a key. If you do not hit a key, it will" cr
." draw another landscape anyway, after a pause." cr cr cr
.HALT HALT hgcs cr cr
." From the menu," CR
." `L' draws new Landscapes." CR cr
." `H' repeats these instructions." CR cr
." `Q' leaves this program and exits to FORTH." CR CR
." `I' recreates a landscape from your Input" cr
." seed. It prompts you to input the seed and hit" cr
." . Before hitting , " cr
." may be used to edit the input if you accident-" cr
." ally something that isn't a number," cr
.HALT HALT hgcs cr cr
;

\ Fractal Landscape routines 14aug87mds

: .LMENU hgcs cr
cr ." RANDOM FRACTAL LANDSCAPES -- MAIN MENU "
cr ." ---------------------------------------------" cr
cr ." `L' continues drawing fractal landscapes"
cr ." ( hitting space bar will pause). " cr
cr ." `H' gives Help by repeating the instructions" cr
cr ." 'I' draws a landscape from seed input. " cr
cr ." `Q' Quits back to FORTH" cr cr
cr ." Please choose on of the above options. " cr cr
;

: .WAIT-WORLD cgs hgcs cr cr
." Wait a moment while I create a piece of the world ..." ;

: SEED-INPUT ( -- ) hgcs !CALC
cr ." Input the seed ... "
D#IN SEED 2! .WAIT-WORLD
LANDSCAPE @CALC ;
: LANDSCAPES ( --)
BEGIN LANDSCAPE
800 0 DO LOOP
KEY?
UNTIL
;

: (LS) ( -- ) INSTRUCTIONS cr cr
.LMENU
BEGIN KEY UPC DUP ASCII Q <>
WHILE DUP ASCII L = IF DROP .WAIT-WORLD LANDSCAPES ELSE
DUP ASCII I = IF DROP SEED-INPUT ELSE
DUP BL = IF DROP .HALT key drop ELSE
DROP .LMENU THEN THEN THEN
REPEAT DROP TEXT
;

: LS ( -- )
gr ge
32 0 80 40 twind hgcs
RANDOMIZE (LS) ;



  3 Responses to “Category : Forth Source Code
Archive   : FPCHERC.ZIP
Filename : HGFRACT.SEQ

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/