diff --git a/2017/d7/main.rkt b/2017/d7/main.rkt index 77a9bee..b9ed30b 100644 --- a/2017/d7/main.rkt +++ b/2017/d7/main.rkt @@ -1,41 +1,41 @@ #lang reader "../aoc-lang.rkt" -(require sugar/cache) (provide (rename-out [#%mb #%module-begin])) + (define current-stars (make-parameter #f)) +(define current-target-len (make-parameter #f)) + (define-macro (#%mb (STARS) (NAME . TOKS) ...) #`(#%module-begin (current-stars 'STARS) - (define names (list 'NAME ...)) - (handle (length names) NAME . TOKS) ...)) + (current-target-len (length '(NAME ...))) + (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) - (or (null? subsyms) - (andmap (λ (ss) (= ((car subsyms) 'wt) (ss 'wt))) (cdr subsyms)))) +(define (unbalanced-subsym subsyms) + (findf (curryr unique-weight subsyms) subsyms)) -(define (unique-member ss subsyms) - (= 1 (length (filter (λ (subsym) (= (ss 'wt) (subsym 'wt))) subsyms)))) +(define (balanced-subsym subsyms) + (findf (negate (curryr unique-weight subsyms)) subsyms)) -(define (exceptional-subsym subsyms) - (for/first ([ss (in-list subsyms)] #:when (unique-member ss subsyms)) ss)) +(struct prog (sym wt) #:transparent) -(define (typical-subsym subsyms) - (for/first ([ss (in-list subsyms)] #:unless (unique-member ss subsyms)) ss)) +(define/caching (wt sym) + (apply + (map prog-wt (flatten (sym))))) (define-macro-cases handle - [(M TARGET-LEN SYM (NUM) -> SUBSYM ...) - #'(begin (define (SYM [x #f]) - (match x - ['wt (+ NUM (SUBSYM 'wt) ...)] - [(? number?) - (define target-weight x) - (define subsyms (list SUBSYM ...)) - (if (weights-equal? subsyms) - (displayln (format "~a is bad: needs to be ~a" 'SYM (- NUM (- (SYM 'wt) target-weight)))) - (let ([next-target-weight ((typical-subsym subsyms) 'wt)]) - ((exceptional-subsym subsyms) next-target-weight)))] - [else (cons 'SYM (append (SUBSYM) ...))])) - (module+ main (when (= TARGET-LEN (length (SYM))) - (case (current-stars) - [(★) 'SYM] - [else (SYM 0)]))))] - [(M TARGET-LEN SYM (NUM)) #'(M TARGET-LEN SYM (NUM) ->)]) \ No newline at end of file + [(M SYM (NUM) -> . SUBSYMS) + #'(begin (define/caching (SYM [target-weight #f]) + (define subsyms (list . SUBSYMS)) + (if target-weight + (if (apply weights= subsyms) + (displayln (format "~a is bad: needs to be ~a" 'SYM (- NUM (- (wt SYM) target-weight)))) + ((unbalanced-subsym subsyms) (wt (balanced-subsym subsyms)))) + (cons (prog 'SYM NUM) (map app subsyms)))) + (module+ main + (when (= (current-target-len) (length (flatten (SYM)))) + (if (eq? (current-stars) '★) 'SYM (SYM 'find-bad-weight)))))] + [(M SYM (NUM)) #'(M SYM (NUM) ->)]) \ No newline at end of file diff --git a/2017/helper.rkt b/2017/helper.rkt index 9e64ba3..daf937c 100644 --- a/2017/helper.rkt +++ b/2017/helper.rkt @@ -1,6 +1,6 @@ #lang br -(require syntax/strip-context sugar/list) -(provide (all-defined-out) (all-from-out syntax/strip-context sugar/list)) +(require syntax/strip-context sugar) +(provide (all-defined-out) (all-from-out syntax/strip-context sugar)) (define ★ '★) (define ★★ '★★) @@ -14,4 +14,9 @@ (define (dirname path) (define-values (dir name _) (split-path path)) - dir) \ No newline at end of file + dir) + +(define (=* . xs) + (or (< (length xs) 2) (apply = xs))) + +(define (app x . args) (apply x args)) \ No newline at end of file