Day 5 Optimized Solution
This commit is contained in:
parent
f090f81d3f
commit
6228043bf0
GPG Key ID:
B38976E82C9DAE42
210
chicken.org
210
chicken.org
|
|
@ -62,6 +62,7 @@ Consider your entire calibration document. *What is the sum of all of the calibr
|
|||
|
||||
#+begin_src scheme :exports none :noweb yes :tangle day1.scm
|
||||
(import (chicken fixnum)
|
||||
(chicken sort)
|
||||
(chicken string)
|
||||
(chicken keyword)
|
||||
(chicken irregex))
|
||||
|
|
@ -406,23 +407,10 @@ of the entries, by using irregex matches.
|
|||
|
||||
#+NAME: day2-part1-record-splitting
|
||||
#+begin_src scheme
|
||||
;; Records
|
||||
(define record-pattern
|
||||
'(: bol
|
||||
"Game "
|
||||
(submatch-named game-no (+ (/ #\0 #\9)))
|
||||
":"
|
||||
(submatch-named draws (*? any))
|
||||
eol))
|
||||
|
||||
(define (record-kons from-index match seed)
|
||||
(cons
|
||||
(cons (string->number (irregex-match-substring match 'game-no))
|
||||
(draws-fold (irregex-match-substring match 'draws)))
|
||||
seed))
|
||||
|
||||
(define (record-fold input)
|
||||
(irregex-fold record-pattern record-kons '() input))
|
||||
(define (calc-part-2)
|
||||
(let ((seeds (expand-seeds (input->seeds-list input)))
|
||||
(mapping-alist (input->mapping-alist input)))
|
||||
(fold-seeds seeds mapping-alist)))
|
||||
#+end_src
|
||||
|
||||
**** Draw Splitting
|
||||
|
|
@ -2075,21 +2063,21 @@ actually needed.
|
|||
|
||||
#+NAME: day5-part2-expand-seeds
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (expand-seed existing-seeds start size)
|
||||
(let ((max (- (+ start size) 1)))
|
||||
(do ((seedlist (cons start existing-seeds)
|
||||
(cons (+ (car seedlist) 1)
|
||||
seedlist)))
|
||||
((< (- max 2) (car seedlist))
|
||||
seedlist))))
|
||||
(define (expand-seed existing-seeds start size)
|
||||
(let ((max (- (+ start size) 1)))
|
||||
(do ((seedlist (cons start existing-seeds)
|
||||
(cons (+ (car seedlist) 1)
|
||||
seedlist)))
|
||||
((< (- max 2) (car seedlist))
|
||||
seedlist))))
|
||||
|
||||
(define (expand-seeds seed-nums #!optional (existing-seeds '()))
|
||||
(if (< 2 (length seed-nums))
|
||||
(expand-seeds (cddr seed-nums)
|
||||
(delay-force (expand-seed existing-seeds
|
||||
(car seed-nums)
|
||||
(cadr seed-nums))))
|
||||
(expand-seed existing-seeds (car seed-nums) (cadr seed-nums))))
|
||||
(define (expand-seeds seed-nums #!optional (existing-seeds '()))
|
||||
(if (< 2 (length seed-nums))
|
||||
(expand-seeds (cddr seed-nums)
|
||||
(delay-force (expand-seed existing-seeds
|
||||
(car seed-nums)
|
||||
(cadr seed-nums))))
|
||||
(expand-seed existing-seeds (car seed-nums) (cadr seed-nums))))
|
||||
#+end_src
|
||||
|
||||
After that, it is /almost/ identical to part 1, but we have to replace the ~foldl~ with a recursive
|
||||
|
|
@ -2097,18 +2085,18 @@ function that handles the promises.
|
|||
|
||||
#+NAME: day5-part2-fold-seeds
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (fold-seeds seeds mapping-alist #!optional (minimum most-positive-fixnum))
|
||||
(let* ((seeds (if (promise? seeds) (force seeds) seeds))
|
||||
(seeds-available? (not (eqv? '() seeds))))
|
||||
(if seeds-available?
|
||||
(let ((location-entity-id ((compose entity-id
|
||||
(cut map-entity-forward-fully <> mapping-alist)
|
||||
(cut make-entity #:seed <>))
|
||||
(car seeds))))
|
||||
(fold-seeds (cdr seeds)
|
||||
mapping-alist
|
||||
(min minimum location-entity-id)))
|
||||
minimum)))
|
||||
(define (fold-seeds seeds mapping-alist #!optional (minimum most-positive-fixnum))
|
||||
(let* ((seeds (if (promise? seeds) (force seeds) seeds))
|
||||
(seeds-available? (not (eqv? '() seeds))))
|
||||
(if seeds-available?
|
||||
(let ((location-entity-id ((compose entity-id
|
||||
(cut map-entity-forward-fully <> mapping-alist)
|
||||
(cut make-entity #:seed <>))
|
||||
(car seeds))))
|
||||
(fold-seeds (cdr seeds)
|
||||
mapping-alist
|
||||
(min minimum location-entity-id)))
|
||||
minimum)))
|
||||
#+end_src
|
||||
|
||||
#+NAME: day5-part2-calc
|
||||
|
|
@ -2155,14 +2143,136 @@ For the optimized solution using ranges, a new record type is needed: ~ranged-en
|
|||
To map the ~ranged-entity~ onto the next step, it has to be split up according to the
|
||||
~mapping-entry~ ranges.
|
||||
|
||||
There are different types of splitting, and when they apply:
|
||||
|
||||
- The beginning of ~ranged-entity~ lies lower than the ~mapping-entry~: the part lower has to be
|
||||
extracted into a 1:1-mapping for the next step type.
|
||||
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (map-ranged-entity-forward ranged-entity mapping-alist)
|
||||
(let* ((mapping-entries (alist-ref (ranged-entity-type ranged-entity) mapping-alist))
|
||||
(mapping-entries-alist (map (lambda (x) (cons (mapping-entry-from-start x)
|
||||
x))
|
||||
mapping-entries))
|
||||
(sorted-range-starts (sort (map mapping-entry-from-start mapping-entries))))
|
||||
))
|
||||
(define (extract-dangling-entity-part ranged-entity type mapping-entry)
|
||||
(let ((mapping-entry-lower-bound (mapping-entry-from-start mapping-entry)))
|
||||
(values (make-ranged-entity type
|
||||
(ranged-entity-from-id ranged-entity)
|
||||
(- mapping-entry-lower-bound 1))
|
||||
(make-ranged-entity (ranged-entity-type ranged-entity)
|
||||
mapping-entry-lower-bound
|
||||
(ranged-entity-to-id ranged-entity)))))
|
||||
#+end_src
|
||||
|
||||
- The beginning of ~ranged-entity~ is somewhere inside ~mapping-entry~: the part inside the
|
||||
~mapping-entity~'s range has to be extracted and the ids shifted accordingly.
|
||||
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (extract-matching-entity-part ranged-entity type mapping-entry)
|
||||
(let* ((mapping-entry-lower-bound (mapping-entry-from-start mapping-entry))
|
||||
(mapping-entry-upper-bound (mapping-entry-from-end mapping-entry))
|
||||
(mapping-entry-target-start (mapping-entry-to-start mapping-entry))
|
||||
(ranged-entity-lower-bound (ranged-entity-from-id ranged-entity))
|
||||
(ranged-entity-upper-bound (ranged-entity-to-id ranged-entity))
|
||||
(start-offset (- ranged-entity-lower-bound mapping-entry-lower-bound))
|
||||
(first-index (max ranged-entity-lower-bound mapping-entry-lower-bound))
|
||||
(last-index (min ranged-entity-upper-bound mapping-entry-upper-bound))
|
||||
(range-size (- last-index first-index))
|
||||
(matches-mapping? (= ranged-entity-upper-bound mapping-entry-upper-bound))
|
||||
(exceeds-mapping? (> ranged-entity-upper-bound mapping-entry-upper-bound)))
|
||||
(values (make-ranged-entity type
|
||||
(+ mapping-entry-target-start start-offset)
|
||||
(+ mapping-entry-target-start start-offset range-size))
|
||||
(if exceeds-mapping?
|
||||
(make-ranged-entity (ranged-entity-type ranged-entity)
|
||||
(+ mapping-entry-upper-bound 1)
|
||||
ranged-entity-upper-bound)
|
||||
#f))))
|
||||
#+end_src
|
||||
|
||||
- There is just ~ranged-entity~ left, with nothing else: then it gets a new type, and is otherwise
|
||||
passed on 1:1.
|
||||
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (map-dangling-entity ranged-entity type)
|
||||
(values (make-ranged-entity type
|
||||
(ranged-entity-from-id ranged-entity)
|
||||
(ranged-entity-to-id ranged-entity))
|
||||
#f))
|
||||
#+end_src
|
||||
|
||||
This behemoth determines which of the functions above to call.
|
||||
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (map-ranged-entity-forward ranged-entity type level-mappings)
|
||||
(let ((processed-ranged-entity #f)
|
||||
(remaining-ranged-entity #f)
|
||||
(retry? #f))
|
||||
(cond
|
||||
((eqv? '() ranged-entity) '())
|
||||
((eqv? '() level-mappings)
|
||||
(let-values (((processed-ranged-entity* remaining-ranged-entity*)
|
||||
(map-dangling-entity ranged-entity type)))
|
||||
(set! processed-ranged-entity processed-ranged-entity*)
|
||||
(set! remaining-ranged-entity remaining-ranged-entity*)))
|
||||
((and (>= (ranged-entity-from-id ranged-entity)
|
||||
(mapping-entry-from-start (car level-mappings)))
|
||||
(<= (ranged-entity-from-id ranged-entity)
|
||||
(mapping-entry-from-end (car level-mappings))))
|
||||
(let-values
|
||||
(((processed-ranged-entity* remaining-ranged-entity*)
|
||||
(extract-matching-entity-part ranged-entity type (car level-mappings))))
|
||||
(set! processed-ranged-entity processed-ranged-entity*)
|
||||
(set! remaining-ranged-entity remaining-ranged-entity*)))
|
||||
((> (ranged-entity-from-id ranged-entity)
|
||||
(mapping-entry-from-end (car level-mappings)))
|
||||
(set! retry? #t))
|
||||
(else
|
||||
(let-values
|
||||
(((processed-ranged-entity* remaining-ranged-entity*)
|
||||
(extract-dangling-entity-part ranged-entity type (car level-mappings))))
|
||||
(set! processed-ranged-entity processed-ranged-entity*)
|
||||
(set! remaining-ranged-entity remaining-ranged-entity*))))
|
||||
(if retry?
|
||||
(map-ranged-entity-forward ranged-entity type (cdr level-mappings))
|
||||
(if remaining-ranged-entity
|
||||
(cons processed-ranged-entity
|
||||
(map-ranged-entity-forward remaining-ranged-entity type (cdr level-mappings)))
|
||||
(list processed-ranged-entity)))))
|
||||
#+end_src
|
||||
|
||||
Here, the mapping is being done.
|
||||
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (map-ranged-entity-forward-fully ranged-entity mapping-alist)
|
||||
(let ((mappings (alist-ref (ranged-entity-type ranged-entity) mapping-alist)))
|
||||
(if (and (not (eqv? '() mappings))
|
||||
mappings)
|
||||
(let* ((mappings-alist (map (lambda (x)
|
||||
(cons (mapping-entry-from-start x) x))
|
||||
mappings))
|
||||
(sorted-mapping-ids (sort (map car mappings-alist) <))
|
||||
(sorted-mappings (map (cut alist-ref <> mappings-alist) sorted-mapping-ids))
|
||||
(new-type (mapping-entry-to-type (car sorted-mappings)))
|
||||
(new-entities (map-ranged-entity-forward ranged-entity new-type sorted-mappings)))
|
||||
(foldl append '() (map (cut map-ranged-entity-forward-fully <> mapping-alist)
|
||||
new-entities)))
|
||||
(list ranged-entity))))
|
||||
|
||||
(define (seeds-list->ranged-entities seeds)
|
||||
(if (<= 2 (length seeds))
|
||||
(cons (make-ranged-entity #:seed (car seeds)
|
||||
(- (+ (car seeds) (cadr seeds)) 1))
|
||||
(seeds-list->ranged-entities (cddr seeds)))
|
||||
'()))
|
||||
#+end_src
|
||||
|
||||
And here, it is all put together.
|
||||
|
||||
#+begin_src scheme :tangle day5.scm
|
||||
(define (calc-part-2-optimized)
|
||||
(let ((seeds (seeds-list->ranged-entities (input->seeds-list input)))
|
||||
(mapping-alist (input->mapping-alist input)))
|
||||
(foldl min most-positive-fixnum
|
||||
(map ranged-entity-from-id
|
||||
(foldl append '()
|
||||
(map (cut map-ranged-entity-forward-fully <> mapping-alist)
|
||||
seeds))))))
|
||||
#+end_src
|
||||
|
||||
** Puzzle Input
|
||||
|
|
|
|||
Loading…
Reference in New Issue