#! /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] h of dude <- try-move endof  [char] l of dude -> try-move endof
        [char] j of dude >d try-move endof  [char] k 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 ." [hjklq] " 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