Piet interpreter

interp.rkt

#lang racket

(require 2htdp/image)
(require (for-syntax syntax/parse))

; #FFC0C0 light red
; #FFFFC0 light yellow
; #C0FFC0 light green
; #C0FFFF light cyan
; #C0C0FF light blue
; #FFC0FF light magenta
; #FF0000 red
; #FFFF00 yellow
; #00FF00 green
; #00FFFF cyan
; #0000FF blue
; #FF00FF magenta
; #C00000 dark red
; #C0C000 dark yellow
; #00C000 dark green
; #00C0C0 dark cyan
; #0000C0 dark blue
; #C000C0 dark magenta
; #FFFFFF white
; #000000 black

(define debugging #f)

;; color
(struct col (hue lightness))

;; colour block
;; with size and it 8 neighborhoods
(define-struct block (color size tl tr rt rb br bl lb lt) #:transparent)

;; all color table
(define color-table
  (make-hash (list
              (cons #xffc0c0 (col 0 0)) (cons #xff0000 (col 0 1)) (cons #xc00000 (col 0 2))
              (cons #xffffc0 (col 1 0)) (cons #xffff00 (col 1 1)) (cons #xc0c000 (col 1 2))
              (cons #xc0ffc0 (col 2 0)) (cons #x00ff00 (col 2 1)) (cons #x00c000 (col 2 2))
              (cons #xc0ffff (col 3 0)) (cons #x00ffff (col 3 1)) (cons #x00c0c0 (col 3 2))
              (cons #xc0c0ff (col 4 0)) (cons #x0000ff (col 4 1)) (cons #x0000c0 (col 4 2))
              (cons #xffc0ff (col 5 0)) (cons #xff00ff (col 5 1)) (cons #xc000c0 (col 5 2)))))

;; helper function: coordinate<->idx
(define (xy->idx x y width height)
  (+ x (* y width)))

(define (idx->xy idx width height)
  (let ([x (modulo idx width)])
    (values x (/ (- idx x) width))))

;; image helper function
;; turn a image into hash table
(define (image->hash img)
  (for/hash ([i (in-range (* (image-width img) (image-height img)))]
             [color (image->color-list img)])
    (values i color)))

(define (hash->image ht width height)
  (color-list->bitmap (for/list ([i (in-range (* width height))])
                        (hash-ref ht i 0))
                      width
                      height))

;; rgba to hexcol->value (2d-hash-ref ht new-x new-y width height (make-c
(define (col->value c)
  (+ (color-blue c)
     (arithmetic-shift (color-green c) 8)
     (arithmetic-shift (color-red c) 16)))
;;  #xffc0c0 to (color 255 192 192 255)

;; give image hash-table x y width height default
;; return the value of pixel at x y
;; return default if x y out of boundary
;; default usually is black
(define (2d-hash-ref ht x y width height default)
  (if (or (< x 0) (< y 0) (>= x width) (>= y height))
      default
      (hash-ref ht (xy->idx x y width height) default)))


;; get the block at x y
;; block contains the info of it's size and surrounding 8 neighborhoods
;; This function looks scared but it just use DFS (depth-first-search) to walk
;; around environment.
(define (get-block ht x y width height)
  (let ([c (col->value (2d-hash-ref ht x y width height (make-color 0 0 0)))]
        ;; it's size
        [sz 0] [visited (make-hash)]
        ;; 8 neighborhoods
        [tlx x] [tly y]
        [trx x] [try y]
        [brx x] [bry y]
        [blx x] [bly y]
        [rtx x] [rty y]
        [rbx x] [rby y]
        [lbx x] [lby y]
        [ltx x] [lty y])
    (begin
      (let loop ([x^ x]
                 [y^ y])
        (begin
          (if (or (< x^ 0) (< y^ 0) (>= x^ width) (>= y^ height))
              #f
              (let ([idx (xy->idx x^ y^ width height)])
                (if (eqv? (hash-ref visited idx #f) #t)
                    #f
                    (and
                     (eqv? c (col->value (2d-hash-ref ht x^ y^ width height #x000000)))
                     (begin
                       (hash-set! visited idx #t)
                       (set! sz (add1 sz))
                       (and (< y^ tly) (set! tlx x^) (set! tly y^))
                       (and (eqv? y^ tly) (< x^ tlx) (set! tlx x^))
                       (and (< y^ try) (set! trx x^) (set! try y^))
                       (and (eqv? y^ try) (> x^ trx) (set! trx x^))

                       (and (> x^ rtx) (set! rtx x^) (set! rty y^))
                       (and (eqv? x^ rtx) (< y^ rty) (set! rty y^))
                       (and (> x^ rbx) (set! rbx x^) (set! rby y^))
                       (and (eqv? x^ rbx) (> y^ rby) (set! rby y^))

                       (and (> y^ bry) (set! brx x^) (set! bry y^))
                       (and (eqv? y^ bry) (> x^ brx) (set! brx x^))
                       (and (> y^ bly) (set! blx x^) (set! bly y^))
                       (and (eqv? y^ bly) (< x^ blx) (set! blx x^))

                       (and (< x^ lbx) (set! lbx x^) (set! lby y^))
                       (and (eqv? x^ lbx) (> y^ lby) (set! lby y^))
                       (and (< x^ ltx) (set! ltx x^) (set! lty y^))
                       (and (eqv? x^ ltx) (< y^ lty) (set! lty y^))

                       (loop (sub1 x^) y^)
                       (loop (add1 x^) y^)
                       (loop x^ (sub1 y^))
                       (loop x^ (add1 y^)))))))))
      (make-block c sz
                  (cons tlx (sub1 tly))
                  (cons trx (sub1 try))
                  (cons (add1 rtx) rty)
                  (cons (add1 rbx) rby)
                  (cons brx (add1 bry))
                  (cons blx (add1 bly))
                  (cons (sub1 lbx) lby)
                  (cons (sub1 ltx) lty)))))

;; choose the block-function by dp cc
;; block-function will take a block and return a new block based on dp cc.
(define (dp+cc->block-func dp cc)
  (match (list (modulo dp 4) (modulo cc 2))
    ['(0 0) block-rt]
    ['(1 0) block-br]
    ['(2 0) block-lb]
    ['(3 0) block-tl]
    ['(0 1) block-rb]
    ['(1 1) block-bl]
    ['(2 1) block-lt]
    ['(3 1) block-tr]))

;; helper function for visualizing color
;; for debug
(define (color->bitmap col)
  (let ([c (make-color
            (color-red col)
            (color-green col)
            (color-blue col))])
    (color-list->bitmap (list c) 1 1)))

;; calculate diff between two hue
(define (hue-sub a b)
  (cond
    [(>= a b) (- a b)]
    [else (+ a (- 6 b))]))

;; calculate diff between two hue
(define (light-sub a b)
  (cond
    [(>= a b) (- a b)]
    [else (+ a (- 3 b))]))

;; change x based on DP
(define (apply-dp-x dp x)
  (match (modulo dp 4)
    ['0 (add1 x)]
    ['1 x]
    ['2 (sub1 x)]
    ['3 x]))

;; change y based on DP
(define (apply-dp-y dp y)
  (match (modulo dp 4)
    ['0 y]
    ['1 (add1 y)]
    ['2 y]
    ['3 (sub1 y)]))

;; helper function: for instruction "roll" to manuipate stack
(define (roll stack num depth)
  (let* ([sub (take stack depth)]
         [m (modulo num depth)]
         [idx (if (< m 0) (+ depth m) m)])
    (append
     (append (drop sub idx)
             (take sub idx))
     (drop stack depth))))

;; get new codal based on x y
(define (get-new-codal ht width height x y)
  (col->value (2d-hash-ref ht x y width height (make-color 0 0 0))))

;; search next codal based on dp & cc
(define (search-next-codal ht width height dp cc curr-block)
  (let* ([new-func (dp+cc->block-func dp cc)]
         [new-xy (new-func curr-block)]
         [new-codal (get-new-codal ht width height (car new-xy) (cdr new-xy))])
    (values new-codal new-xy)))


;; this function take new-codal and codal
;; then calculate the hue difference and light difference to know
;; which instructions to take
;; return (values op stack dp cc)
(define (update-by-instruction new-codal codal curr-block stack dp cc)
  (let
      ([hue-diff (hue-sub (col-hue new-codal) (col-hue codal))]
       [light-diff (light-sub (col-lightness new-codal) (col-lightness codal))])
    (match (list hue-diff light-diff stack)
      [`(0 0 ,_) (values 'no-op stack dp cc)]
      [`(1 0 (,a ,b . ,rest))
       (values '+ (cons (+ b a) rest) dp cc)]
      [`(1 0 ,_)
       (error (format "stack only has ~a elements (2 required) when trying to add" (length stack)))]
      [`(2 0 (,a ,b . ,rest))
       (let ([rem (modulo b a)])
         (values '/ (cons (if (zero? rem) (/ b a) (/ (- b rem) a)) rest) dp cc))]
      [`(2 0 ,_)
       (error (format "stack only has ~a elements (2 required) when trying to multiply" (length stack)))]
      [`(3 0 (,a ,b . ,rest))
       (values '> (cons (if (> b a) 1 0) rest) dp cc)]
      [`(3 0 ,_)
       (error (format "stack only has ~a elements (2 required) when trying to compute greater" (length stack)))]
      [`(4 0 (,a . ,rest))
       (values 'dup (cons a stack) dp cc)]
      [`(4 0 ,_)
       (error (format "stack only has ~a elements (1 required) when trying to duplicate" (length stack)))]
      [`(5 0 ,_)
       (values 'in-char (cons (char->integer (string-ref (format "~a" (read)) 0)) stack) dp cc)]
      [`(0 1 ,_)
       (values 'push (cons (block-size curr-block) stack) dp cc)]
      [`(1 1 (,a ,b . ,rest))
       (values '- (cons (- b a) rest) dp cc)]
      [`(1 1 ,_)
       (error (format "stack only has ~a elements (2 required) when trying to subtract" (length stack)))]
      [`(2 1 (,a ,b . ,rest))
       (values '% (cons (modulo b a) rest) dp cc)]
      [`(2 1 ,_)
       (error (format "stack only has ~a elements (2 required) when trying to mod" (length stack)))]
      [`(3 1 (,a . ,rest))
       (values 'pointer rest (modulo (+ dp a) 4) cc)]
      [`(4 1 (,n ,d . ,rest))
       (when (< d 0)
         (error (format "negative depth not allowed for rolling // (stack: ~a)" stack)))
       (values 'roll (roll rest n d) dp cc)]
      [`(4 1 ,_)
       (error (format "stack only has ~a elements (2 required) when trying to roll" (length stack)))]
      [`(5 1 (,a . ,rest))
       (printf "~a" a)
       (values 'out-num rest dp cc)]
      [`(5 1 ,_)
       (error (format "stack only has ~a elements (1 required) when trying to print num" (length stack)))]
      [`(0 2 (,a . ,rest))
       (values 'pop rest dp cc)]
      [`(0 2 ,_)
       (error (format "stack only has ~a elements (1 required) when trying to pop" (length stack)))]
      [`(1 2 (,a ,b . ,rest))
       (values '* (cons (* b a) rest) dp cc)]
      [`(1 2 ,_)
       (error (format "stack only has ~a elements (2 required) when trying to multiply" (length stack)))]
      [`(2 2 (,a . ,rest))
       (values '! (cons (if (zero? a) 1 0) rest) dp cc)]
      [`(2 2 ,_)
       (error (format "stack only has ~a elements (1 required) when trying to perform not" (length stack)))]
      [`(3 2 (,a . ,rest))
       (values 'switch rest dp (modulo (+ cc a) 2))]
      [`(4 2 ,_)
       (define new-stack (cons
                          (match (read)
                            [`,a #:when (integer? a) a]
                            [`,a (error (format "not an integer: ~a" a))])
                          stack))
       (values 'in-num new-stack dp cc)]
      [`(5 2 (,a . ,rest))
       (printf "~a" (integer->char a))
       (values 'out-char rest dp cc)]
      [`(5 2 ,_)
       (error (format "stack only has ~a elements (1 required) when trying to print char" (length stack)))]
      [`,x (values (string->symbol (format "ignoring command: ~a" x)) stack dp cc)])))

;; the entry of interpreter
(define (run-program prg)
  (let ([ht (image->hash prg)]
        [width (image-width prg)]
        [height (image-height prg)]
        [visited (make-hash)]
        [dp 0]
        [cc 0]
        [stack (list 0)]
        [x 0]
        [y 0]
        ;; for debugging
        [op 'no-op])
    (begin
      (let loop ()
        ;; get the current position idx and it's color value
        (let* ([idx (xy->idx x y width height)]
               [c (col->value (2d-hash-ref ht x y width height (make-color 0 0 0)))])
          (cond
            [(eqv? c #x000000) #f]
            [(hash-ref color-table c #f)
             => (λ (codal)
                  ;; get current block
                  (let ([curr-block (get-block ht x y width height)]
                        [next #f])
                    ;; we use dp and cc to find the next block to enter
                    ;; we will check all 4 directions with 2 possible cc
                    ;; That is why this run 8 time
                    (for ([i (in-range 9)])
                      #:break next
                      (begin
                        (let-values ([(new-codal new-xy) (search-next-codal ht width height dp cc curr-block)])
                          (if (zero? new-codal)
                              ;; update cc on 1, 3, 5 tries
                              ;; update dp on 0, 2, 4, 6 tries
                              (if (even? i)
                                  (set! cc (modulo (add1 cc) 2))
                                  (set! dp (modulo (add1 dp) 4)))
                              (set! next new-xy)))))
                    ;; if we find next codal to enter,
                    ;; next is (next-x, next-y)
                    (and next
                         (begin
                           ;; find codal by (x, y) in next
                           (let ([new-codal (hash-ref color-table (get-new-codal ht width height (car next) (cdr next)) #f)])
                             (and new-codal
                                  ;; get a instruction based on current codal and new-codal
                                  ;; and then update machine state: stack dp cc accordingly.
                                  ;; op is just for debugging
                                  (let-values ([(new-op new-stack new-dp new-cc) (update-by-instruction new-codal codal curr-block stack dp cc)])
                                    (begin
                                      (set! op new-op)
                                      (set! stack new-stack)
                                      (set! dp new-dp)
                                      (set! cc new-cc)))
                                  (when debugging
                                    (begin
                                      (display "[no-sl] ")
                                      (display (scale 30 (color->bitmap (2d-hash-ref ht x y width height (make-color 0 0 0)))))
                                      (display (scale 30 (color->bitmap (2d-hash-ref ht (car next) (cdr next) width height (make-color 0 0 0)))))
                                      (printf " ~a" op)
                                      (printf " [~a ~a] " dp cc)
                                      (display curr-block)
                                      (printf " ~a\n" stack)))
                                  ))
                           ;; update x y
                           (set! x (car next))
                           (set! y (cdr next))
                           (loop)))))]
            ;; sliding
            [else
             (when debugging (displayln (format "Sliding on ~a" c)))
             ;; slide-already includes all slide direction we try before in this position.
             (define slide-already (hash-ref visited idx (set)))
             (let* ([new-x (apply-dp-x dp x)]
                    [new-y (apply-dp-y dp y)]
                    [new-codal (get-new-codal ht width height new-x new-y)])
               (when debugging
                 (printf "[slide] ~a~a ~a (~a ~a) <~a, ~a> -> <~a, ~a>\n"
                         (scale 30 (color->bitmap (2d-hash-ref ht x y width height (make-color 0 0 0))))
                         (scale 30 (color->bitmap (2d-hash-ref ht new-x new-y width height (make-color 0 0 0))))
                         new-codal dp cc x y new-x new-y))
               ;; If we don't slide to this direction before, we slide to that direction.
               ;; For sliding, we update x and y based on dp.
               ;; Then try to find next codal,
               ;; If it is black, then we update dp
               ;; else we find the next codal to enter, and we clean visited table.
               (and
                (not (set-member? slide-already dp))
                (begin
                  (hash-set! visited idx (set-add slide-already dp))
                  (set! x new-x)
                  (set! y new-y)
                  (and (eqv? new-codal #x000000) (set! dp (modulo (add1 dp) 4)))
                  (and (hash-ref color-table new-codal #f) (set! visited (make-hash)))
                  (loop))))]
            )))
      (void))))