aoc-2023

My solutions in CHICKEN scheme to Advent of Code 2023
git clone https://git.instinctive.eu/aoc-2023.git
Log | Files | Refs | README | LICENSE

day07.scm (4569B)

      1 ; Copyright (c) 2023, Natacha Porté
      2 ;
      3 ; Permission to use, copy, modify, and distribute this software for any
      4 ; purpose with or without fee is hereby granted, provided that the above
      5 ; copyright notice and this permission notice appear in all copies.
      6 ;
      7 ; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
      8 ; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
      9 ; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
     10 ; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
     11 ; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
     12 ; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
     13 ; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
     14 
     15 (import (chicken io) (chicken sort) (chicken string)
     16         comparse
     17         srfi-1
     18         srfi-14)
     19 
     20 ;;;;;;;;;;;;;;;;;
     21 ;; Input parsing
     22 
     23 (define (as-number parser)
     24   (bind (as-string parser)
     25         (lambda (s)
     26           (result (string->number s)))))
     27 
     28 (define spaces
     29   (one-or-more (is #\space)))
     30 
     31 (define digit
     32   (in char-set:digit))
     33 
     34 (define digits
     35   (as-number (one-or-more digit)))
     36 
     37 (define card
     38   (in #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\T #\J #\Q #\K #\A))
     39 
     40 (define hand
     41   (sequence* ((hand (repeated card 5))
     42               (_ spaces)
     43               (bid digits)
     44               (_ (is #\newline)))
     45     (result (list hand bid))))
     46 
     47 (define all-data
     48   (zero-or-more hand))
     49 
     50 (define data (parse all-data (read-string)))
     51 ;(write-line (conc "Input: " data))
     52 
     53 ;;;;;;;;;;;;;;;;;
     54 ;; First Puzzle
     55 
     56 (define (card-value c)
     57   (cond ((eqv? c #\2)  2)
     58         ((eqv? c #\3)  3)
     59         ((eqv? c #\4)  4)
     60         ((eqv? c #\5)  5)
     61         ((eqv? c #\6)  6)
     62         ((eqv? c #\7)  7)
     63         ((eqv? c #\8)  8)
     64         ((eqv? c #\9)  9)
     65         ((eqv? c #\T) 10)
     66         ((eqv? c #\J) 11)
     67         ((eqv? c #\Q) 12)
     68         ((eqv? c #\K) 13)
     69         ((eqv? c #\A) 14)))
     70 
     71 (define converted-data
     72   (map (lambda (x) (list (map card-value (car x)) (cadr x))) data))
     73 
     74 (define (inner-count-cards sorted-hand prev result)
     75   (if (null? sorted-hand)
     76       result
     77       (inner-count-cards (cdr sorted-hand)
     78                    (car sorted-hand)
     79                    (if (= (car sorted-hand) prev)
     80                        (cons (add1 (car result)) (cdr result))
     81                        (cons 1 result)))))
     82  (define (count-cards sorted-hand)
     83    (inner-count-cards sorted-hand -1 '()))
     84 
     85 (define (list=? list1 list2)
     86   (cond ((and (null? list1) (null? list2)) #t)
     87         ((or (null? list1) (null? list2)) #f)
     88         ((= (car list1) (car list2)) (list=? (cdr list1) (cdr list2)))
     89         (else #f)))
     90 
     91 (define (hand-kind hand)
     92   (let ((counts (sort (count-cards (sort hand <)) <)))
     93     (cond ((list=? counts '(5)) 7)  ; five of a kind
     94           ((list=? counts '(1 4)) 6) ; four of a kind
     95           ((list=? counts '(2 3)) 5) ; full house
     96           ((list=? counts '(1 1 3)) 4) ; three of a kind
     97           ((list=? counts '(1 2 2)) 3) ; two pairs
     98           ((list=? counts '(1 1 1 2)) 2) ; one pair
     99           ((list=? counts '(1 1 1 1 1)) 1) ; one pair
    100           (else (write-line (conc "Bad hand " hand " with counts " counts))))))
    101 
    102 (define (list-less? list1 list2)
    103   (cond ((and (null? list1) (null? list2)) #f)
    104         ((< (car list1) (car list2)) #t)
    105         ((> (car list1) (car list2)) #f)
    106         (else (list-less? (cdr list1) (cdr list2)))))
    107 
    108 (define (hand-less? hand1 hand2)
    109   (let ((kind1 (hand-kind hand1))
    110         (kind2 (hand-kind hand2)))
    111     (or (< kind1 kind2)
    112         (and (= kind1 kind2) (list-less? hand1 hand2)))))
    113 
    114 (define sorted-converted-data
    115   (sort converted-data (lambda (x y) (hand-less? (car x) (car y)))))
    116 
    117 (define (answer-1 todo rank result)
    118   (if (null? todo)
    119       result
    120       (answer-1 (cdr todo)
    121                 (add1 rank)
    122                 (+ result (* rank (cadar todo))))))
    123 
    124 (write-line (conc "First puzzle:  " (answer-1 sorted-converted-data 1 0)))
    125 
    126 ;;;;;;;;;;;;;;;;;
    127 ;; Second Puzzle
    128 
    129 (define (count-cards sorted-hand)
    130   (let* ((no-J-hand (filter (lambda (x) (not (= x 1))) sorted-hand))
    131          (no-J-counts (sort (inner-count-cards no-J-hand -1 '()) >)))
    132     (if (null? no-J-counts)
    133         '(5)
    134         (cons (+ (car no-J-counts) (- 5 (length no-J-hand)))
    135               (cdr no-J-counts)))))
    136 
    137 (define converted-data-2
    138   (map (lambda (l) (cons
    139     (map (lambda (x) (if (= x 11) 1 x)) (car l)) (cdr l)))
    140     converted-data))
    141 
    142 (define sorted-converted-data-2
    143   (sort converted-data-2 (lambda (x y) (hand-less? (car x) (car y)))))
    144 
    145 (write-line (conc "Second puzzle: " (answer-1 sorted-converted-data-2 1 0)))