diff options
| -rw-r--r-- | bytepusher.scm | 188 | ||||
| -rw-r--r-- | manifest.scm | 1 | ||||
| -rw-r--r-- | tests/README.md | 7 | ||||
| -rw-r--r-- | tests/nyan.bp | bin | 0 -> 200298 bytes | |||
| -rw-r--r-- | tests/palette.bp | bin | 0 -> 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 Binary files differnew file mode 100644 index 0000000..b7b4400 --- /dev/null +++ b/tests/nyan.bp diff --git a/tests/palette.bp b/tests/palette.bp Binary files differnew file mode 100644 index 0000000..06f1e03 --- /dev/null +++ b/tests/palette.bp |