core.lisp

(begin
  ;; we need this primitive because SDL's won't render scaled lines
  ;; algorithm ported from
  ;; http://tech-algorithm.com/articles/drawing-line-using-bresenham-algorithm/
  (define (line x y x2 y2 c)
    (let ((w (- x2 x))
          (h (- y2 y))
          (dx1 0) (dy1 0) (dx2 0) (dy2 0))
      (cond ((< w 0) (set! dx1 -1))
            ((> w 0) (set! dx1 1)))
      (cond ((< h 0) (set! dy1 -1))
            ((> h 0) (set! dy1 1)))
      (cond ((< w 0) (set! dx2 -1))
            ((> w 0) (set! dx2 1)))
      (let ((longest (abs w))
            (shortest (abs h)))
        (when (<= longest shortest)
              (set! longest (abs h))
              (set! shortest (abs w))
              (cond ((< h 0) (set! dy2 -1))
                    ((> h 0) (set! dy2 1)))
              (set! dx2 0))
        (let ((numerator (ash (truncate longest) -1)))
          (do ((i 0 (+ i 1)))
              ((> i longest))
            (pix x y c)
            (set! numerator (+ numerator shortest))
            (cond ((>= numerator longest)
                   (set! numerator (- numerator longest))
                   (set! x (+ x dx1))
                   (set! y (+ y dy1)))
                  (else (set! x (+ x dx2))
                        (set! y (+ y dy2)))))))))

  ;; brute force algorithm which performs at least 3x as fast as Bresenham's
  (define (circ x0 y0 radius c)
    (do ((y (- radius) (+ y 1))) ((> y radius))
      (do ((x (- radius) (+ x 1))) ((> x radius))
        (when (< (+ (* x x) (* y y)) (+ (* radius radius) radius))
              (pix (+ x0 x) (+ y0 y) c)))))

  (define (circb x0 y0 radius c)
    (do ((y (- radius) (+ y 1))) ((> y radius))
      (do ((x (- radius) (+ x 1))) ((> x radius))
        (when (and (> (+ (* x x) (* y y)) (- (* radius radius) radius))
                   (< (+ (* x x) (* y y)) (+ (* radius radius) radius)))
              (pix (+ x0 x) (+ y0 y) c)))))

  ;; these could be implemented in C, but if there's no need, there's no need
  (define (filter p ls)
    (let ((result (list)))
      (for-each (lambda (n) (when (p n) (set! result (cons n result)))) ls)
      (reverse result)))

  (define (btn n)
    (> (logand KEYS (ash 1 n)) 0))

  (define (btnp n)
    (and (> (logand KEYS (ash 1 n)) 0)
         (= (logand LASTKEYS (ash 1 n)) 0)))

  (define (collideAABB a b)
    (let ((X1 ((a 'x)))
          (W1 ((a 'w)))
          (Y1 ((a 'y)))
          (H1 ((a 'h)))
          (X2 ((b 'x)))
          (W2 ((b 'w)))
          (Y2 ((b 'y)))
          (H2 ((b 'h))))
      (not (or (< (+ X1 W1) X2)
               (< (+ X2 W2) X1)
               (< (+ Y1 H1) Y2)
               (< (+ Y2 H2) Y1)))))

  (define (collide-with-mask a b)
    (let ((X1 ((a 'x)))
          (W1 ((a 'w)))
          (Y1 ((a 'y)))
          (H1 ((a 'h)))
          (X2 ((b 'x)))
          (W2 ((b 'w)))
          (Y2 ((b 'y)))
          (H2 ((b 'h))))
      (not (or (< (+ X1 W1) X2)
               (< (+ X2 W2) X1)
               (< (+ Y1 H1) Y2)
               (< (+ Y2 H2) Y1)))))

  (define (make-sprite filename-or-id x y w h)
    (let ((id #f) (dx 0) (dy 0))
      (set! id (cond ((number? filename-or-id)
                      filename-or-id)
                     ((string? filename-or-id)
                      (define-sprite filename-or-id))
                     (else #f)))
      (lambda (method-name)
        (case method-name
          ('spr! (lambda (value) (set! id value)))
          ('spr  (lambda () id))

          ('x! (lambda (value) (set! x value)))
          ('x  (lambda () x))
          ('y! (lambda (value) (set! y value)))
          ('y  (lambda () y))

          ('w! (lambda (value) (set! w value)))
          ('w  (lambda () w))
          ('h! (lambda (value) (set! h value)))
          ('h  (lambda () h))

          ('dx! (lambda (value) (set! dx value)))
          ('dx  (lambda () dx))
          ('dy! (lambda (value) (set! dy value)))
          ('dy  (lambda () dy))

          ('update (lambda ()
                     (set! x (+ x dx))
                     (set! y (+ y dy))))
          ('draw (lambda ()
                   (when id (spr id x y w h))))))))

  ;; replacements for TIC-80's map concept, mget() and map()
  (define *MAPBYTES*
    (make-vector (list SCREEN-HEIGHT SCREEN-WIDTH) 0))

  (define (mget x y)
    (*MAPBYTES* (floor y) (floor x)))

  (define (mset x y n)
    (set! (*MAPBYTES* (floor y) (floor x)) n))

  (define (blitmap x0 y0 w h sx sy)
    ;; scale is ignored
    (do ((y 0 (+ y 1))) ((= y h))
      (do ((x 0 (+ x 1))) ((= x w))
        (spr (mget x y) (+ x0 (* x 16)) (+ y0 (* y 16)) 16 16))))

  (display "Core library loaded\n"))