worlds/haxima-1.002/vehicles.scm

   1
   2 ;;---------------------------------------------------------------
   3 ;; utility stuff
   4
   5 (define (vehicle-broadside-facing vehicle dx dy)
   6         (let ((facing (kern-obj-get-facing vehicle)))
   7                 (cond ((< dx 0) ;;west side
   8                                         (if (equal? facing NORTH) NORTH SOUTH))
   9                                 ((> dx 0) ;;east side
  10                                         (if (equal? facing SOUTH) SOUTH NORTH))
  11                                 ((< dy 0) ;;north side
  12                                         (if (equal? facing WEST) WEST EAST))
  13                                 ((> dy 0) ;;south side
  14                                         (if (equal? facing EAST) EAST WEST))
  15                                 (else facing)
  16                 )))
  17
  18 (define (map-paste-centered dst-map src-map src-x src-y src-w src-h dst-x dst-y dst-w dst-h)
  19         (let* ((cw (min src-w dst-w))
  20                 (ch (min src-h dst-h))
  21                 (src-cx (floor (+ src-x (/ (- src-w cw) 2))))
  22                 (dst-cx (floor (+ dst-x (/ (- dst-w cw) 2))))
  23                 (src-cy (floor (+ src-y (/ (- src-h ch) 2))))
  24                 (dst-cy (floor (+ dst-y (/ (- dst-h ch) 2)))))
  25                 (kern-blit-map dst-map dst-cx dst-cy
  26                         src-map src-cx src-cy
  27                         cw ch)
  28         ))
  29
  30 (define (place-add-objects-offset place src-x src-y src-w src-h dst-x dst-y dst-w dst-h objectlist)
  31         (let* ((cw (min src-w dst-w))
  32                 (ch (min src-h dst-h))
  33                 (src-cx (floor (+ src-x (/ (- src-w cw) 2))))
  34                 (dst-cx (floor (+ dst-x (/ (- dst-w cw) 2))))
  35                 (src-cy (floor (+ src-y (/ (- src-h ch) 2))))
  36                 (dst-cy (floor (+ dst-y (/ (- dst-h ch) 2))))
  37                 (dx (- dst-cx src-cx))
  38                 (dy (- dst-cy src-cy)))
  39                 (map
  40                         (lambda (objectentry)
  41                                 (kern-obj-put-at (car objectentry)
  42                                         (list place
  43                                                 (+ (cadr objectentry) dx)
  44                                                 (+ (caddr objectentry) dy)
  45                                         ))
  46                         )
  47                         objectlist
  48                 )
  49         ))
  50
  51 (define (mk-vehicle ktype)
  52   (kern-mk-vehicle ktype north 100))
  53
  54 (define (vehicle-object-list-rotate facing n-wid n-hgt objectlist)
  55         (let* ((turn-matrix (cond
  56                                 ((equal? facing NORTH) (list 0 0 1 0 0 1))
  57                                 ((equal? facing EAST) (list (- n-hgt 1) 0 0 -1 1 0))
  58                                 ((equal? facing WEST) (list 0 (- n-wid 1) 0 1 -1 0))
  59                                 (else (list (- n-wid 1) (- n-hgt 1) -1 0 0 -1))))
  60                         (xoff (car turn-matrix))
  61                         (yoff (cadr turn-matrix))
  62                         (xxmult (list-ref turn-matrix 2))
  63                         (xymult (list-ref turn-matrix 3))
  64                         (yxmult (list-ref turn-matrix 4))
  65                         (yymult (list-ref turn-matrix 5)))
  66                         (map
  67                                 (lambda (objectentry)
  68                                         (list
  69                                                 (car objectentry)
  70                                                 (+ xoff (* xxmult (cadr objectentry)) (* xymult (caddr objectentry)))
  71                                                 (+ yoff (* yxmult (cadr objectentry)) (* yymult (caddr objectentry)))
  72                                         )
  73                                 )
  74                                 objectlist
  75                         )
  76         ))
  77
  78 (define (facing-turn-90right facing)
  79         (cond ((equal? facing NORTH) EAST)
  80                 ((equal? facing WEST) NORTH)
  81                 ((equal? facing EAST) SOUTH)
  82                 ((equal? facing SOUTH) WEST)
  83                 (else facing)))
  84
  85 (define (facing-turn-90left facing)
  86         (cond ((equal? facing NORTH) WEST)
  87                 ((equal? facing WEST) SOUTH)
  88                 ((equal? facing EAST) NORTH)
  89                 ((equal? facing SOUTH) EAST)
  90                 (else facing)))
  91
  92
  93 ;;--------------------------------------------------------------------------
  94 ;; vehicle objects: wheel
  95
  96 (define shipwheel-ifc
  97         (ifc '()
  98                 (method 'init
  99                         (lambda (kwheel)
 100                                 (kern-obj-set-facing kwheel (gob kwheel))
 101                 ))
 102         ))
 103
 104 (mk-obj-type 't_shipswheel "ÂÉÎØ" s_shipswheel layer-mechanism shipwheel-ifc)
 105
 106 (define  (vehicle-mk-wheel facing)
 107         (let ((kwheel (kern-mk-obj t_shipswheel 1)))
 108           (kern-obj-set-facing kwheel facing)
 109           (bind kwheel facing)
 110           kwheel))
 111
 112 ;;---------------------------------------------------------------------------
 113 ;; boarding ramp handling
 114
 115 (define onramp-ifc
 116         (ifc '()
 117                 (method 'exec
 118                         (lambda (kramp)
 119                                 (let* ((kloc (kern-obj-get-location kramp))
 120                                         (kplace (car kloc))
 121                                         (wid (kern-place-get-width kplace))
 122                                         (hgt (kern-place-get-height kplace))
 123                                         (rx (cadr kloc))
 124                                         (ry (caddr kloc)))
 125                                         (define (vehicle-check-ramp x y)
 126                                                 (cond ((< x 0) 0)
 127                                                         ((> x wid) 0)
 128                                                         ((< y 0) 0)
 129                                                         ((> y hgt) 0)
 130                                                         ((kern-place-is-passable (list kplace x y) kramp) 1)
 131                                                         (else
 132                                                                 (let ((objs (kern-get-objects-at (list kplace x y))))
 133                                                                         (if (and (not (null? objs))
 134                                                                                         (equal? (kern-obj-get-type (car objs)) (eval 't_onramp)))
 135                                                                                 1
 136                                                                                 0)))
 137                                                 ))
 138                                         (define (vehicle-trigger-ramp-neighbors x y)
 139                                                 (cond ((< x 0) 0)
 140                                                         ((> x wid) 0)
 141                                                         ((< y 0) 0)
 142                                                         ((> y hgt) 0)
 143                                                         (else
 144                                                                 (let ((objs (kern-get-objects-at (list kplace x y))))
 145                                                                         (if (and (not (null? objs))
 146                                                                                         (equal? (kern-obj-get-type (car objs)) (eval 't_onramp)))
 147                                                                                 ((kobj-ifc (car objs)) 'exec (car objs))
 148                                                                                 0)))
 149                                                 ))
 150                                         (if (< 1
 151                                                         (+ (vehicle-check-ramp (+ rx 1) ry)
 152                                                                 (vehicle-check-ramp (- rx 1) ry)
 153                                                                 (vehicle-check-ramp rx (+ ry 1))
 154                                                                 (vehicle-check-ramp rx (- ry 1))))
 155                                                 (begin
 156                                                         (kern-place-set-terrain (list kplace rx ry) t_deck)
 157                                                         (kern-obj-remove kramp)
 158                                                         (vehicle-trigger-ramp-neighbors (+ rx 1) ry)
 159                                                         (vehicle-trigger-ramp-neighbors (- rx 1) ry)
 160                                                         (vehicle-trigger-ramp-neighbors  rx (+ ry 1))
 161                                                         (vehicle-trigger-ramp-neighbors  rx (- ry 1))
 162                                                 )
 163                                                 (kern-obj-remove kramp)
 164                                         )
 165                         )))
 166                 ))
 167
 168 (mk-obj-type 't_onramp nil nil layer-none onramp-ifc)
 169
 170 ;;------------------------------------------------------------------------
 171 ;; ship
 172
 173 (kern-mk-map
 174  'm_ship_n 9 17 pal_expanded
 175  (list
 176   "-- -- -- -- -- -- -- -- --";
 177   "-- -- -- #e #a #f -- -- --";
 178   "-- -- #e #E ee #F #f -- --";
 179   "-- #e #E ee ee ee #F #f --";
 180   "-- #b ee ee ee ee ee #c --";
 181   "-- #b <n #= #= #= <n #c --";
 182   "-- ee ee ee oo ee ee ee --";
 183   "-- #b ee ee ee ee ee #c --";
 184   "-- #b ee ee ee ee ee #c --";
 185   "-- #b ee ee ee ee ee #c --";
 186   "-- ee ee ee ee ee ee ee --";
 187   "-- #b ee ee oo ee ee #c --";
 188   "-- #b <s #= #= #= <s #c --";
 189   "-- #b ee ee ee ee ee #c --";
 190   "-- #g #G ee ee ee #H #h --";
 191   "-- -- #g #d #d #d #h -- --";
 192   "-- -- -- -- -- -- -- -- --";
 193   ))
 194
 195 (kern-mk-map
 196  'm_ship_s 9 17 pal_expanded
 197  (list
 198   "-- -- -- -- -- -- -- -- --";
 199   "-- -- #e #a #a #a #f -- --";
 200   "-- #e #E ee ee ee #F #f --";
 201   "-- #b ee ee ee ee ee #c --";
 202   "-- #b <n #= #= #= <n #c --";
 203   "-- #b ee ee oo ee ee #c --";
 204   "-- ee ee ee ee ee ee ee --";
 205   "-- #b ee ee ee ee ee #c --";
 206   "-- #b ee ee ee ee ee #c --";
 207   "-- #b ee ee ee ee ee #c --";
 208   "-- ee ee ee oo ee ee ee --";
 209   "-- #b <s #= #= #= <s #c --";
 210   "-- #b ee ee ee ee ee #c --";
 211   "-- #g #G ee ee ee #H #h --";
 212   "-- -- #g #G ee #H #h -- --";
 213   "-- -- -- #g #d #h -- -- --";
 214   "-- -- -- -- -- -- -- -- --";
 215   ))
 216
 217 (kern-mk-map
 218  'm_ship_e 17 9 pal_expanded
 219  (list
 220   "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --";
 221   "-- -- #e #a #a #a ee #a #a #a ee #a #a #f -- -- --";
 222   "-- #e #E ee <w ee ee ee ee ee ee <e ee #F #f -- --";
 223   "-- #b ee ee #| ee ee ee ee ee ee #| ee ee #F #f --";
 224   "-- #b ee ee #| oo ee ee ee ee oo #| ee ee ee #c --";
 225   "-- #b ee ee #| ee ee ee ee ee ee #| ee ee #H #h --";
 226   "-- #g #G ee <w ee ee ee ee ee ee <e ee #H #h -- --";
 227   "-- -- #g #d #d #d ee #d #d #d ee #d #d #h -- -- --";
 228   "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --";
 229   ))
 230
 231 (kern-mk-map
 232  'm_ship_w 17 9 pal_expanded
 233  (list
 234   "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --";
 235   "-- -- -- #e #a #a ee #a #a #a ee #a #a #a #f -- --";
 236   "-- -- #e #E ee <w ee ee ee ee ee ee <e ee #F #f --";
 237   "-- #e #E ee ee #| ee ee ee ee ee ee #| ee ee #c --";
 238   "-- #b ee ee ee #| oo ee ee ee ee oo #| ee ee #c --";
 239   "-- #g #G ee ee #| ee ee ee ee ee ee #| ee ee #c --";
 240   "-- -- #g #G ee <w ee ee ee ee ee ee <e ee #H #h --";
 241   "-- -- -- #g #d #d ee #d #d #d ee #d #d #d #h -- --";
 242   "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --";
 243   ))
 244
 245 (define vehicle-ship-handler
 246         (lambda (place vehicle off_x off_y)
 247                 (let* ((facing (vehicle-broadside-facing vehicle off_x off_y))
 248                         (vmap (get-cardinal-lref (list m_ship_n m_ship_w m_ship_e m_ship_s) facing))
 249                         (src-w (kern-terrainmap-get-width vmap))
 250                         (src-h (kern-terrainmap-get-height vmap))
 251                         (dst-x (combat-off-to-dst off_x))
 252                         (dst-y (combat-off-to-dst off_y))
 253                         (dst-w (combat-off-to-len (kern-place-get-width place) off_x))
 254                         (dst-h (combat-off-to-len (kern-place-get-height place) off_y)))
 255                 (map-paste-centered (kern-place-get-terrain-map place) vmap
 256                         0 0 src-w src-h
 257                         dst-x dst-y dst-w dst-h)
 258                 (place-add-objects-offset place
 259                         0 0 src-w src-h
 260                         dst-x dst-y dst-w dst-h
 261                         (vehicle-object-list-rotate facing 9 17
 262                         (list
 263                                 (list (vehicle-mk-wheel facing) 4 12)
 264                                 (list (arms-mk-cannon (facing-turn-90right facing)) 7 8)
 265                                 (list (arms-mk-cannon (facing-turn-90left facing)) 1 8)
 266                                 (list (kern-mk-obj t_onramp 1) 0 6)
 267                                 (list (kern-mk-obj t_onramp 1) 8 6)
 268                                 (list (kern-mk-obj t_onramp 1) 0 10)
 269                                 (list (kern-mk-obj t_onramp 1) 8 10)
 270                         )))
 271         )))
 272
 273
 274 (kern-mk-vehicle-type 't_ship   ; tag
 275                       "Á¥"      ; name
 276                       s_ship    ; sprite
 277                       m_ship_n    ; map
 278                       t_cannon  ; ordnance
 279                       #t        ; vulnerable
 280                       #t        ; occupants die when destroyed
 281                       #t        ; must turn
 282                       "sail"    ; move description
 283                       sound-ship-move ; move sound
 284                       1           ; tailwind penalty
 285                       4           ; headwind penalty
 286                       2           ; crosswind penalty
 287                       100         ; max hp
 288                       speed-ship  ; speed
 289                       mmode-ship  ; pmask
 290                       vehicle-ship-handler;
 291                       )
 292
 293 (define (mk-ship)
 294   (kern-mk-vehicle t_ship north 100))
 295
 296 ;;----------------------------------------------------------------------------
 297 ;; voidship
 298 ;;----------------------------------------------------------------------------
 299 (kern-mk-map
 300  'm_voidship_n 9 17 pal_expanded
 301  (list
 302   "** ** ** ** ** ** ** ** **"
 303   "** ** ** ** ** ** ** ** **"
 304   "** ** ** #i #A #j ** ** **"
 305   "** ** #i #E ee #F #j ** **"
 306   "** #i #E ee ee ee #F #j **"
 307   "** #B ee ee 00 ee ee #C **"
 308   "** #B ee ee 00 ee ee #C **"
 309   "** #B ee ee ee ee ee #C **"
 310   "** ee ee ee ee ee ee ee **"
 311   "** #B ee ee ee ee ee #C **"
 312   "#n #m #O ee ee ee #N #m #o"
 313   "#m #m #M ee 00 ee #m #m #M"
 314   "#m #m #M ee ## ee #m #m #M"
 315   "#m #m #M #D ## #D #m #m #M"
 316   "#m #m #M ** ** ** #m #m #M"
 317   "#p #M #q ** ** ** #p #M #q"
 318   "** ** ** ** ** ** ** ** **"
 319   ))
 320
 321 (kern-mk-map
 322  'm_voidship_s 9 17 pal_expanded
 323  (list
 324   "** ** ** ** ** ** ** ** **"
 325   "#n #m #o ** ** ** #n #m #o"
 326   "#m #m #M ** ** ** #m #m #M"
 327   "#m #m #M #A ## #A #m #m #M"
 328   "#m #m #M ee ## ee #m #m #M"
 329   "#m #m #M ee 00 ee #m #m #M"
 330   "#p #M #Q ee ee ee #P #M #q"
 331   "** #B ee ee ee ee ee #C **"
 332   "** ee ee ee ee ee ee ee **"
 333   "** #B ee ee ee ee ee #C **"
 334   "** #B ee ee 00 ee ee #C **"
 335   "** #B ee ee 00 ee ee #C **"
 336   "** #k #G ee ee ee #H #l **"
 337   "** ** #k #G ee #H #l ** **"
 338   "** ** ** #k #D #l ** ** **"
 339   "** ** ** ** ** ** ** ** **"
 340   "** ** ** ** ** ** ** ** **"
 341   ))
 342
 343 (kern-mk-map
 344  'm_voidship_e 17 9 pal_expanded
 345  (list
 346   "** #n #m #m #m #m #o ** ** ** ** ** ** ** ** ** **";
 347   "** #m #m #m #m #m #M #A ee #A #A #A #j ** ** ** **";
 348   "** #p #M #M #M #M #Q ee ee ee ee ee #F #j ** ** **";
 349   "** ** ** #B ee ee ee ee ee ee ee ee ee #F #j ** **";
 350   "** ** ** ## ## 00 ee ee ee ee 00 00 ee ee #C ** **";
 351   "** ** ** #B ee ee ee ee ee ee ee ee ee #H #l ** **";
 352   "** #n #m #m #m #m #O ee ee ee ee ee #H #l ** ** **";
 353   "** #m #m #m #m #m #M #D ee #D #D #D #l ** ** ** **";
 354   "** #p #M #M #M #M #q ** ** ** ** ** ** ** ** ** **";
 355   ))
 356
 357
 358 (kern-mk-map
 359  'm_voidship_w 17 9 pal_expanded
 360  (list
 361   "** ** ** ** ** ** ** ** ** ** #n #m #m #m #m #o **";
 362   "** ** ** ** #i #A #A #A ee #A #m #m #m #m #m #M **";
 363   "** ** ** #i #E ee ee ee ee ee #P #M #M #M #M #q **";
 364   "** ** #i #E ee ee ee ee ee ee ee ee ee #C ** ** **";
 365   "** ** #B ee ee 00 00 ee ee ee ee 00 ## ## ** ** **";
 366   "** ** #k #G ee ee ee ee ee ee ee ee ee #C ** ** **";
 367   "** ** ** #k #G ee ee ee ee ee #N #m #m #m #m #o **";
 368   "** ** ** ** #k #D #D #D ee #D #m #m #m #m #m #M **";
 369   "** ** ** ** ** ** ** ** ** ** #p #M #M #M #M #q **";
 370   ))
 371
 372 (define vehicle-voidship-handler
 373         (lambda (place vehicle off_x off_y)
 374                 (let* ((facing (vehicle-broadside-facing vehicle off_x off_y))
 375                         (vmap (get-cardinal-lref (list m_voidship_n m_voidship_w m_voidship_e m_voidship_s) facing))
 376                         (src-w (kern-terrainmap-get-width vmap))
 377                         (src-h (kern-terrainmap-get-height vmap))
 378                         (dst-x (combat-off-to-dst off_x))
 379                         (dst-y (combat-off-to-dst off_y))
 380                         (dst-w (combat-off-to-len (kern-place-get-width place) off_x))
 381                         (dst-h (combat-off-to-len (kern-place-get-height place) off_y)))
 382                 (map-paste-centered (kern-place-get-terrain-map place) vmap
 383                         0 0 src-w src-h
 384                         dst-x dst-y dst-w dst-h)
 385                 (place-add-objects-offset place
 386                         0 0 src-w src-h
 387                         dst-x dst-y dst-w dst-h
 388                         (vehicle-object-list-rotate facing 9 17
 389                         (list
 390                                 (list (vehicle-mk-wheel facing) 4 6)
 391                                 (list (arms-mk-cannon (facing-turn-90right facing)) 7 6)
 392                                 (list (arms-mk-cannon (facing-turn-90left facing)) 1 6)
 393                                 (list (kern-mk-obj t_onramp 1) 0 8)
 394                                 (list (kern-mk-obj t_onramp 1) 8 8)
 395                         )))
 396         )))
 397
 398 (kern-mk-vehicle-type 't_voidship   ; tag
 399                       "µõ¶õÁ¥"    ; name
 400                       s_void_ship   ; sprite
 401                       m_voidship_n    ; map
 402                       t_cannon  ; ordnance
 403                       #t        ; vulnerable
 404                       #t        ; occupants die when destroyed
 405                       #t        ; must turn
 406                       "sail"    ; move description
 407                       sound-ship-move ; move sound
 408                       1           ; tailwind penalty
 409                       4           ; headwind penalty
 410                       2           ; crosswind penalty
 411                       100         ; max hp
 412                       speed-ship  ; speed
 413                       mmode-voidship  ; pmask
 414                       vehicle-voidship-handler;
 415                       )
 416
 417
 418 (define (mk-voidship)
 419   (kern-mk-vehicle t_voidship north 100))
 420