master
Matthew Butterick
parent 034abe299f
commit 7e74c93a79

@ -1,41 +1,41 @@
#lang reader "../aoc-lang.rkt" #lang reader "../aoc-lang.rkt"
(require sugar/cache)
(provide (rename-out [#%mb #%module-begin])) (provide (rename-out [#%mb #%module-begin]))
(define current-stars (make-parameter #f)) (define current-stars (make-parameter #f))
(define current-target-len (make-parameter #f))
(define-macro (#%mb (STARS) (NAME . TOKS) ...) (define-macro (#%mb (STARS) (NAME . TOKS) ...)
#`(#%module-begin #`(#%module-begin
(current-stars 'STARS) (current-stars 'STARS)
(define names (list 'NAME ...)) (current-target-len (length '(NAME ...)))
(handle (length names) NAME . TOKS) ...)) (handle NAME . TOKS) ...))
(define (weights= . xs) (apply =* (map wt xs)))
(define (unique-weight x xs)
(= 1 (length (filter values (map (curry weights= x) xs)))))
(define (weights-equal? subsyms) (define (unbalanced-subsym subsyms)
(or (null? subsyms) (findf (curryr unique-weight subsyms) subsyms))
(andmap (λ (ss) (= ((car subsyms) 'wt) (ss 'wt))) (cdr subsyms))))
(define (unique-member ss subsyms) (define (balanced-subsym subsyms)
(= 1 (length (filter (λ (subsym) (= (ss 'wt) (subsym 'wt))) subsyms)))) (findf (negate (curryr unique-weight subsyms)) subsyms))
(define (exceptional-subsym subsyms) (struct prog (sym wt) #:transparent)
(for/first ([ss (in-list subsyms)] #:when (unique-member ss subsyms)) ss))
(define (typical-subsym subsyms) (define/caching (wt sym)
(for/first ([ss (in-list subsyms)] #:unless (unique-member ss subsyms)) ss)) (apply + (map prog-wt (flatten (sym)))))
(define-macro-cases handle (define-macro-cases handle
[(M TARGET-LEN SYM (NUM) -> SUBSYM ...) [(M SYM (NUM) -> . SUBSYMS)
#'(begin (define (SYM [x #f]) #'(begin (define/caching (SYM [target-weight #f])
(match x (define subsyms (list . SUBSYMS))
['wt (+ NUM (SUBSYM 'wt) ...)] (if target-weight
[(? number?) (if (apply weights= subsyms)
(define target-weight x) (displayln (format "~a is bad: needs to be ~a" 'SYM (- NUM (- (wt SYM) target-weight))))
(define subsyms (list SUBSYM ...)) ((unbalanced-subsym subsyms) (wt (balanced-subsym subsyms))))
(if (weights-equal? subsyms) (cons (prog 'SYM NUM) (map app subsyms))))
(displayln (format "~a is bad: needs to be ~a" 'SYM (- NUM (- (SYM 'wt) target-weight)))) (module+ main
(let ([next-target-weight ((typical-subsym subsyms) 'wt)]) (when (= (current-target-len) (length (flatten (SYM))))
((exceptional-subsym subsyms) next-target-weight)))] (if (eq? (current-stars) ') 'SYM (SYM 'find-bad-weight)))))]
[else (cons 'SYM (append (SUBSYM) ...))])) [(M SYM (NUM)) #'(M SYM (NUM) ->)])
(module+ main (when (= TARGET-LEN (length (SYM)))
(case (current-stars)
[() 'SYM]
[else (SYM 0)]))))]
[(M TARGET-LEN SYM (NUM)) #'(M TARGET-LEN SYM (NUM) ->)])

@ -1,6 +1,6 @@
#lang br #lang br
(require syntax/strip-context sugar/list) (require syntax/strip-context sugar)
(provide (all-defined-out) (all-from-out syntax/strip-context sugar/list)) (provide (all-defined-out) (all-from-out syntax/strip-context sugar))
(define ') (define ★★ '★★) (define ') (define ★★ '★★)
@ -15,3 +15,8 @@
(define (dirname path) (define (dirname path)
(define-values (dir name _) (split-path path)) (define-values (dir name _) (split-path path))
dir) dir)
(define (=* . xs)
(or (< (length xs) 2) (apply = xs)))
(define (app x . args) (apply x args))