diff options
| -rwxr-xr-x | forth/wmaze.fs | 79 |
1 files changed, 79 insertions, 0 deletions
diff --git a/forth/wmaze.fs b/forth/wmaze.fs new file mode 100755 index 0000000..e70a003 --- /dev/null +++ b/forth/wmaze.fs @@ -0,0 +1,79 @@ +#! /usr/bin/env gforth +\ Game to wander a maze finding treasure until a victory animation. +\ : gamename c" wmaze" ; gamename find [if] wmaze [endif] drop marker wmaze +\ Near-minimal roguelike? + +\ This program is in the public domain. To the extent possible under +\ law, Kragen Javier Sitaker has waived all copyright and related or +\ neighboring rights to the wmaze.fs roguelike. This work is published +\ from Argentina; see +\ <http://creativecommons.org/publicdomain/zero/1.0/> for details. + +: csi 27 emit ." [" ; + +( \ To run in pforth, comment out the #! at the top and uncomment this block: +: time&date 53 0 0 0 0 0 ; : form 23 80 ; +: at-xy csi 1+ 0 .r ." ;" 1+ 0 .r ." H" ; +\ ) + +\ Linear congruential random number generator MINSTD for 32+-bit Forths: +time&date - - - - - value seed +decimal : rand seed 48271 m* 2147483647 sm/rem drop dup to seed swap mod ; + +\ Match dungeon size to screen. +form value width 1- value height : size width height * ; + +0 value array : at@ cells array + @ ; : at! cells array + ! ; \ array access +: iota 0 ?do i , loop ; : ints 0 ?do i at@ . loop ; \ filling and dumping + +\ Fisher-Yates shuffle for randomizing the maze generation +-1 value x : shuffle 0 ?do i 1+ rand to x x at@ i at@ x at! i at! loop ; +create deck size iota deck to array size shuffle + +\ Union-find to make a good maze +create dads size iota +: family dads to array dup dup at@ <> if dup at@ recurse tuck swap at! then ; +: connected? family swap family = ; + +char ! value wall create board size allot board size wall fill +0 value lastcolor : nocolor csi ." m" 0 to lastcolor ; +: color csi 0 .r ." ;1m" ; +: color? 8 mod 30 + dup lastcolor <> if dup color then to lastcolor ; +: colorize 0 ?do dup i + c@ dup 7 + color? emit loop drop ; +: .board board height 0 ?do dup width colorize cr width + loop drop ; +: put board + c! ; : redraw 0 0 at-xy .board ; : row width / ; : col width mod ; +: lr? col dup 0= swap width 1- = or ; : -> 1+ ; : <- 1- ; \ positions +: tb? row dup 0= swap height 1- = or ; : >u width - ; : >d width + ; +: tblink? dup >u swap >d connected? ; : lrlink? dup <- swap -> connected? ; +: connect? dup board + c@ bl = if family at! else 2drop then ; +: connect-l dup <- connect? ; : connect-r dup -> connect? ; +: connect-u dup >u connect? ; : connect-d dup >d connect? ; +: dig bl over put dup connect-l dup connect-r dup connect-u connect-d ; +: digin? dup tblink? if drop exit then dup lrlink? if drop exit then dig ; +: dig? dup lr? if drop exit then dup tb? if drop exit then digin? ; +64 value frame : animate ( n -- ) frame mod 0= if redraw 16 ms then ; +: amaze size 0 ?do deck to array i at@ dig? i animate loop ; + +\ Plant treasure to provide an artificial objective to strive for +: randcell ( -- index borderflag ) size rand dup dup lr? swap tb? or ; +: enrich height 0 ?do randcell if drop else [char] $ swap put then loop ; +: treasure 0 size 0 ?do i board + c@ [char] $ = if 1+ then loop ; + +height 2/ width * width 2/ + value dude +: mvaddch 2dup put dup col swap row at-xy dup 7 + color? emit ; +: draw-dude [char] @ dude mvaddch ; : erase-dude [char] . dude mvaddch ; +: try-move dup board + c@ wall <> + if erase-dude to dude draw-dude else drop then ; +: act ( c -- ) case \ Dispatch key command. + [char] w of dude <- try-move endof [char] d of dude -> try-move endof + [char] s of dude >d try-move endof [char] a of dude >u try-move endof + [char] q of drop 0 endof + endcase ; +: victory size 0 ?do dup i deck to array at@ put i animate loop drop + frame 2* to frame ; +: wander amaze enrich redraw draw-dude 1 begin dup treasure min while + 0 height at-xy nocolor ." [wasd] " treasure . key act repeat drop + treasure 0= if frame 8 / to frame + [char] * victory [char] ! victory [char] $ victory bl victory + redraw then ; +page wander cr nocolor bye |