OH GOD OH FUCK
This commit is contained in:
parent
d13776b971
commit
7f85232037
|
|
@ -0,0 +1,252 @@
|
||||||
|
#lang racket
|
||||||
|
|
||||||
|
(require racket/async-channel)
|
||||||
|
(require struct-update)
|
||||||
|
|
||||||
|
;; First some helpers
|
||||||
|
|
||||||
|
(define (op-mode opcode idx)
|
||||||
|
(match (modulo (floor (/ opcode (expt 10 (+ idx 2)))) 10)
|
||||||
|
[0 'pos]
|
||||||
|
[1 'imm]
|
||||||
|
[2 'rel]
|
||||||
|
[_ (error "invalid mode")]))
|
||||||
|
|
||||||
|
(define (op-op opcode)
|
||||||
|
(modulo opcode 100))
|
||||||
|
|
||||||
|
(define (tape-expand tape len)
|
||||||
|
(cond [(> len (length tape)) (append tape (for/list ([i (in-range (- len (length tape)))]) 0))]
|
||||||
|
[else tape]))
|
||||||
|
|
||||||
|
(define (tape-ref tape pos)
|
||||||
|
(define new-tape (tape-expand tape (add1 pos)))
|
||||||
|
(list-ref new-tape pos))
|
||||||
|
|
||||||
|
(define (tape-ref/mode tape pos mode)
|
||||||
|
(match mode
|
||||||
|
['pos (tape-ref tape (tape-ref tape pos))]
|
||||||
|
['imm (tape-ref tape pos)]
|
||||||
|
['rel (tape-ref tape (+ (intcode-rel-base) (tape-ref tape pos)))]
|
||||||
|
[_ (error "invalid mode")]))
|
||||||
|
|
||||||
|
(define (tape-set tape where what)
|
||||||
|
(define new-tape (tape-expand tape (add1 where)))
|
||||||
|
(list-set new-tape where what))
|
||||||
|
|
||||||
|
(define (tape-set/mode tape where what mode)
|
||||||
|
(match mode
|
||||||
|
['pos (tape-set tape (tape-ref tape where) what)]
|
||||||
|
['rel (tape-set tape (+ (intcode-rel-base) (tape-ref tape where)) what)]
|
||||||
|
[_ (error "invalid mode")]))
|
||||||
|
|
||||||
|
;; Generic abstracted opcode interpreter function
|
||||||
|
;; Calls handler for opcode-specific handling, which should call callback to continue or return to
|
||||||
|
;; exit.
|
||||||
|
(define (intcode-handle-opcode callback spec handler tape pos)
|
||||||
|
(let* ([opcode (list-ref tape pos)]
|
||||||
|
[args (for/list ([spec-item spec] [idx (in-range (length spec))])
|
||||||
|
(match spec-item
|
||||||
|
['in (tape-ref/mode tape (+ pos idx 1) (op-mode opcode idx))]
|
||||||
|
['out
|
||||||
|
(lambda (what)
|
||||||
|
(tape-set/mode tape (+ pos idx 1) what (op-mode opcode idx)))]))])
|
||||||
|
(apply handler callback tape (+ pos (length spec) 1) args)))
|
||||||
|
|
||||||
|
;; Create a system to register intcode ops
|
||||||
|
(struct intcode-op [code spec handler])
|
||||||
|
(define opcode-table (make-hash))
|
||||||
|
|
||||||
|
;; Evil mutation incoming!!!!
|
||||||
|
(define (intcode-register code spec handler)
|
||||||
|
(hash-set! opcode-table code (intcode-op code spec handler)))
|
||||||
|
|
||||||
|
;; Main eval function
|
||||||
|
(define (intcode-eval tape [pos 0])
|
||||||
|
(let* ([opcode (list-ref tape pos)]
|
||||||
|
[handler-entry (hash-ref opcode-table (op-op opcode))])
|
||||||
|
(intcode-handle-opcode intcode-eval
|
||||||
|
(intcode-op-spec handler-entry)
|
||||||
|
(intcode-op-handler handler-entry)
|
||||||
|
tape pos)))
|
||||||
|
|
||||||
|
;; Now it's time to define all the operations we can do
|
||||||
|
|
||||||
|
;; Binary operations!!!
|
||||||
|
(define spec-binop '(in in out))
|
||||||
|
(define ((intcode-generic-binop op) cb tape pos lhs rhs dst)
|
||||||
|
(cb (dst (op lhs rhs)) pos))
|
||||||
|
|
||||||
|
(intcode-register 1 spec-binop (intcode-generic-binop +))
|
||||||
|
(intcode-register 2 spec-binop (intcode-generic-binop *))
|
||||||
|
(define (bool->number b) (if b 1 0))
|
||||||
|
(intcode-register 7 spec-binop (intcode-generic-binop (compose bool->number <)))
|
||||||
|
(intcode-register 8 spec-binop (intcode-generic-binop (compose bool->number =)))
|
||||||
|
|
||||||
|
;; I/O time
|
||||||
|
(define current-input-channel (make-parameter (make-async-channel)))
|
||||||
|
(define current-output-channel (make-parameter (make-async-channel)))
|
||||||
|
(define instance (make-parameter '()))
|
||||||
|
(define (instance-log what)
|
||||||
|
(if (empty? (instance)) (void) (displayln (format "~a ~a" (instance) what))))
|
||||||
|
(define (intcode-input cb tape pos dst)
|
||||||
|
;(displayln "WANT INPUT")
|
||||||
|
(define inp (if (async-channel? (current-input-channel))
|
||||||
|
(async-channel-get (current-input-channel))
|
||||||
|
(apply (current-input-channel) '())))
|
||||||
|
(instance-log (list "input" inp))
|
||||||
|
(cb (dst inp) pos))
|
||||||
|
(intcode-register 3 '(out) intcode-input)
|
||||||
|
|
||||||
|
(define (intcode-output cb tape pos src)
|
||||||
|
(instance-log (list "output" src))
|
||||||
|
(if (async-channel? (current-output-channel))
|
||||||
|
(async-channel-put (current-output-channel) src)
|
||||||
|
(apply (current-output-channel) (list src)))
|
||||||
|
(cb tape pos))
|
||||||
|
(intcode-register 4 '(in) intcode-output)
|
||||||
|
|
||||||
|
;; Jumps
|
||||||
|
(define ((intcode-generic-jump which) cb tape pos arg dst)
|
||||||
|
(cb tape (if (which arg) dst pos)))
|
||||||
|
(intcode-register 5 '(in in) (intcode-generic-jump (compose not zero?)))
|
||||||
|
(intcode-register 6 '(in in) (intcode-generic-jump zero?))
|
||||||
|
|
||||||
|
;; Relative base
|
||||||
|
(define intcode-rel-base (make-parameter 0))
|
||||||
|
(define (intcode-set-rel-base cb tape pos arg)
|
||||||
|
(define new-base (+ (intcode-rel-base) arg))
|
||||||
|
(instance-log (list "rel base" (intcode-rel-base) "+" arg "=" new-base))
|
||||||
|
(parameterize ([intcode-rel-base new-base])
|
||||||
|
(cb tape pos)))
|
||||||
|
(intcode-register 9 '(in) intcode-set-rel-base)
|
||||||
|
|
||||||
|
;; Exit
|
||||||
|
(define (intcode-exit cb tape pos)
|
||||||
|
(instance-log "exit")
|
||||||
|
(void))
|
||||||
|
(intcode-register 99 '() intcode-exit)
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (parse-input input)
|
||||||
|
(map string->number (string-split (string-trim input) ",")))
|
||||||
|
|
||||||
|
(define input (parse-input (file->string "input.13.txt")))
|
||||||
|
|
||||||
|
(struct pos [x y] #:transparent)
|
||||||
|
(define-struct-updaters pos)
|
||||||
|
|
||||||
|
(define main-thread (current-thread))
|
||||||
|
|
||||||
|
(define (arcade-io [screen (make-immutable-hash)] [score 0])
|
||||||
|
(define next-x (async-channel-get (current-output-channel)))
|
||||||
|
(cond [(equal? 'eof next-x)
|
||||||
|
(begin
|
||||||
|
(thread-send main-thread screen)
|
||||||
|
(thread-send main-thread score))]
|
||||||
|
[else (begin
|
||||||
|
(define next-y (async-channel-get (current-output-channel)))
|
||||||
|
(define next-tile (async-channel-get (current-output-channel)))
|
||||||
|
(define (is-score x y) (and (= x -1) (= y 00)))
|
||||||
|
(define next-screen
|
||||||
|
(if (is-score next-x next-y)
|
||||||
|
screen
|
||||||
|
(hash-set screen (pos next-x next-y) next-tile)))
|
||||||
|
(define next-score
|
||||||
|
(if (is-score next-x next-y)
|
||||||
|
next-tile
|
||||||
|
score))
|
||||||
|
(arcade-io next-screen next-score))]))
|
||||||
|
|
||||||
|
(define io-thread-part1 (thread arcade-io))
|
||||||
|
(intcode-eval input)
|
||||||
|
(async-channel-put (current-output-channel) 'eof)
|
||||||
|
(define part1-screen (thread-receive))
|
||||||
|
(define part1-score (thread-receive))
|
||||||
|
|
||||||
|
;; Part 1
|
||||||
|
(apply + (map (lambda (x) (if (= x 2) 1 0)) (hash-values part1-screen)))
|
||||||
|
|
||||||
|
(if (false? (async-channel-try-get (current-input-channel)))
|
||||||
|
(void) (error "input channel not empty"))
|
||||||
|
(if (false? (async-channel-try-get (current-output-channel)))
|
||||||
|
(void) (error "output channel not empty"))
|
||||||
|
|
||||||
|
;; Part 2
|
||||||
|
(define hacked-input (list-set input 0 2))
|
||||||
|
|
||||||
|
(require 2htdp/image)
|
||||||
|
(require 2htdp/universe)
|
||||||
|
|
||||||
|
(define (render screen)
|
||||||
|
(define min-x (apply min (map pos-x (hash-keys screen))))
|
||||||
|
(define min-y (apply min (map pos-y (hash-keys screen))))
|
||||||
|
(define max-x (apply max (map pos-x (hash-keys screen))))
|
||||||
|
(define max-y (apply max (map pos-y (hash-keys screen))))
|
||||||
|
|
||||||
|
(define pixel-size 16)
|
||||||
|
(define colors '(black white blue red green))
|
||||||
|
|
||||||
|
(define base (empty-scene
|
||||||
|
(* pixel-size (add1 (- max-x min-x)))
|
||||||
|
(* pixel-size (add1 (- max-y min-y))) 'black))
|
||||||
|
|
||||||
|
(define (set-color scene loc color)
|
||||||
|
(define rect (rectangle pixel-size pixel-size 'solid (list-ref colors color)))
|
||||||
|
(define image-x (* pixel-size (- (pos-x loc) min-x)))
|
||||||
|
(define image-y (* pixel-size (- (- max-y min-y) (- (pos-y loc) min-y))))
|
||||||
|
(place-image/align rect image-x image-y 'left 'top scene))
|
||||||
|
|
||||||
|
(frame
|
||||||
|
(for/foldr ([scene (set-color base (pos 0 0) 1)])
|
||||||
|
([loc (hash-keys screen)])
|
||||||
|
(set-color scene loc (hash-ref screen loc)))))
|
||||||
|
|
||||||
|
(struct world [screen] #:transparent)
|
||||||
|
|
||||||
|
(define (is-score x y) (and (= x -1) (= y 0)))
|
||||||
|
|
||||||
|
;; bad bad bad
|
||||||
|
(define global-screen (make-hash))
|
||||||
|
(define global-val-buf '())
|
||||||
|
|
||||||
|
(define (handle-update next-x next-y next-tile)
|
||||||
|
(set! global-val-buf '())
|
||||||
|
(if (is-score next-x next-y)
|
||||||
|
(displayln (list "Score:" next-tile))
|
||||||
|
(hash-set! global-screen (pos next-x next-y) next-tile)))
|
||||||
|
|
||||||
|
(define (update-screen val)
|
||||||
|
(set! global-val-buf (append global-val-buf (list val)))
|
||||||
|
(if (= 3 (length global-val-buf))
|
||||||
|
(handle-update (first global-val-buf) (second global-val-buf) (third global-val-buf))
|
||||||
|
(void)))
|
||||||
|
|
||||||
|
(define (find-in-screen screen val)
|
||||||
|
(ormap (lambda (key) (if (equal? (hash-ref screen key) val) key #f)) (hash-keys screen)))
|
||||||
|
|
||||||
|
(define (bot-decision)
|
||||||
|
(define ball (find-in-screen global-screen 4))
|
||||||
|
(define paddle (find-in-screen global-screen 3))
|
||||||
|
(define ball-x (pos-x ball))
|
||||||
|
(define paddle-x (pos-x paddle))
|
||||||
|
(cond
|
||||||
|
[(< ball-x paddle-x) -1]
|
||||||
|
[(> ball-x paddle-x) 1]
|
||||||
|
[else 0]))
|
||||||
|
|
||||||
|
(define (handle-tick state)
|
||||||
|
(world global-screen))
|
||||||
|
|
||||||
|
(define (handle-draw state)
|
||||||
|
(if (hash-empty? (world-screen state))
|
||||||
|
(empty-scene 800 600 'white)
|
||||||
|
(render (world-screen state))))
|
||||||
|
|
||||||
|
(parameterize ([current-input-channel bot-decision]
|
||||||
|
[current-output-channel update-screen])
|
||||||
|
(define eval-thread (thread (lambda () (intcode-eval hacked-input) (displayln "exit"))))
|
||||||
|
(void (big-bang (world (make-immutable-hash))
|
||||||
|
(to-draw handle-draw)
|
||||||
|
(on-tick handle-tick 1/30))))
|
||||||
Loading…
Reference in New Issue