blob: e70a003dd4a96c5317065d0a139de270ac5e318d (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
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
|