125 lines
4.6 KiB
Racket
125 lines
4.6 KiB
Racket
#lang curly-fn racket
|
|
|
|
;; utilities for every challenge script
|
|
|
|
(require "aoc-lib.rkt" (prefix-in is: data/integer-set) graph threading syntax/parse/define
|
|
(for-syntax racket/syntax))
|
|
(provide answer aoc-finish dbg memoize define/memoized
|
|
band bor bxor bnot bshl bshr bset? bfield
|
|
string-reverse
|
|
maximum-bipartite-matching/stable
|
|
is:make-empty is:make-xrange is:make-range* is:make-xrange* is:map
|
|
(all-from-out data/integer-set graph syntax/parse/define threading)
|
|
(for-syntax (all-from-out racket/syntax)))
|
|
|
|
;; in-expression debug print, uwu
|
|
(define (dbg x)
|
|
(pretty-write x)
|
|
x)
|
|
|
|
(define band bitwise-and)
|
|
(define bor bitwise-ior)
|
|
(define bxor bitwise-xor)
|
|
(define bnot bitwise-not)
|
|
(define bshl arithmetic-shift)
|
|
(define bshr #{arithmetic-shift %1 (- %2)})
|
|
(define bset? bitwise-bit-set?)
|
|
(define bfield bitwise-bit-field)
|
|
|
|
(define (string-reverse x)
|
|
(list->string (reverse (string->list x))))
|
|
|
|
;; makes a memoization wrapper around a function
|
|
(define (memoize func)
|
|
(define memo (make-hash))
|
|
(lambda args
|
|
(hash-ref! memo args (λ () (apply func args)))))
|
|
|
|
(define-syntax-parse-rule (define/memoized (name:id arg:id ...) body:expr ...+)
|
|
(define name (memoize (λ (arg ...) body ...))))
|
|
|
|
(define-syntax-parse-rule (define/memo (name:id arg:id ...) body:expr ...+)
|
|
(define name (memoize (λ (arg ...) body ...))))
|
|
|
|
;; helper for maximum-bipartite-matching
|
|
;; given an edge list where each first item corresponds to the left set and each second item
|
|
;; corresponds to the right set, return a matching list where the first item is from the left set
|
|
;; and the second item is from the right
|
|
(define (maximum-bipartite-matching/stable edges)
|
|
(when (empty? edges) (error "provided empty edges list"))
|
|
(define left (list->set (map first edges)))
|
|
(define G (undirected-graph edges))
|
|
(define matching (maximum-bipartite-matching G))
|
|
(define num-first-lefts
|
|
(for/sum ([m (in-list matching)] #:when (set-member? left (first m)))
|
|
1))
|
|
;; if the first set contains more elements belonging to lefts than rights, then assume it's in
|
|
;; the right order. otherwise, swap
|
|
(if (> num-first-lefts (- (length matching) num-first-lefts))
|
|
matching
|
|
(map #{list (second %) (first %)} matching)))
|
|
|
|
;; integer set helpers
|
|
|
|
;; makes an empty integer-set, alias for is:make-range with no args
|
|
(define (is:make-empty)
|
|
(is:make-range))
|
|
|
|
;; makes an integer-set from an exclusive range, ie [start, end)
|
|
(define (is:make-xrange start end)
|
|
(is:make-range start (sub1 end)))
|
|
|
|
(define ((is:make-range*-maker is:maker) ranges)
|
|
(for/fold ([iset (is:make-empty)]) ([range (in-list ranges)])
|
|
(is:union iset
|
|
(match range
|
|
[(list start end) (is:maker start end)]
|
|
[(cons start '()) (is:maker start)]
|
|
[(cons start end) (is:maker start end)]
|
|
[start (is:maker start)]))))
|
|
|
|
;; makes an integer set from a list of ranges
|
|
;; the result will be the union of every element in the given list
|
|
;; each element can be
|
|
;; - (list start end) - [start, end]
|
|
;; - (cons start end) - [start, end]
|
|
;; - (list start) - [start, start]
|
|
;; - start - [start, start]
|
|
;; the individual ranges need not be well-formed
|
|
(define is:make-range* (is:make-range*-maker is:make-range))
|
|
;; similar to is:make-range* but each element can be
|
|
;; - (list start end) - [start, end)
|
|
;; - (cons start end) - [start, end)
|
|
(define is:make-xrange* (is:make-range*-maker is:make-xrange))
|
|
|
|
;; applies a mapping function to each individual continuous range in the integer set
|
|
;; returns the union of the resulting ranges
|
|
;; each range is in the integer-set wfs format, ie inclusive [start, end]
|
|
;; the output ranges need not be in well-formed order
|
|
(define (is:map mapper iset)
|
|
(is:make-range* (map mapper (is:integer-set-contents iset))))
|
|
|
|
;; submit a solution to the server if not already submitted
|
|
(define (answer day part answer)
|
|
(printf "answer ~a.~a: ~s\n" day part answer)
|
|
(unless (aoc-complete? day part)
|
|
(printf "submit? [Y/n]: ")
|
|
(match (string-downcase (string-trim (read-line)))
|
|
[(or "" "y" "yes")
|
|
(printf "submitting...\n")
|
|
(define resp
|
|
(aoc-submit-answer (getenv "AOC_YEAR") (~a day) (getenv "AOC_SESSION") (~a part)
|
|
(~a answer)))
|
|
(printf "server responded: ~a\n" resp)]
|
|
[_ (printf "not submitting\n")])))
|
|
|
|
;; submit 25 part 2
|
|
(define (aoc-finish)
|
|
(unless (aoc-complete? 25 1)
|
|
(error "submit 25.1 first"))
|
|
(unless (aoc-complete? 25 2)
|
|
(printf "submitting done for 25.2...\n")
|
|
(define resp
|
|
(aoc-submit-answer (getenv "AOC_YEAR") "25" (getenv "AOC_SESSION") "2" "done"))
|
|
(printf "server responded: ~a\n" resp)))
|