#lang racket

(struct mem
        (regs pc sp flags bank))

(define (make-mem [start #x00] [bs '()])
  (set-bytes start bs
             (mem (make-regs)
                  start
                  0
                  0
                  (make-bank))))

(define (make-regs)
  (make-vector 8 0))

(define (get-zero mem)
  (bitwise-bit-set? (mem-flags mem) 7))

(define (get-carry mem)
  (bitwise-bit-set? (mem-flags mem) 4))

(define (get-reg x mem)
  (if (and (< x 8) (>= x 0))
    (let ([regs (mem-regs mem)])
      (if (not (= x 6))
        (vector-ref regs x)
        (let([bank (mem-bank mem)]
             [h (vector-ref regs 4)]
             [l (vector-ref regs 5)])
          (vector-ref bank (make-16b-addr h l)))))
    (error "unknown register index")))

(define (set-reg x val m)
  (if (and (< x 8) (>= x 0))
    (let ([regs (mem-regs m)])
      (if (not (= x 6))
        (let ([newregs (vector-copy regs)])
          (vector-set! newregs x (mod-8bit val))
          (struct-copy mem m [regs newregs]))
        (let ([newbank (vector-copy (mem-bank m))]
              [h (vector-ref regs 4)]
              [l (vector-ref regs 5)])
          (vector-set! newbank (make-16b-addr h l) (mod-8bit val))
          (struct-copy mem m [bank newbank]))))
    (error "unknown register index")))

(define (make-bank [def #x00])
  (make-vector 65536 def))

(define (mod-8bit val)
  (modulo val 256))

(define (mod-16bit val)
  (modulo val 65536))

(define (set-pc addr m)
  (begin
    (struct-copy mem m [pc (mod-16bit addr)])))

(define (set-flags f m)
  (begin
    (struct-copy mem m [flags (mod-8bit f)])))

(define (get-byte addr m)
  (let ([b (mem-bank m)])
    (if (and (>= addr 0)
             (< addr (vector-length b)))
      (vector-ref b addr)
      (error (format "address ~a out of bounds" addr)))))

(define (set-byte addr val m)
  (let ([b (mem-bank m)])
    (if (and (>= addr 0)
             (< addr (vector-length b)))
      (let ([newbank (vector-copy b)])
        (vector-set! newbank addr (mod-8bit val))
        (struct-copy mem m [bank newbank]))
      (error (format "address ~a out of bounds" addr)))))

(define (set-bytes addr bs m)
  (if (null? bs)
    m
    (set-bytes (mod-16bit (add1 addr))
               (cdr bs)
               (set-byte addr (car bs) m))))

(define (get-x byte)
  (arithmetic-shift (bitwise-and #b11000000 byte) -6))

(define (get-y byte)
  (arithmetic-shift (bitwise-and #b00111000 byte) -3))

(define (get-z byte)
  (bitwise-and #b00000111 byte))

(define (inc-sp m)
  (struct-copy mem m [sp (add1 (mem-sp m))]))

(define (inc-pc m)
  (struct-copy mem m [pc (add1 (mem-pc m))]))

(define (make-16b-addr x y)
  (bitwise-ior y (arithmetic-shift x 8)))

(define (make-8b-ld-reg-imm y m)
  (letrec ([pc (mem-pc m)]
           [x (get-byte pc m)])
    (cons (8b-ld-reg-imm y x)
          (set-pc (add1pc pc) m))))

(define (make-jp cc m)
  (letrec ([pc (mem-pc m)]
           [y (get-byte pc m)]
           [npc (add1pc pc)]
           [x (get-byte npc m)]
           [addr (make-16b-addr x y)]
           [cs (cc-tab cc)])
    (cons (jp cs addr) (set-pc (add1pc npc) m))))

(define (cc-tab cc)
  (case cc
    [(0) 'NZ]
    [(1) 'Z]
    [(2) 'NC]
    [(3) 'C]
    [else 'uncond]))

(define (make-8b-ld-reg-reg y z m)
  (cons (8b-ld-reg-reg y z)
        m))

(define (make-alu-imm z m)
  (letrec ([pc (mem-pc m)]
           [x (get-byte pc m)])
    (cons (case z
            [(0) (8b-add-imm x)]
            [(1) (8b-adc-imm x)]
            [(2) (8b-sub-imm x)]
            [(3) (8b-sbc-imm x)]
            [(4) (8b-and-imm x)]
            [(5) (8b-xor-imm x)]
            [(6) (8b-or-imm x)]
            [(7) (8b-cp-imm x)]
            [else (nop)])
          (inc-pc m))))

(define (make-8b-inc-dec-reg y z m)
  (cons ((case z
           [(4) 8b-inc-reg]
           [(5) 8b-dec-reg]) y)
        m))

(define (make-alu-reg y z m)
  (cons (case y
          [(0) (8b-add-reg z)]
          [(1) (8b-adc-reg z)]
          [(2) (8b-sub-reg z)]
          [(3) (8b-sbc-reg z)]
          [(4) (8b-and-reg z)]
          [(5) (8b-xor-reg z)]
          [(6) (8b-or-reg z)]
          [(7) (8b-cp-reg z)])
        m))

(define (make-nop m)
  (cons (nop) m))

(define (make-stop m)
   (cons 'STOP m))

(define (jp cc addr)
   (case cc
      [(uncond) (jp-uncond addr)]
      [else (jp-cond cc addr)]))

(define (8b-ld-reg-imm reg imm)
   (lambda (m)
      (set-reg reg imm m)))

(define (8b-ld-reg-reg dst src)
   (lambda (m)
      (set-reg dst
               (get-reg src m)
               m)))

(define (8b-inc-reg r)
   (lambda (m)
      (let ([a (mod-8bit (add1 (get-reg r m)))])
        (set-flags
          (bitwise-ior (if (= a 0) #b10000000 #x00)
                       (if (>= a 16) #b00100000 #x00))
          (set-reg r a m)))))

(define (8b-dec-reg r)
   (lambda (m)
      (let ([a (mod-8bit (sub1 (get-reg r m)))])
        (set-flags
          (bitwise-ior (if (= a 0) #b10000000 #x00)
                       (if (>= a 16) #b00100000 #x00)
                       #b01000000)
          (set-reg r a m)))))

(define (jp-cond cc addr)
   (lambda (m)
      (let ([c (get-carry m)]
            [z (get-zero m)])
         (if (case cc
               [(NZ) (not z)]
               [(Z)  z]
               [(NC) (not c)]
               [(C)  c])
             (set-pc addr m)
             m))))

(define (jp-uncond addr)
   (lambda (m)
      (set-pc addr m)))

(define (8b-add-imm v)
   (lambda (m)
      (let ([a (+ (get-reg 7 m)
                  (mod-8bit v))])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-sbc-imm v)
   (lambda (m)
      (letrec ([c (bitwise-and #b00010000 (mem-flags m))]
               [a (- (get-reg 7 m)
                     (mod-8bit v)
                     c)])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-sub-imm v)
   (lambda (m)
      (let ([a (- (get-reg 7 m)
                  (mod-8bit v))])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-cp-imm v)
   (lambda (m)
      (let ([a (- (get-reg 7 m)
                  (mod-8bit v))])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
                    m))))

(define (8b-adc-imm v)
   (lambda (m)
      (letrec ([c (bitwise-and #b00010000 (mem-flags m))]
               [a (+ (get-reg 7 m)
                     (mod-8bit v)
                     c)])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-add-reg r)
   (lambda (m)
      (let ([a (+ (get-reg 7 m)
                  (get-reg r m))])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-sbc-reg r)
   (lambda (m)
      (letrec ([c (bitwise-and #b00010000 (mem-flags m))]
               [a (- (get-reg 7 m)
                     (get-reg r m)
                     c)])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-sub-reg r)
   (lambda (m)
      (let ([a (- (get-reg 7 m)
                  (get-reg r m))])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-cp-reg r)
   (lambda (m)
      (let ([a (- (get-reg 7 m)
                  (get-reg r m))])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
                    m))))

(define (8b-adc-reg r)
   (lambda (m)
      (letrec ([c (bitwise-and #b00010000 (mem-flags m))]
               [a (+ (get-reg 7 m)
                     (get-reg r m)
                     c)])
         (set-flags (bitwise-ior (if (= a 0) #b10000000 #x00)
                                 (if (>= a 16) #b00100000 #x00) 
                                 (if (>= a 256) #b00010000 #x00))
            (set-reg 7 (mod-8bit a) m)))))

(define (8b-xor-reg r)
   (lambda (m)
      (let ([a (bitwise-xor (get-reg 7 m)
                            (get-reg r m))])
         (set-flags (if (= a 0) #b10000000 #x00)
            (set-reg 7 a m)))))

(define (8b-and-reg r)
   (lambda (m)
      (let ([a (bitwise-and (get-reg 7 m)
                            (get-reg r m))])
         (set-flags (if (= a 0) #b10000000 #x00)
            (set-reg 7 a m)))))

(define (8b-or-reg r)
   (lambda (m)
      (let ([a (bitwise-ior (get-reg 7 m)
                            (get-reg r m))])
         (set-flags (if (= a 0) #b10000000 #x00)
            (set-reg 7 a m)))))

(define (8b-xor-imm imm)
   (lambda (m)
      (let ([a (bitwise-xor (get-reg 7 m)
                            (mod-8bit imm))])
         (set-flags (if (= a 0) #b10000000 #x00)
            (set-reg 7 a m)))))

(define (8b-or-imm imm)
   (lambda (m)
      (let ([a (bitwise-ior (get-reg 7 m)
                            (mod-8bit imm))])
         (set-flags (if (= a 0) #b10000000 #x00)
            (set-reg 7 a m)))))

(define (8b-and-imm imm)
   (lambda (m)
      (let ([a (bitwise-and (get-reg 7 m)
                            (mod-8bit imm))])
         (set-flags (if (= a 0) #b10000000 #x00)
            (set-reg 7 a m)))))

(define (nop)
   (lambda (m) m))

(define (display-byte-hex v)
  (~a #:align 'right #:left-pad-string "0" #:width 2
      (format "~x" v)))

(define (display-word-hex v)
  (~a #:align 'right #:left-pad-string "0" #:width 4
      (format "~x" v)))

(define (display-bin v)
  (~a #:left-pad-string "0" #:width 8 #:align 'right
      (format "~b" v)))

(define (print-regs m)
   (letrec ([regs (mem-regs m)]
            [F (display-byte-hex (mem-flags m))]
            [B (display-byte-hex (vector-ref regs 0))]
            [C (display-byte-hex (vector-ref regs 1))] 
            [D (display-byte-hex (vector-ref regs 2))] 
            [E (display-byte-hex (vector-ref regs 3))] 
            [h (vector-ref regs 4)] 
            [l (vector-ref regs 5)] 
            [H (display-byte-hex (vector-ref regs 4))] 
            [L (display-byte-hex (vector-ref regs 5))] 
            [HL-ind (display-byte-hex (get-byte (make-16b-addr h l) m))] 
            [A (display-byte-hex (vector-ref regs 7))])
       (displayln (format "BC: $~a~a, DE: $~a~a" B C D E))
       (displayln (format "HL: $~a~a, AF: $~a~a" H L A F))
       (displayln (format "(HL): $~a" HL-ind))
       (void)))

(define (print-state m)
   (displayln (format "PC: $~a, SP: $~a, Flags: %~a"
                      (display-word-hex (mem-pc m))
                      (display-word-hex (mem-sp m))
                      (display-bin (mem-flags m)))))

(define (print-part-bank start count m)
   (define (print-mem v)
      (display (format " $~a" (display-byte-hex v))))
   (let ([s (display-word-hex start)]
         [e (display-word-hex (mod-16bit (+ start (sub1 count))))])
      (display (format "$~a >" s))
      (let ([splice (vector-take
                       (vector-drop (mem-bank m) start)
                       count)])
         (vector-map print-mem splice))
      (display (format " < $~a\n" e) ))
      (void))

(define (add1pc pc)
   (mod-16bit (add1 pc)))

(define (within x y z)
   (and (>= x y) (<= x z)))

(define (decode-op m)
   (letrec ([pc (mem-pc m)]
            [op (get-byte pc m)]
            [npc (add1pc pc)]
            [x (get-x op)]
            [y (get-y op)]
            [z (get-z op)])
      (cond
         [(= #x00 op) (make-nop (set-pc npc m))]
         [(= #x10 op) (make-stop (set-pc npc m))]
         [(= #xC3 op) (make-jp 'uncond (set-pc npc m))]
         [(and (= 0 x) (within z 4 5))
            (make-8b-inc-dec-reg y z (set-pc npc m))]
         [(= 1 x)
            (make-8b-ld-reg-reg y z (set-pc npc m))]
         [(= 2 x)
            (make-alu-reg y z (set-pc npc m))]
         [(and (= 3 x) (= z 2) (within y 0 3))
            (make-jp y (set-pc npc m))]
         [(and (= 3 x) (= z 6))
            (make-alu-imm y (set-pc npc m))]
         [(and (= 0 x) (= 6 z))
            (make-8b-ld-reg-imm y (set-pc npc m))]
         [else (make-nop (set-pc npc m))])))

(define (test-vm start bank-start bank-count bs)
   (let ([m (make-mem start bs)])
      (define (fin m)
         (begin (print-state m)
                (print-regs m)
                (print-part-bank bank-start bank-count m)))
      (define (run-op m)
         (displayln (format "executing: $~a @ $~a"
                            (display-byte-hex (get-byte (mem-pc m) m))
                            (display-word-hex (mem-pc m))))
         (letrec ([op-pc (decode-op m)]
                  [op (car op-pc)]
                  [newmem (cdr op-pc)])
            (if (and (not (procedure? op))
                     (eq? op 'STOP))
                (fin newmem)
                (begin
                  ;(print-state newmem)
                  ;(print-regs newmem)
                  (run-op (op newmem))))))
      (run-op m)))

(define (run-vm start bank-start bank-count bs)
   (let ([m (make-mem start bs)])
      (define (fin m)
         (begin (print-state m)
                (print-regs m)
                (print-part-bank bank-start bank-count m)))
      (define (run-op m)
         (letrec ([op-pc (decode-op m)]
                  [op (car op-pc)]
                  [newmem (cdr op-pc)])
            (if (and (not (procedure? op))
                     (eq? op 'STOP))
                (fin newmem)
                (run-op (op newmem)))))
      (run-op m)))

(provide (all-defined-out))