summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--bytepusher.scm188
-rw-r--r--manifest.scm1
-rw-r--r--tests/README.md7
-rw-r--r--tests/nyan.bpbin0 -> 200298 bytes
-rw-r--r--tests/palette.bpbin0 -> 131072 bytes
5 files changed, 196 insertions, 0 deletions
diff --git a/bytepusher.scm b/bytepusher.scm
new file mode 100644
index 0000000..19cdeae
--- /dev/null
+++ b/bytepusher.scm
@@ -0,0 +1,188 @@
+(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 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 (get-pixels)
+ (let* ((initial (get-initial-pixel))
+ (len (* width height))
+ (base (make-bytevector len)))
+ (bytevector-copy! memory initial base 0 len)
+ (uint-list->bytevector
+ (map pixel->color-fast (bytevector->u8-list base))
+ (endianness big)
+ 4)))
+
+(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 (* 4 width) (* 4 height)))
+ (lambda (w)
+ (call-with-renderer
+ (make-renderer w)
+ (lambda (renderer)
+ (set-renderer-scale! renderer 4 4)
+ (clear-renderer renderer)
+ (render-copy renderer
+ (surface->texture
+ renderer
+ (bytevector->surface (get-pixels)
+ width
+ height
+ 32
+ (* width 4))))
+
+ (present-renderer renderer)
+ (sleep 10)))))
+ (sdl-quit))
+;; ---- debug
+
+
+;; 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)
+ (set-renderer-scale! renderer 4 4)
+ (let loop ()
+ (let ((t0 (sdl-ticks)))
+ (loop-frame!)
+ (clear-renderer renderer)
+ ;; TODO: Too many copies, improve upstream in Guile-SDL2
+ (render-copy renderer
+ (surface->texture
+ renderer
+ (bytevector->surface (get-pixels)
+ width
+ height
+ 32
+ (* width 4))))
+ (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 (* 4 width) (* 4 height)))
+ (lambda (w)
+ (call-with-renderer (make-renderer w) loop!)))
+ (sdl-quit))
+
+;; ---- main operation
diff --git a/manifest.scm b/manifest.scm
new file mode 100644
index 0000000..54d99a5
--- /dev/null
+++ b/manifest.scm
@@ -0,0 +1 @@
+(specification->manifest (list "guile" "guile-sdl2"))
diff --git a/tests/README.md b/tests/README.md
new file mode 100644
index 0000000..a729c09
--- /dev/null
+++ b/tests/README.md
@@ -0,0 +1,7 @@
+These tests are not written by myself. They are obtained from:
+
+https://esolangs.org/wiki/BytePusher
+
+I do not hold any copyright on them, and I don't know their license, but I'll
+keep them still, as they are found freely in the internet, shared by the
+author.
diff --git a/tests/nyan.bp b/tests/nyan.bp
new file mode 100644
index 0000000..b7b4400
--- /dev/null
+++ b/tests/nyan.bp
Binary files differ
diff --git a/tests/palette.bp b/tests/palette.bp
new file mode 100644
index 0000000..06f1e03
--- /dev/null
+++ b/tests/palette.bp
Binary files differ