worlds/haxima-1.002/terrain-to-ptype.scm

   1 ;; terrain to party type
   2
   3 ;; ttp-entry: each row in the subtable for a terrain in the terrain-to-ptype
   4 ;; table is one of these
   5 (define (ttp-entry-mk ptype level occur)
   6   (list ptype level occur))
   7 (define (ttp-entry-ptype ttpe) (car ttpe))
   8 (define (ttp-entry-level ttpe) (cadr ttpe))
   9 (define (ttp-entry-occur ttpe) (caddr ttpe))
  10
  11 (define terrain-to-ptype-tbl
  12   (list
  13    (list t_grass
  14          (ttp-entry-mk 'forest-goblin-party-l1 1 1)
  15          (ttp-entry-mk 'bandit-party-l1        1 1)
  16          (ttp-entry-mk 'headless-party-l1      1 1)
  17          (ttp-entry-mk 'forest-goblin-party-l2 2 1)
  18          (ttp-entry-mk 'bandit-party-l2        2 1)
  19          (ttp-entry-mk 'bandit-party-l3        3 1)
  20          (ttp-entry-mk 'headless-party-l3      3 1)
  21          (ttp-entry-mk 'bandit-party-l4        4 1)
  22          (ttp-entry-mk 'accursed-party-l4      4 1)
  23          (ttp-entry-mk 'militia-party-l4       4 1)
  24          (ttp-entry-mk 'bandit-party-l5        5 1)
  25          (ttp-entry-mk 'headless-party-l5      5 1)
  26          (ttp-entry-mk 'accursed-party-l5      5 1)
  27          (ttp-entry-mk 'accursed-party-l6      6 1)
  28          )
  29    (list t_forest
  30          (ttp-entry-mk 'forest-goblin-party-l1 1 1)
  31          (ttp-entry-mk 'wolf-party-l1          1 1)
  32          (ttp-entry-mk 'wolf-party-l2          2 1)
  33          (ttp-entry-mk 'dryad-party-l3         3 1)
  34          (ttp-entry-mk 'forest-goblin-party-l3 3 1)
  35          (ttp-entry-mk 'spider-party-l3        3 1)
  36          (ttp-entry-mk 'forest-goblin-party-l4 4 1)
  37          (ttp-entry-mk 'spider-party-l4        4 1)
  38          (ttp-entry-mk 'dryad-party-l4         4 1)
  39          (ttp-entry-mk 'wisp-party-l5          5 1)
  40          (ttp-entry-mk 'dryad-party-l5         5 1)
  41          )
  42    (list t_trees
  43          (ttp-entry-mk 'forest-goblin-party-l1 1 1)
  44          (ttp-entry-mk 'forest-goblin-party-l2 2 1)
  45          (ttp-entry-mk 'forest-goblin-party-l3 3 1)
  46          (ttp-entry-mk 'wolf-party-l1          1 1)
  47          (ttp-entry-mk 'wolf-party-l2          2 1)
  48          (ttp-entry-mk 'spider-party-l3        3 1)
  49          (ttp-entry-mk 'spider-party-l4        4 1)
  50          (ttp-entry-mk 'snake-party-l1         1 1)
  51          (ttp-entry-mk 'bat-party-l1           1 1)
  52          (ttp-entry-mk 'rat-party-l1           1 1)
  53          )
  54    (list t_hills
  55          (ttp-entry-mk 'spider-party-l3 3 30)
  56          (ttp-entry-mk 'spider-party-l4 4 30)
  57          (ttp-entry-mk 'troll-party-l3  3 30)
  58          (ttp-entry-mk 'troll-party-l4  4 30)
  59          (ttp-entry-mk 'gint-party-l4   4 20)
  60          (ttp-entry-mk 'gint-party-l5   5 20)
  61          (ttp-entry-mk 'gint-party-l6   6 20)
  62          (ttp-entry-mk 'dragon-party-l7 7 6)
  63          )
  64    (list t_mountains
  65          (ttp-entry-mk 'nil              0 100)
  66          (ttp-entry-mk 'bat-party-l1     1 20)
  67          (ttp-entry-mk 'griffin-party-l3 3 10)
  68          (ttp-entry-mk 'dragon-party-l6  6 1)
  69          (ttp-entry-mk 'dragon-party-l8  8 1)
  70          )
  71    (list t_bog
  72          (ttp-entry-mk 'skeleton-party-l2     2 1)
  73          (ttp-entry-mk 'ghast-party           2 1)
  74          (ttp-entry-mk 'green-slime-party-l2  2 1)
  75          (ttp-entry-mk 'skeleton-party-l3     3 1)
  76          (ttp-entry-mk 'yellow-slime-party-l3 3 1)
  77          (ttp-entry-mk 'skeleton-party-l4     4 1)
  78          (ttp-entry-mk 'lich-party-l5         5 1)
  79          (ttp-entry-mk 'hydra-party-l5        5 1)
  80          )
  81    (list t_shoals
  82          (ttp-entry-mk 'nil                  0 4)
  83          (ttp-entry-mk 'nixie-party-l2       2 4)
  84          (ttp-entry-mk 'kraken-party-l3      3 2)
  85          (ttp-entry-mk 'sea-serpent-party-l3 3 1)
  86          )
  87    (list t_shallow
  88          (ttp-entry-mk 'nil                  0 16)
  89          (ttp-entry-mk 'kraken-party-l3      3 6)
  90          (ttp-entry-mk 'sea-serpent-party-l3 3 6)
  91          (ttp-entry-mk 'nixie-party-l3       3 16)
  92          (ttp-entry-mk 'nixie-party-l4       4 16)
  93          (ttp-entry-mk 'nixie-party-l5       5 16)
  94          (ttp-entry-mk 'dragon-party-l6      6 3)
  95          )
  96    (list t_deep
  97          (ttp-entry-mk 'nil                  0 96)
  98          (ttp-entry-mk 'kraken-party-l3      3 8)
  99          (ttp-entry-mk 'sea-serpent-party-l3 3 8)
 100          (ttp-entry-mk 'pirate-party-l3      3 8)
 101          (ttp-entry-mk 'pirate-party-l4      4 8)
 102          (ttp-entry-mk 'skeleton-pirates-l4  4 8)
 103          (ttp-entry-mk 'dragon-party-l6      6 3)
 104          (ttp-entry-mk 'dragon-party-l8      8 3)
 105          )
 106    (list t_lava
 107          (ttp-entry-mk 'fire-slime-party-l4 4 20)
 108          (ttp-entry-mk 'dragon-party-l6 6 1)
 109          (ttp-entry-mk 'dragon-party-l8 8 1)
 110          )
 111    ))
 112
 113 ;;----------------------------------------------------------------------------
 114 ;; "private"
 115 (define (terrain-to-ptypes kter)
 116   (let ((entry (assoc kter terrain-to-ptype-tbl)))
 117     (if (not entry)
 118         nil
 119         (cdr entry)
 120         )))
 121
 122 (define (ttp-list-modulus entries)
 123   (foldr (lambda (sum entry)
 124            (+ sum (ttp-entry-occur entry)))
 125          0
 126          entries))
 127
 128 (define (ttp-list-lookup entries n)
 129   (cond ((null? entries) nil)
 130         (else
 131          (if (< n (ttp-entry-occur (car entries)))
 132              (begin
 133                (eval (ttp-entry-ptype (car entries)))
 134                )
 135              (ttp-list-lookup (cdr entries)
 136                               (- n (ttp-entry-occur (car entries)))
 137                               )))))
 138
 139 (define (ttp-list-filter entries lvl)
 140   (filter (lambda (entry)
 141             (<= (ttp-entry-level entry) lvl))
 142           entries))
 143
 144 (define (ttp-list-select entries lvl)
 145   (let ((entries (ttp-list-filter entries lvl)))
 146     (if (null? entries)
 147         nil
 148         (let ((n (modulo (random-next)
 149                          (ttp-list-modulus entries))))
 150           (ttp-list-lookup entries n)))))
 151
 152 ;;----------------------------------------------------------------------------
 153 ;; public
 154 (define (terrain-to-ptype kter lvl)
 155   (let ((subtable (assoc kter terrain-to-ptype-tbl)))
 156     (if (not subtable)
 157         nil
 158         (ttp-list-select (cdr subtable) lvl))))