squares

wordlist: squares

digression sq@ "bmpread"

mapmaking first

squares first


definitions

\ ---------------------

variable #terrains
0 #terrains !

20000000 constant infinite

\ a table n x n in size
: xtable ( n <name> -- )
  create dup ,
  dup * cells allot
;

: >= < not ;

: rangechk ( x y addr -- x y addr)
  dup @ ( x y start max )
  >r over r@ >= if abort" Table row out of range" then
  2 pick r> >= if abort" Table column out of range" then ( x y start)
;

: tablexy ( x y addr -- addr2)
  rangechk
  @+ ( x y size start )
  swap >r ( x y start |size)
  rot cells+
  swap r> * cells+
;

\ 4 5 <table> -- val
: xy@ ( x y addr -- addr)
  tablexy @
;

: xy! tablexy ! ;
: xy+! tablexy +! ;

: cfill ( addr cells value -- )
  -rot
  times
    2dup !
    cell+
  iterate
  2drop
;

: default ( n addr -- )
  @+ swap  ( n start size )
  dup * rot cfill
;

: clear ( addr)
  0 swap default
;

: size@ @ ;

: row! ( n y addr -- )
  2dup @ >= if abort" Illegal row store" then
  @+ ( n y size start )
  swap dup>r  ( n y start size |r: size)
  rot * cells+  ( n row^ |r:size)
  r> rot cfill
;

: col! ( n x addr -- )
  2dup @ >= if abort" Illegal col store" then
  @+ swap dup  times  ( n x rowStart size)
      over 2>r           ( n x rowStart |r: size rowStart)
      over cells+  ( n x col^ | size rowStart)
      2 pick      ( n x col^ n| size rowStart)
      swap ! ( n x  |size rowStart)
      r> r@ cells+ r> ( n x nextRowStart size)
  iterate
  4 drops
; 

: (rowmax) ( row^ sz -- maxx max )
  over @ 0 swap 2>r ( row^ sz |r: maxx max )
  begin
    1- ( row^ x |r: maxx max )
    2dup cells+ @
    dup r@ > if ( row^ x newmax |r: maxx oldmax)
      rdrop rdrop ( maxrow^ x newmax)
      2dup 2>r
    then
    drop
    ?dup while
  repeat
  drop 2r>
;

: preprow ( y table -- rowaddr sz) 
  dup @ rot ( addr sz y )
  2dup < if abort" non-existant row" then
  over >r
  * 1+ cells+ r> ( rowaddr sz)
;


: rowmax ( y table -- maxx max)
  preprow
  (rowmax)
;

: >row ( y table -- rowaddr)
  @+  ( y sz tabledata )
  -rot
  * cells+ ;

: .row ( y table -- )
  dup @ rot over >r * 1+ cells + r>
  0 do i . @+ swap . space loop drop cr ;

: rowsum ( y table -- t)
  preprow ( rowaddr sz)
  0 -rot
  times ( t addr)
    @+ >r + r>
  iterate
  drop
;

256 xtable costs

256 cells 2* create terrains$ allot

: t$ ( n -- caddr len) 2* cells terrains$ + 2@ ;

: t$! ( caddr len n -- )
  -rot (fix$) rot
  2* cells terrains$ + 2! ;  

: self! ( n x -- ) dup costs xy! ;
: self@ ( x -- ) dup costs xy@ ;

\ set cost from terrain y to any OTHER terrain to n
: any> ( n y -- )
  dup dup self@ ( n y y c)
  2>r ( n y |r: y c)
  costs col!
  r> r> self!
;

\ set cost of moving to any OTHER terrain from terrain y, to n
: >any ( n y -- )
  dup dup self@ ( n y y c)
  2>r ( n y |r: y c)
  costs row!
  r> r> self!
;

\ set cost of moving from x -> y terrain to n
: cost! ( n x y -- ) costs xy! ;
: cost@ ( x y -- cost ) costs xy@ ;
: cost? cost@ . ;

\ from x to y is average of x->x and y->y
\ from y to x is average of x->x and y->y
: avg ( x y -- )
  2dup dup cost@ swap dup cost@  ( x y ycost xcost)
  + 2/ ( x y average)
  >r   ( x y |r: average)
  2dup r@ -rot cost!
  swap r> -rot cost!
;

: +terrain ( cost <name> -- )
  #terrains @ dup 256 = if abort" Too many terrains!" then
  save-input
  constant
  restore-input bl word count #terrains @ t$!
  1 #terrains +!
;

: prev-terrain #terrains @ 1- ;

10 constant cheapest \ = 48miles per day=24"

48 constant fastest

3840 constant 1day
1day 24 / constant 1hr
1day 7 * constant 1week
1day 30 * constant 1month

: " ( n <name> -- )
  cheapest fastest rot */ mapscale ( cost <name> )
\  1day swap /
  +terrain
  prev-terrain ( cost index )
  self!
;

: averages!
  costs size@ ( size start)
  0 do
    costs size@
    0 do
      i j cost@
      cheapest = if  i j avg      then
    loop
  loop
;

cheapest costs default

\ These values are effectively 2 x the normal D&D move rates
+terrain impassible
infinite impassible self!
32 " opensea  \ slightly more risky, so avoid if possible
18 " city
48 " coastal
18 " plains
 9 " woods
24 " roads
12 " ltwoods
 9 " hills
 6 " wdhills
 1 " mts
 1 " swamp
 6 " desert
 4 " scrub
 6 " rough
30 " river
12 " ford
1 " jungle
4 " snow
\ 2 " ice
\ 6 " tundra

averages!

1month coastal any>
1month coastal >any

1week 2 * opensea any>
1week 2 * opensea >any

1month river any>
1month river >any

\ 1month swamp any>
\ 1month swamp >any

1week river ford cost!
1week ford river cost!

1day city river cost!
1hr 4 * river city cost!

river coastal avg
river opensea avg

coastal opensea avg

\ river swamp avg
\ coastal swamp avg
\ opensea swamp avg

1hr 6 * coastal city cost!
1hr 6 * opensea city cost!

1day city coastal cost!
1day city opensea cost!

1hr roads plains cost!

infinite impassible >any
infinite impassible any>

: .costs
  tab tab
  #terrains @ 1 do i t$ type tab loop cr
  #terrains @ 1 do i . i tab t$ type tab
    #terrains @ 1 do
      j i costs xy@ u. tab
    loop
    cr
  loop
  cr
;

\ .costs

: orthogcost ( from to -- cost)
  sq@ swap sq@ swap
  cost@
;

: diagcost ( from to -- cost) orthogcost 2828427 2000000 */ ;

export{

: move£ ( from to -- cost)
    2dup - abs  ( from to diff)
    dup 1 = if drop orthogcost
    else width = if orthogcost
        else diagcost
        then then
;


}export

previous definitions