Execute SNUSP/Racket

From Rosetta Code
< Execute SNUSP(Redirected from RCSNUSP/Racket)
Execute SNUSP/Racket is an implementation of SNUSP. Other implementations of SNUSP.
Execute SNUSP/Racket is part of RCSNUSP. You may find other members of RCSNUSP at Category:RCSNUSP.

Interpreter for Modular (and, maybe, Bloated) SNUSP.

Looking at the split example, it seems I don't understand one of threads or read!

But have a go and confirm if split works as you'd expect.

I've implemented an "abstract" esoteric machine which encompasses the ability to run a BF, a Funge and SNUSP.

esoteric.rkt

#lang racket
;;;; This file defines all identifiers which are generally useful for
;;;; the kind of machine you'll find on esolangs.org (SNUSP, Funges, BFs)
(provide (struct-out pointer-2d)
         (struct-out machine)
         (struct-out m/c-thread)
         (struct-out m/c-cursor)
         
         machine-instruction
         m/c-cursor-direction-updater
         m/c-thread-update-cursor
         
         debugging? ; suggest require this with a prefix
         memory-out-of-bounds?
         memory-unbounded-longhand
         
         memory-default-value
         oob-reporter
         memory-overflow
         valid-data-value?
         
         instruction-space-padding
         
         get-memory
         set-memory
         update-memory
         
         normalise-instruction-set)

;                                                                        
;                                                                        
;    ;;;;    ;                           ;                               
;   ;    ;   ;                           ;                               
;   ;      ;;;;;   ;;;;  ;   ;   ;;;   ;;;;;  ;   ;   ;;;;   ;;;    ;;;  
;   ;;       ;     ;;  ; ;   ;  ;;  ;    ;    ;   ;   ;;  ; ;;  ;  ;   ; 
;    ;;;;    ;     ;     ;   ;  ;        ;    ;   ;   ;     ;   ;  ;     
;        ;   ;     ;     ;   ;  ;        ;    ;   ;   ;     ;;;;;   ;;;  
;        ;   ;     ;     ;   ;  ;        ;    ;   ;   ;     ;          ; 
;   ;    ;   ;     ;     ;   ;  ;;       ;    ;   ;   ;     ;   ;  ;   ; 
;    ;;;;    ;;;   ;      ;;;;   ;;;;    ;;;   ;;;;   ;      ;;;    ;;;  
;                                                                        
;                                                                        
;                                                                        

