guile-project-euler-solutions/018-bottom-up-approach.scm

;; ==================
;; BOTTOM UP APPROACH
;; ==================

;; OK, lets try the constructive bottom up approach.

(import
 (except (rnrs base) let-values map)

 (only (guile)
       lambda* λ
       ;; printing
       display
       simple-format
       ;; command line arguments
       command-line
       current-input-port
       current-output-port)

 (ice-9 textual-ports)
 (ice-9 match)  ; let-match
 (ice-9 exceptions)
 (ice-9 pretty-print)

 (srfi srfi-1)
 ;; for functional structs (not part of srfi-9 directly)
 (srfi srfi-9 gnu)
 ;; hash tables
 (srfi srfi-69)

 (fileio)
 (list-helpers)
 (function-combinators))

;; =====
;; MODEL
;; =====

(define make-inappropriate-value-exception
  (record-constructor
   (make-exception-type '&inappropriate-value
                        &programming-error
                        '(val))))


(define-immutable-record-type <position>
  (construct-position row col)
  position?
  (row position-row set-position-row)
  (col position-col set-position-col))


(define-immutable-record-type <path-element>
  (construct-path-element pos val)
  path-element?
  (pos path-element-pos set-path-element-pos)
  (val path-element-val set-path-element-val))


(define-immutable-record-type <path>
  (construct-path elems sum)
  path?
  (elems path-elements set-path-element-elems)
  (sum path-sum set-path-element-sum))


(define make-position
  (λ (row col)
    (cond
     [(not (integer? row))
      (raise-exception
       (make-exception
        (make-inappropriate-value-exception row)
        (make-exception-with-message "row must be a positive integer")
        (make-exception-with-irritants (list row))
        (make-exception-with-origin 'make-position)))]
     [(not (integer? col))
      (raise-exception
       (make-exception
        (make-inappropriate-value-exception col)
        (make-exception-with-message "col must be a positive integer")
        (make-exception-with-irritants (list col))
        (make-exception-with-origin 'make-position)))]
     [else
      (construct-position row col)])))


(define position=?
  (λ (p1 p2)
    (and (= (position-row p1) (position-row p2))
         (= (position-col p1) (position-col p2)))))


(define make-path-element
  (λ (pos val)
    (cond
     [(not (position? pos))
      (raise-exception
       (make-exception
        (make-inappropriate-value-exception pos)
        (make-exception-with-message "pos must be a <position>")
        (make-exception-with-irritants (list pos))
        (make-exception-with-origin 'make-path-element)))]
     [else
      (construct-path-element pos val)])))


(define make-path
  (λ (elems sum)
    (construct-path elems sum)))


(define make-empty-path
  (λ ()
    (make-path '() 0)))


(define path-prepend
  (λ (path elem)
    (make-path (cons elem (path-elements path))
               (+ (path-sum path)
                  (path-element-val elem)))))

;; navigating

(define go-up-left
  (λ (pos)
    (make-position (- (position-row pos) 1)
                   (- (position-col pos) 1))))


(define go-up
  (λ (pos)
    (make-position (- (position-row pos) 1)
                   (position-col pos))))


;; triangle abstraction

(define triangle-dimensions
  (λ (triangle)
    (array-dimensions triangle)))


(define in-triangle?
  (λ (triangle pos)
    (match-let ([(height width) (triangle-dimensions triangle)]
                [row (position-row pos)]
                [col (position-col pos)])
      (and (< row height)
           (< col width)
           (<= col row)
           (>= col 0)
           (>= row 0)))))


(define triangle-ref
  (λ (triangle pos)
    (array-ref triangle
               (position-row pos)
               (position-col pos))))





(define triangle-height
  (λ (triangle)
    (match-let ([(height _) (triangle-dimensions triangle)])
      height)))


(define triangle-width
  (λ (triangle)
    (match-let ([(_ width) (triangle-dimensions triangle)])
      width)))



(define triangle-up-element
  (λ (triangle pos)
    (let* ([element-pos (make-position (- (position-row pos) 1) (position-col pos))]
           [element-val (triangle-ref triangle element-pos)])
      (make-path-element element-pos element-val))))


(define triangle-up-left-element
  (λ (triangle pos)
    (let* ([element-pos
            (make-position (- (position-row pos) 1)
                           (- (position-col pos) 1))]
           [element-val
            (triangle-ref triangle element-pos)])
      (make-path-element element-pos element-val))))


;; =========
;; ALGORITHM
;; =========

(define max-parent-element
  (λ (triangle pos)
    ;; Problem: cannot go up left for example, from col 0.
    (let ([up-left-pos (go-up-left pos)]
          [up-pos (go-up pos)])
      (cond
       ;; If both positions should exist in the triangle, return the maximum
       ;; element.
       [(and (in-triangle? triangle up-left-pos)
             (in-triangle? triangle up-pos))
        (cond
         [(> (triangle-ref triangle up-left-pos)
             (triangle-ref triangle up-pos))
          (list
           (make-path-element up-pos (triangle-ref triangle up-left-pos)))]
         ;; If both elements are equal, we need to consider both paths
         ;; up the triangle, in order to not leave out any potentially
         ;; maximum path.
         [(= (triangle-ref triangle up-left-pos)
             (triangle-ref triangle up-pos))
          (list
           (make-path-element up-pos (triangle-ref triangle up-left-pos))
           (make-path-element up-left-pos (triangle-ref triangle up-pos)))]
         [else
          (list
           (make-path-element up-pos (triangle-ref triangle up-pos)))])]
       ;; Otherwise return the one that does exist.
       [(in-triangle? triangle up-left-pos)
        (list
         (make-path-element up-left-pos (triangle-ref triangle up-left-pos)))]
       [(in-triangle? triangle up-pos)
        (list
         (make-path-element up-pos (triangle-ref triangle up-pos)))]
       ;; Otherwise raise an exception.
       [else
        (raise-exception
         (make-exception
          (make-exception-with-message "unexpected error")
          (make-exception-with-irritants (list triangle pos))
          (make-exception-with-origin 'max-parent-element)))]))))


(define parent-elements
  (λ (triangle pos)
    (let ([up-left-pos (go-up-left pos)]
          [up-pos (go-up pos)])
      (cond
       ;; If both positions should exist in the triangle, return the maximum
       ;; element.
       [(and (in-triangle? triangle up-left-pos)
             (in-triangle? triangle up-pos))
        (list
         (make-path-element up-pos (triangle-ref triangle up-pos))
         (make-path-element up-left-pos (triangle-ref triangle up-left-pos)))]
       ;; Otherwise return the one that does exist.
       [(in-triangle? triangle up-left-pos)
        (list
         (make-path-element up-left-pos (triangle-ref triangle up-left-pos)))]
       [(in-triangle? triangle up-pos)
        (list
         (make-path-element up-pos (triangle-ref triangle up-pos)))]
       ;; Otherwise raise an exception.
       [else
        (raise-exception
         (make-exception
          (make-exception-with-message "unexpected error")
          (make-exception-with-irritants (list triangle pos))
          (make-exception-with-origin 'max-parent-element)))]))))


(define triangle-base-paths
  (λ (triangle)
    (match-let ([(height width) (triangle-dimensions triangle)])
      (let ([base-row (- height 1)])
        (let iter ([col 0])
          (cond
           [(>= col width) '()]
           [else
            (let* ([pos (make-position base-row col)]
                   [val (triangle-ref triangle pos)]
                   [one-elem-path
                    (path-prepend (make-empty-path) (make-path-element pos val))])
              (cons one-elem-path (iter (+ col 1))))]))))))


(define reduce-paths
  (λ (paths)
    "Idea: If paths have the same top element, but different sums,
then keep only the one with the maximum sum. If there are equal sums,
keep only one of them."
    (let ([pos-to-max-path-table (make-hash-table position=?)])
      (for-each (λ (path)
                  (let ([pos-key (path-element-pos (first (path-elements path)))])
                    (hash-table-update!/default pos-to-max-path-table
                                                pos-key
                                                ;; Compare with the
                                                ;; old path.
                                                (λ (old-path)
                                                  (if (> (path-sum path)
                                                         (path-sum old-path))
                                                      path
                                                      old-path))
                                                ;; Set the current
                                                ;; path as the first
                                                ;; value for a
                                                ;; position in the
                                                ;; hash table.
                                                path)))
                paths)
      (hash-table-values pos-to-max-path-table))))


(define expand-paths
  (λ (triangle paths)
    (flatten
     ;; For each path prepend parent elements to the path.
     (map (λ (path)
            (match-let ([(elem . others) (path-elements path)]
                        [sum (path-sum path)])
              (let ([parents
                     ;; There can be multiple maximum parents, if both
                     ;; parents have the same value.
                     (parent-elements triangle (path-element-pos elem))])
                ;; Prepend the maximum parent element(s) to the path.
                (map (λ (parent) (path-prepend path parent))
                     parents))))
          paths))))


(define find-max-sum-bottom-up
  (λ (triangle)
    (match-let ([(height width) (triangle-dimensions triangle)])
      ;; Iterate through the rows from bottom to top.
      (let iter ([current-row (- height 1)]
                 [paths (triangle-base-paths triangle)])
        ;; The higher we get in the triangle, the thinner the triangle gets and
        ;; there are no more numbers on higher indices we need to look at.
        (let ([current-width (+ current-row 1)])
          (cond
           ;; If all rows have been looked at, we will know the maximum sum
           ;; path. In fact, there should only be one path left in the list of
           ;; paths.
           [(= current-row 0)
            (let iter-max ([remaining-paths (drop paths 1)]
                           [max-path (first paths)])
              (cond
               [(null? remaining-paths) max-path]
               [else
                (let ([path (first remaining-paths)])
                  (cond
                   [(> (path-sum path)
                       (path-sum max-path))
                    (iter-max (drop remaining-paths 1) path)]
                   [else
                    (iter-max (drop remaining-paths 1) max-path)]))]))]
           ;; Otherwise go to the next column.
           [else
            ;; TODO: next idea: take all parents and implement reduce
            ;; for paths to keep paths from becoming too many.
            (let ([updated-paths (expand-paths triangle paths)])
              (iter (- current-row 1)
                    updated-paths))]))))))


;; read in the data
(define input-lines (get-lines-from-file (cadr (command-line))))
(define input
  (let* ([as-list-of-lists
          (map (combine (λ (line) (string-split line (λ (c) (char=? c #\space))))
                        (λ (num-strs) (map string->number num-strs)))
               input-lines)]
         [max-width
          (fold (λ (acc elem) (max elem acc))
                0
                (map length as-list-of-lists))]
         [padded-list-of-lists
          (map (λ (lst) (list-right-pad lst max-width 0))
               as-list-of-lists)]
         [as-array
          (list->array '(0 0) padded-list-of-lists)])
    as-array))


(display
 (simple-format
  #f "max sum (bottom-up): ~a\n"
  (find-max-sum-bottom-up input)))