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

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

(define keys (make-bitvector 16 #f))

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


;; key control ----
(define (set-key! index)
  (bitvector-set-bit! keys index))

(define (clear-keys!)
  (bitvector-clear-all-bits! keys))

(define (keys->half)
  (let loop ((i 0)
             (acc 0))
    (if (= i (bitvector-length keys))
      acc
      (loop (+ 1 i)
            (+ acc (if (bitvector-bit-set? keys i) (expt 2 i) 0))))))
;; ---- key control


;; memory ----

(define (get-pc)
  (+ (bytevector-u16-ref memory 3 (endianness big))
     (ash (bytevector-u8-ref memory 2) 16)))

(define (set-pc! value)
  (let ((pc value))
    (bytevector-u16-set! memory 2 (ash pc -8)  (endianness big))
    (bytevector-u8-set!  memory 4 (ash pc -16))))

(define (get-addr pos)
  (+ (bytevector-u16-ref memory (+ 1 pos) (endianness big))
     (ash (bytevector-u8-ref memory pos) 16)))

(define (get-initial-pixel)
  (ash (bytevector-u8-ref memory 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 v))

;; ---- memory


;; colors ----

; Only used to set the colormap, use the faster version is below
(define (pixel->color pixel)
  (if (> pixel 216)
    0
    (let* ((b (modulo pixel 6))
           (g (modulo (/ (- pixel (modulo pixel  6))  6) 6))
           (r (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)
  (let* ((initial   (get-initial-pixel))
         (len       (* width height))
         (base      (make-bytevector len))
         (final     (make-bytevector (* 4 len))))
    (bytevector-copy! memory initial base 0 len)
    (let loop ((i 0))
      (bytevector-u32-set! final
                           (* 4 i)
                           (pixel->color-fast (bytevector-u8-ref base i))
                           (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))
    (set-pc! c)))

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

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

(define (main)
  (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) loop!)))
  (sdl-quit))

;; ---- main operation