(define-struct pointer-2d (r c) #:prefab)

;; state that can be pushed onto a stack
(define-struct m/c-cursor (p2d direction) #:prefab)

;; I stands for "instruction"
;; M stands for "data" (memory)
;; stack - list of m/c-cursor (excluding current cursor)
(define-struct m/c-thread (id M-p2d csr stack) #:prefab)

(define-struct machine (data prog threads) #:prefab)

(define ((m/c-cursor-direction-updater upd-dir) csr)
  (struct-copy m/c-cursor csr
               (direction (upd-dir (m/c-cursor-direction csr)))))

(define (m/c-thread-update-cursor T csr-updater)
  (struct-copy m/c-thread T (csr (csr-updater (m/c-thread-csr T)))))

;                                                                        
;                                                                        
;   ;;;;;                                       ;                        
;   ;    ;                                      ;                        
;   ;    ;  ;;;    ;;;;   ;;;   ;;;;;   ;;;   ;;;;;   ;;;    ;;;;   ;;;  
;   ;    ; ;   ;   ;;  ; ;   ;  ; ; ;  ;;  ;    ;    ;;  ;   ;;  ; ;   ; 
;   ;;;;;      ;   ;         ;  ; ; ;  ;   ;    ;    ;   ;   ;     ;     
;   ;       ;;;;   ;      ;;;;  ; ; ;  ;;;;;    ;    ;;;;;   ;      ;;;  
;   ;      ;   ;   ;     ;   ;  ; ; ;  ;        ;    ;       ;         ; 
;   ;      ;   ;   ;     ;   ;  ; ; ;  ;   ;    ;    ;   ;   ;     ;   ; 
;   ;       ;;;;   ;      ;;;;  ; ; ;   ;;;     ;;;   ;;;    ;      ;;;  
;                                                                        
;                                                                        
;                                                                        
(define debugging? (make-parameter #f))

;;; Memory model:
;;;  memory can be bounded in all directions
;;;  bounds are specified by the following coordinates

;;; generally, min is inclusive and max is exclusive
;;; not really relevant for +/- inf.0, though
(define (memory-unbounded-longhand r c)
  (or (< r -inf.0) (>= r +inf.0) (< c -inf.0) (>= c +inf.0)))

(define memory-out-of-bounds? (make-parameter (lambda (r c) #f)))

;; defauts for memory
(define memory-default-value (make-parameter 0))
(define (oob-reporter caller rc) (error caller "out of bounds: ~s" rc))
(define memory-overflow oob-reporter)

; or throw an error
(define valid-data-value? (make-parameter (thunk* #t)))

;; best bet to ensure this is not an instruction character ... but pretty when used to
;; print the instructions space out (if needed)
(define instruction-space-padding (make-parameter #\space))

;                                            
;                                            
;   ;    ;                                   
;   ;;  ;;                                   
;   ;;  ;;  ;;;   ;;;;;   ;;;    ;;;;  ;   ; 
;   ; ;; ; ;;  ;  ; ; ;  ;   ;   ;;  ; ;   ; 
;   ; ;; ; ;   ;  ; ; ;  ;   ;   ;      ; ;  
;   ; ;; ; ;;;;;  ; ; ;  ;   ;   ;      ; ;  
;   ;    ; ;      ; ; ;  ;   ;   ;      ; ;  
;   ;    ; ;   ;  ; ; ;  ;   ;   ;      ;;   
;   ;    ;  ;;;   ; ; ;   ;;;    ;       ;   
;                                        ;   
;                                       ;    
;                                      ;;    

; INSTRUCTION AND DATA MEMORIES


(define (machine-instruction M r.c)
  (define P (machine-prog M))
  (define r (pointer-2d-r r.c))
  (define c (pointer-2d-c r.c))
  (define row-in-bounds? (< -1 r (length P)))
  (define col-in-bounds? (and row-in-bounds? (< -1 c (length (car P)))))
  (and row-in-bounds? col-in-bounds? (list-ref (list-ref (machine-prog M) r) c)))

(define get-memory
  (case-lambda
    ((D rc)
     (get-memory D (pointer-2d-r rc) (pointer-2d-c rc)))
    ((D r c)
     (if ((memory-out-of-bounds?) r c)
         ((memory-overflow) 'data r c)         
         (hash-ref D (pointer-2d r c) (memory-default-value))))))

(define set-memory
  (case-lambda
    ((D rc v)
     (set-memory D (pointer-2d-r rc) (pointer-2d-c rc) v))
    ((D r c v)
     (if ((memory-out-of-bounds?) r c)
         ((memory-overflow) 'data r c)
         (hash-set D (pointer-2d r c) v)))))

(define update-memory
  (case-lambda
    ((D rc f)
     (update-memory D (pointer-2d-r rc) (pointer-2d-c rc) f))
    ((D r c f)
     (let* ((v (get-memory D r c)) (v* (f v)))
       (when ((valid-data-value?) v*)
         (hash-set D (pointer-2d r c) v*))))))


;                                                                        
;                                                      ;                 
;                                                             ;          
;                                                             ;          
;    ;;;    ;;;;   ;;;           ;;;    ;;;   ; ;;   ;;;    ;;;;;  ;   ; 
;   ;   ;   ;;  ; ;;  ;         ;   ;  ;   ;  ;;  ;    ;      ;    ;   ; 
;   ;       ;     ;             ;          ;  ;   ;    ;      ;     ; ;  
;    ;;;    ;     ;              ;;;    ;;;;  ;   ;    ;      ;     ; ;  
;       ;   ;     ;                 ;  ;   ;  ;   ;    ;      ;     ; ;  
;   ;   ;   ;     ;;            ;   ;  ;   ;  ;   ;    ;      ;     ;;   
;    ;;;    ;      ;;;;          ;;;    ;;;;  ;   ;  ;;;;;    ;;;    ;   
;                                                                    ;   
;                                                                   ;    
;                                                                  ;;    

(define (all-list-lengths=? l) (or (null? l) (apply = (map length l))))
(define rectangular-list?
  (and/c (listof list?) (flat-contract all-list-lengths=?)))

;; returns the maximum width of l and whether it is rectangular (i.e. doesn't need padding)
(define (list-rectangular?/width L)
  (for*/fold
      ((max-l #f) (rectangular? #t))
    ((r (in-list L))
     (l (in-value (length r)))) ;; TODO: RENAME TO `len`
    (cond [(not max-l) (values l rectangular?)]
          [(= l max-l) (values l rectangular?)]
          [else (values (max l max-l) #f)])))

(define ((pad-to-width width padding) r)
  (append r (make-list (- width (length r)) padding)))  
(define (pad-right-list L width padding)
  (map (pad-to-width width padding) L))

;; turns a sequence of seqences of characters (e.g. a list of strings) into a
;; rectangular-list? of characters
(define (normalise-instruction-set I)
  (define I-chars (sequence->list (sequence-map sequence->list I)))
  (define-values (I-max-width I-rectangular?) (list-rectangular?/width I-chars))  
  (if I-rectangular?
      I-chars
      (normalise-instruction-set
       (pad-right-list I-chars I-max-width (instruction-space-padding)))))

;                                     
;                                     
;     ;                    ;          
;     ;                    ;          
;   ;;;;;   ;;;    ;;;   ;;;;;   ;;;  
;     ;    ;;  ;  ;   ;    ;    ;   ; 
;     ;    ;   ;  ;        ;    ;     
;     ;    ;;;;;   ;;;     ;     ;;;  
;     ;    ;          ;    ;        ; 
;     ;    ;   ;  ;   ;    ;    ;   ; 
;     ;;;   ;;;    ;;;     ;;;   ;;;  
;                                     
;                                     
;                                     

[module+ test
  ;;; prepare the unit testing module
  (require rackunit)
  (require rackunit/text-ui)
  
  (define-test-suite ts:rectangular-list?
    (check-pred rectangular-list?
                (normalise-instruction-set
                 '("=========="
                   "=========="
                   "=========="
                   "==========")))
    (check-pred rectangular-list?
                (normalise-instruction-set
                 '("======="
                   "========"
                   "=========="
                   "======")))
    (check-pred rectangular-list?
                (parameterize ((instruction-space-padding #\X))
                  (normalise-instruction-set
                   '("======="
                     "========"
                     "=========="
                     "======")))))
  
  (define-test-suite ts:esoteric-machine
    ts:rectangular-list?)
  (run-tests ts:esoteric-machine)
  ]

SNUSP.rkt

#lang racket
(require "esoteric-machine.rkt")

(define SNUSP-logger (make-logger 'snusp (current-logger)))
(define root-logger (current-logger)) ; in case you need it
(current-logger SNUSP-logger)

;;; Snusp References:
;;;   http://esoteric.voxelperfect.net/files/snusp/doc/snusp-1.0-spec-wd1.pdf

;;; SNUSP language levels
(define snusp-modular? (make-parameter #t))
(define snusp-bloated? (make-parameter #t))

;                                                                 
;                                                                 
;    ;;;;  ;;   ; ;    ;  ;;;;  ;;;;;         ;    ;      ;   ;;; 
;   ;    ; ;;   ; ;    ; ;    ; ;    ;        ;;  ;;     ;   ;   ;
;   ;      ; ;  ; ;    ; ;      ;    ;        ;;  ;;     ;  ;     
;   ;;     ; ;  ; ;    ; ;;     ;    ;        ; ;; ;    ;   ;     
;    ;;;;  ; ;; ; ;    ;  ;;;;  ;;;;;         ; ;; ;    ;   ;     
;        ; ;  ; ; ;    ;      ; ;             ; ;; ;   ;    ;     
;        ; ;  ; ; ;    ;      ; ;             ;    ;   ;    ;     
;   ;    ; ;   ;; ;    ; ;    ; ;             ;    ;  ;      ;   ;
;    ;;;;  ;   ;;  ;;;;   ;;;;  ;             ;    ;  ;       ;;; 
;                                                    ;            
;                                                                 
;                                                      

;; finds the first $, otherwise return 0,0
(define (snusp-start-coordinates I)
  (for*/fold ((r 0) (c 0))
    (((rw rn) (in-parallel I (in-naturals)))
     ((cl cn) (in-parallel rw (in-naturals)))
     #:when (char=? cl #\$))
    #:final #t
    (values rn cn)))

(define (new-snusp-machine I)
  (define instructions (normalise-instruction-set I))
  (define-values (start-r start-c) (snusp-start-coordinates I))
  (define initial-thread
    (make-m/c-thread (gensym 'm/c-thread) (pointer-2d 0 0) (m/c-cursor (pointer-2d start-r start-c) #\>) null))
  (machine (hash) instructions (list initial-thread)))

;; Directions are as per bloated snusp -- no need to map up to : etc...
;;   :
;;  < >
;;   ;
(define directions '(#\> #\; #\< #\:))
(define (LURD d) (case d ((#\<) #\:) ((#\:) #\<) ((#\>) #\;) ((#\;) #\>))) ; \
(define (RULD d) (case d ((#\>) #\:) ((#\:) #\>) ((#\<) #\;) ((#\;) #\<))) ; /

(define (snusp-move-p2d d rc)
  (case d
    ((#\:) (struct-copy pointer-2d rc (r (sub1 (pointer-2d-r rc)))))
    ((#\;) (struct-copy pointer-2d rc (r (add1 (pointer-2d-r rc)))))
    ((#\<) (struct-copy pointer-2d rc (c (sub1 (pointer-2d-c rc)))))
    ((#\>) (struct-copy pointer-2d rc (c (add1 (pointer-2d-c rc)))))
    (else rc)))

(define (snusp-thread-fwd T)
  (match T
    ((m/c-thread _ _ (and csr (m/c-cursor p2d dir)) _)
     (define csr* (struct-copy m/c-cursor csr (p2d (snusp-move-p2d dir p2d))))
     (struct-copy m/c-thread T (csr csr*)))))

(define (snusp-machine-tick M tick-nr)
  (define (ret-fwd t) ;; returns (list T) as a convenience
    (list (snusp-thread-fwd t)))
  (define (ret-NOOP t) (values M (list (snusp-thread-fwd t))))
  
  (log-debug "machine tick #~a" tick-nr)
  
  (define (handle-modular-instruction M T M-p2d I)
    (case I
      ;;; Modular
      [(#\@) ; enter “Push the current direction and IP location on the call-stack”           
       (values
        M
        (ret-fwd
         (struct-copy
          m/c-thread T
          (stack
           (cons
            (m/c-thread-csr T)
            (m/c-thread-stack T))))))]
      
      [(#\#) ; leave “Pop direction and IP location off call-stack and advance IP one step”
       (values
        M
        (match (m/c-thread-stack T)
          ('() null)
          ((cons stack-head stack-tail)
           (ret-fwd (snusp-thread-fwd
                     (struct-copy m/c-thread T
                                  (csr stack-head)
                                  (stack stack-tail)))))))]
      
      [else
       (if (snusp-bloated?) (handle-bloated-instruction M T M-p2d I)
           (ret-NOOP T))]))
  
  (define (handle-bloated-instruction M T M-p2d I)
    (case I
      [(#\: #\;) ; memory up-down (up/down is bloated behaviour)
       (values M (ret-fwd (struct-copy m/c-thread T (M-p2d (snusp-move-p2d I M-p2d)))))]
      
      [(#\%) ; rand
       (define (random-0-to-n n) (random (add1 n)))
       (define new-data (update-memory (machine-data M) M-p2d random-0-to-n))
       (values (struct-copy machine M (data new-data)) (ret-fwd T))]
      
      [(#\&) ; split
       ;; SPLIT moves the instruction pointer of the old thread one step forward,
       ;; so it is possible to distinguish the old thread from the new
       (define new-T (struct-copy m/c-thread T (id (gensym 'm/c-thread))))
       (values M (list (snusp-thread-fwd (snusp-thread-fwd T))
                       (snusp-thread-fwd new-T)))]
      ;; if it didn't happen in bloated, it's not going to happen!
      [else (ret-NOOP T)]))
  
  ;; returns the modified machine and a list of (modified) threads to
  ;; replace T with
  (define (handle-instruction M T M-p2d I)
    (case I
      ;;; Core
      [(#\< #\>) ; memory left/right (up/down is bloated behaviour)
       (values M (ret-fwd (struct-copy m/c-thread T (M-p2d (snusp-move-p2d I M-p2d)))))]
      [(#\+ #\-) ; memory inc/dec
       (define new-data (update-memory (machine-data M) M-p2d (if (char=? I #\+) add1 sub1)))
       (values (struct-copy machine M (data new-data)) (ret-fwd T))]                
      [(#\,) ; memory read I/O
       (define received-int (char->integer (read-char)))
       (define new-data (set-memory (machine-data M) M-p2d received-int))
       (values (struct-copy machine M (data new-data)) (ret-fwd T))]
      [(#\.) ; memory write I/O
       (write-char (integer->char (get-memory (machine-data M) M-p2d)))
       (values M (ret-fwd T))]
      [(#\\) ; LURD
       (values M (ret-fwd (m/c-thread-update-cursor T (m/c-cursor-direction-updater LURD))))]
      [(#\/) ; RULD
       (values M (ret-fwd (m/c-thread-update-cursor T (m/c-cursor-direction-updater RULD))))]
      [(#\!) ; skip
       (values M (ret-fwd (snusp-thread-fwd T)))]
      [(#\?) ; skipz
       (define do-skip? (zero? (get-memory (machine-data M) M-p2d)))
       (values M (ret-fwd (if do-skip? (snusp-thread-fwd T) T)))]      
      [else
       (cond [(snusp-modular?) (handle-modular-instruction M T M-p2d I)]
             [(snusp-bloated?) (handle-bloated-instruction M T M-p2d I)]
             [else (ret-NOOP T)])]))
  
  (define (m/c-thread-turn M T)
    (log-debug "thread-turn for ~a" (m/c-thread-id T))
    
    (define I (machine-instruction M (m/c-cursor-p2d (m/c-thread-csr T))))
    (when (debugging?) (log-debug "I@~a ~a" T I))
    (cond
      [(not I) ; I-p2d is OOB
       (log-debug "thread ~a terminated" (m/c-thread-id T))
       (values M null)]
      [else (handle-instruction M T (m/c-thread-M-p2d T) I)]))
  
  (define-values (ret-M new-T last-run-thread)
    (for/fold
        ((M M) (new-threads null) (last-run-thread #f))
      ((T (machine-threads M)))
      (define-values (M* T*) (m/c-thread-turn M T))
      (values M* (append new-threads T*) T)))
  
  (values (struct-copy machine ret-M (threads new-T))
          last-run-thread))

(define (execute-snusp-machine M tick-nr remaining-ticks (last-run-thread #f))
  (define-values (new-m/c last-run-thread) (snusp-machine-tick M tick-nr))
  (match* (new-m/c last-run-thread remaining-ticks)
    [((machine _    _ '()) #f _) (memory-default-value)]           
    [(_ #f 0) (memory-default-value)]           
    [((machine data _ _) (m/c-thread _ M-p2d _ _) 0) (get-memory data M-p2d)]           
    [((machine data _ '()) (m/c-thread _ M-p2d _ _) _) (get-memory data M-p2d)]           
    [(_ _ _) (execute-snusp-machine new-m/c (add1 tick-nr) (sub1 remaining-ticks))]))

(define (execute/new-snusp-machine source #:remaining-ticks (remaining-ticks +inf.0))
  (execute-snusp-machine
   (new-snusp-machine (regexp-split #rx"\n" source))
   0 remaining-ticks))

;; good for tests and demonstrations
(define (snusp-io-string I #:in-string (in-string ""))
  (with-output-to-string
   (λ () (with-input-from-string
          in-string
          (λ () (execute/new-snusp-machine I))))))

(define (snusp-val-string I #:in-string (in-string ""))
  (parameterize ((current-output-port (open-output-string))
                 (current-input-port (open-input-string in-string))) ; string is a sink
   (execute/new-snusp-machine I)))

;                                     
;                                     
;     ;                    ;          
;     ;                    ;          
;   ;;;;;   ;;;    ;;;   ;;;;;   ;;;  
;     ;    ;;  ;  ;   ;    ;    ;   ; 
;     ;    ;   ;  ;        ;    ;     
;     ;    ;;;;;   ;;;     ;     ;;;  
;     ;    ;          ;    ;        ; 
;     ;    ;   ;  ;   ;    ;    ;   ; 
;     ;;;   ;;;    ;;;     ;;;   ;;;  
;                                     
;                                     
;                                     

[module+ test
  ;;; prepare the unit testing module
  (require rackunit)
  (require rackunit/text-ui)
  
  (define-simple-check (check-start-coordinates r c L)
    (let-values (((start-r start-c) (snusp-start-coordinates L)))
      (check-equal? (list r c) (list start-r start-c))))
  
  (define-test-suite ts:snusp-start-coordinates
    (check-start-coordinates 0 0 '((#\. #\. #\.)
                                   (#\. #\. #\.)
                                   (#\. #\. #\.)))
    
    (check-start-coordinates 1 1 '((#\. #\. #\.)
                                   (#\. #\$ #\.)
                                   (#\. #\. #\.)))
    
    (check-start-coordinates 2 2 '((#\. #\. #\.)
                                   (#\. #\. #\.)
                                   (#\. #\. #\$)))
    (check-start-coordinates 1 1 '((#\. #\. #\.)
                                   (#\. #\$ #\.)
                                   (#\. #\. #\$))))
  
  (define-test-suite ts:degenerate-m/c
    (check-not-exn (λ () (call-with-values (λ () (execute-snusp-machine (new-snusp-machine '()) 0 +inf.0))
                                           list))
                   "null machine works")
    
    (check-not-exn (λ () (call-with-values (λ () (execute/new-snusp-machine ""))
                                           list)) "empty machine works"))
  
  (check-equal? "x" (snusp-io-string ",." #:in-string "x"))
  
  ;; programs that create 48 will print a #\0
  (define prog-48/1 #<<EOS
++++++++++ ++++++++++ ++++++++++ ++++++++++ ++++++++ .
EOS
    )
  (define prog-48/2 #<<EOS
?#?.++++++++++++++++++++++++=!\\
                              \/
EOS
    )
  
  (define prog-48/6 #<<EOS
=@\.
  \=@@@+@+++++#
EOS
    )
  (define prog-print #<<EOS
$++++++++++++\
/============/
|        /recurse\    #/?\ zero
\=print=!\@\>?!\@/<@\.!\-/
           |   \=/  \=itoa=@@@+@+++++#
           !     /+ !/+ !/+ !/+   \    mod10
           /<+> -\!?-\!?-\!?-\!?-\!
           \?!\-?!\-?!\-?!\-?!\-?/\    div10
              #  +/! +/! +/! +/! +/
EOS
    )
  
  (define prog-hw/1 #<<EOS
      /@@@@++++#               #+++@@\                #-----@@@\n
$@\H.@/e.+++++++l.l.+++o.>>++++.< .<@/w.@\o.+++r.++@\l.@\d.>+.@/.#
  \@@@@=>++++>+++++<<@+++++#       #---@@/!=========/!==/
EOS
    )
  (define prog-hw/2 #<<EOS
  H e l l o ,   w o r l d !
$@\@\@\@\@\@\@\@\@\@\@\@\@\#
  | | | | | | | | | | | | |
  |!|!|!|!|!|!|!|!|!|!|!|!|@@@+@-@@@+++# 128
  @ @ @ @ @ | | @ @ @ @ @ |
  \!\!\!\!\!|!|!\!\!\!\!\!|-@@+@@@@+++# 64
  | @ @ @ @ @ @ @ @ @ @ @ @
  |!\!\!\!\!\!\!\!\!\!\!\!\@@@-@++++# 32
  | | | | | | | @ | @ | | |
  |!|!|!|!|!|!|!\!|!\!|!|!|+@+@++++# 16
  @ | @ @ @ @ | | @ | @ | |
  \!|!\!\!\!\!|!|!\!|!\!|!|@@+++# 8
  | @ @ @ @ @ | @ @ | @ @ |
  |!\!\!\!\!\!|!\!\!|!\!\!|++++# 4
  | | | | @ | | @ @ @ | | |
  |!|!|!|!\!|!|!\!\!\!|!|!|++# 2
  | @ | | @ | | @ @ | | | @
  |!\!|!|!\!|!|!\!\!|!|!|!\+# 1
  | | | | | | | | | | | | |
  \!\!\!\!\!\!\!\!\!\!\!\!\.># print and move
EOS
    )
  
  ;; Two e.gs from:
  
  ;; esolangs.org/SNUSP this is "modular":
  
  ;; “This example from the SNUSP spec shows how to use the
  ;;  call-stack to define an ECHO subroutine and call it twice:”
  (define prog-echo/modular
    #<<EOS
       /==!/======ECHO==,==.==#
       |   |
$==>==@/==@/==<==#
EOS
    )
  
  (define-test-suite ts:48-adders
    (check-eq? (char->integer #\0) 48)     
    (check-equal? (snusp-io-string prog-48/1) "0")    
    (check-equal? (snusp-val-string prog-48/1) 48)    
    (check-equal? (snusp-io-string prog-48/2) "0")
    (check-equal? (snusp-io-string prog-48/6) "0"))
  
  (define-test-suite ts:print
    (check-equal? (snusp-io-string prog-print) "12"))
  
  (define-test-suite ts:hello-world
    (check-equal? (snusp-io-string prog-hw/1) "Hello, world!\n")    
    (check-equal? (snusp-io-string prog-hw/2) "Hello, world!"))
  
  (define-test-suite ts:echo
    (check-equal? (snusp-io-string prog-echo/modular #:in-string "ab") "ab"))
  
  ;; This is bloated (but deterministic!):
  ;; “The following example uses two threads to print ! until a key is pressed:”
  ;;
  ;; We're not going to test this, since the description suggest an asynchronous
  ;; approach to reading a character... which (read-char) can't really test so
  ;; well.
  (define prog-exclaimer/bloated
    #<<EOS
                    /==.==<==\
                    |        |
     /+++++++++++==&\==>===?!/==<<==#
     \+++++++++++\  |
$==>==+++++++++++/  \==>==,==#
EOS
    )
  
  (define-test-suite ts:all
    ts:snusp-start-coordinates
    ts:degenerate-m/c
    ts:48-adders
    ts:hello-world
    ts:print
    ts:echo)
  (run-tests ts:all)  
  ]