path: root/bytepusher.scm

(define-module (bytepusher)
  #:use-module (ice-9 binary-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (sdl2 events)
  #:use-module (sdl2 image)
  #:use-module (sdl2 rect)
  #:use-module (sdl2 render)
  #:use-module (sdl2 surface)
  #:use-module (sdl2 video)
  #:use-module (sdl2)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-60))

(define width  256)
(define height 256)
(define scale 2)

(define key-ids (make-hash-table 16))
(hashq-set! key-ids 'x 0)
(hashq-set! key-ids '1 1)
(hashq-set! key-ids '2 2)
(hashq-set! key-ids '3 3)
(hashq-set! key-ids 'q 4)
(hashq-set! key-ids 'w 5)
(hashq-set! key-ids 'e 6)
(hashq-set! key-ids 'a 7)
(hashq-set! key-ids 's 8)
(hashq-set! key-ids 'd 9)
(hashq-set! key-ids 'z #xA)
(hashq-set! key-ids 'c #xB)
(hashq-set! key-ids '4 #xC)
(hashq-set! key-ids 'r #xD)
(hashq-set! key-ids 'f #xE)
(hashq-set! key-ids 'v #xF)

(define memory (make-bytevector (* 1024 1024 16)))


;; key control ----
(define (get-keys)
  (+ (ash (get-byte (+ 1 0))  0)
     (ash (get-byte      0)   8)))

(define (set-keys! keys)
  (set-byte! 1 (ash keys 0))
  (set-byte! 0 (ash keys -8)))

(define (press-key! index)
  (set-keys! (copy-bit index (get-keys) #t)))

(define (release-key! index)
  (set-keys! (copy-bit index (get-keys) #f)))
;; ---- key control


;; memory ----

(define (get-pc)
  (get-addr 2))

(define (set-pc! value)
  (set-byte! 4 (ash value 0))
  (set-byte! 3 (ash value -8))
  (set-byte! 2 (ash value -16)))

(define (get-addr pos)
  (+ (ash (get-byte (+ 2 pos))  0)
     (ash (get-byte (+ 1 pos))  8)
     (ash (get-byte      pos)  16)))

(define (get-initial-pixel)
  (ash (get-byte 5) 16))

(define (get-sample)
  (bytevector-u16-ref memory 6 (endianness big)))

(define (get-byte n)
  (bytevector-u8-ref memory n))

(define (set-byte! n v)
  (bytevector-u8-set! memory n (logand v #xFF)))

;; ---- memory


;; colors ----

; Only used to set the colormap, use the faster version is below
(define (pixel->color pixel)
  (if (> pixel 216)
    0
    (let* ((r (modulo pixel 6))
           (g (modulo (/ (- pixel (modulo pixel  6))  6) 6))
           (b (modulo (/ (- pixel (modulo pixel 36)) 36) 6)))
      (+ #xFF (ash (* #x33 (+ (ash r 16) (ash g 8) b)) 8)))))

(define colormap
  (uint-list->bytevector
    (map pixel->color (iota 256))
    (endianness big)
    4))

(define (pixel->color-fast pixel)
  (bytevector-u32-ref colormap (* 4 pixel) (endianness big)))

;; ---- colors


;; debug ----

(define (peek-memory start end)
  (for-each (lambda (i) (display "0x")
              (display (number->string i 16))
              (newline))
            (take (drop (bytevector->u8-list memory) start) (- end start))))

(define (display-state)
  (sdl-init)
  (call-with-window
    (make-window #:title "BytePusher"
                 #:size (list (* scale width) (* scale height)))
    (lambda (w)
      (call-with-renderer
        (make-renderer w)
        (lambda (renderer)
          (set-renderer-scale! renderer scale scale)
          (let ((texture (make-display-texture renderer)))
            (clear-renderer renderer)
            (load-display! texture)
            (render-copy renderer texture)
            (present-renderer renderer)
            (sleep 10))))))
  (sdl-quit))
;; ---- debug


;; rendering ----
(define get-pixels
  ((lambda ()
    (define len   (* width height))
    (define final (make-bytevector (* 4 len)))
    (lambda ()
      (let* ((initial   (get-initial-pixel)))
        (let loop ((i 0))
          (bytevector-u32-set! final
                               (* 4 i)
                               (pixel->color-fast (get-byte (+ i initial)))
                               (endianness big))
          (unless (= i (- len 1)) (loop (+ 1 i))))
        final)))))

(define (make-display-texture renderer)
  (make-texture renderer 'argb8888 'streaming width height))

(define (load-display! texture)
  (update-texture texture
                  (make-rect 0 0 width height)
                  (get-pixels)
                  (* width 4)))
;; ---- rendering


;; main operation ----

(define (load-program! path)
  (call-with-input-file path
    (lambda (p)
      (let ((program (get-bytevector-all p)))
        (bytevector-copy! program 0 memory 0 (bytevector-length program))))))

(define (execute! instruction-addr)
  (let ((a (get-addr (+ 0 instruction-addr)))
        (b (get-addr (+ 3 instruction-addr)))
        (c (get-addr (+ 6 instruction-addr))))
    (set-byte! b (get-byte a))
    c))

(define (loop-frame!)
  (let loop ((count 65536)
             (nextpc (get-pc)))
    (unless (= count 0)
      (loop (- count 1)
            (execute! nextpc)))))

(define (handle-key! action! key)
  (let ((index (hashq-ref key-ids key)))
    (when index (action! index))))

(define (handle-events!)
  (let ((event (poll-event)))
    (cond
      ((keyboard-down-event? event)
       (handle-key! press-key!   (keyboard-event-key event)))
      ((keyboard-up-event? event)
       (handle-key! release-key! (keyboard-event-key event)))
      ((quit-event? event)
       (exit 0)))
    (when event (handle-events!))))

(define (loop! renderer)
  (define texture (make-display-texture renderer))
  (set-renderer-scale! renderer scale scale)
  (let loop ()
    (let ((t0 (sdl-ticks)))
      (handle-events!)
      (loop-frame!)
      (clear-renderer renderer)
      (load-display! texture)
      (render-copy renderer texture)
      (present-renderer renderer)
      (let* ((t1         (sdl-ticks))
             (frame-time 1000/60)
             (max-time   (+ t0 frame-time)))
        (when (> max-time t1)
          (usleep (floor (* 1000 (- max-time t1)))))
        (display (string-append
                   "FPS: "
                   (number->string
                     (exact->inexact (/ 1000 (- (sdl-ticks) t0))))
                   "("
                   (number->string
                     (exact->inexact (/ 1000 (- t1 t0))))
                  ")\n"))))
    (loop)))

(define (main . args)
  (load-program! "tests/palette.bp")
  (sdl-init)
  (call-with-window
    (make-window #:title "BytePusher"
                 #:size (list (* scale width) (* scale height)))
    (lambda (w)
      (call-with-renderer (make-renderer w '(accelerated)) loop!)))
  (sdl-quit))

(main)
;; ---- main operation


;; tests ----
(define (test-pc)
  (for-each
    (lambda (addr)
      (set-pc! addr)
      (when (not (= (get-pc) addr))
        (error "Error in set pc")))
    (iota #x1000000)))
;; ---- tests