advent-of-code-2022/day-12/part-02.scm

(import
 (except (rnrs base)
         let-values
         map
         error
         vector-map)
 (only (guile)
       lambda* λ
       simple-format
       current-output-port)
 (fileio)
 (array-helpers)
 ;; (ice-9 pretty-print)
 (ice-9 format)
 (parallelism)
 ;; purely functional data structures
 (pfds sets)
 (srfi srfi-1))


(define debug-peek
  (lambda* (sth #:optional (message ""))
    (let ([as-string
           (call-with-output-string
             (λ (port)
               (simple-format port "~a" sth)))])
      (simple-format (current-output-port)
                     "~a~a\n"
                     message
                     as-string)
      sth)))


(define-syntax ->
  (syntax-rules ()
    ;; first expression is left unchanged
    [(-> expr) expr]
    ;; take from the back, wrap other calls
    [(-> expr* ... (op args* ...))
     (op args* ... (-> expr* ...))]
    ;; make parens unnecessary in trivial case of no further arguments
    [(-> expr* ... op)
     (op (-> expr* ...))]))


(define input-filename "input")
(define lines (get-lines-from-file input-filename))
(define rows (length lines))
(define cols (string-length (car lines)))
(define empty-landscape (make-array 0 rows cols))


(define a-z->01-26
  (λ (char)
    (let ([offset (char->integer (car (string->list "a")))])
      (- (char->integer char)
         offset))))


(define string->char
  (λ (str)
    (car (string->list str))))


(define landscape
  (let ([char-array
         (parallel-map (λ (line _index) (string->list line))
                       lines)])
    (array-map (λ (elem) (a-z->01-26 elem))
               (list->array 2 char-array))))


(define start-pos
  (let ([as-vec
         (array-index-of landscape
                         (λ (num)
                           (= num (a-z->01-26 (string->char "S")))))])
    (cons (vector-ref as-vec 0)
          (vector-ref as-vec 1))))


(define end-pos
  (let ([as-vec
         (array-index-of landscape
                         (λ (num)
                           (= num (a-z->01-26 (string->char "E")))))])
    (cons (vector-ref as-vec 0)
          (vector-ref as-vec 1))))


(define landscape-replaced
  (array-map (λ (elem)
               (cond
                [(= elem (a-z->01-26 (string->char "S")))
                 (a-z->01-26 (string->char "a"))]
                [(= elem (a-z->01-26 (string->char "E")))
                 (a-z->01-26 (string->char "z"))]
                [else elem]))
             landscape))


(define neighbors
  (λ (arr row-ind col-ind)
    (define up
      (λ (row-ind col-ind)
        (cons (- row-ind 1) col-ind)))
    (define down
      (λ (row-ind col-ind)
        (cons (+ row-ind 1) col-ind)))
    (define left
      (λ (row-ind col-ind)
        (cons row-ind (- col-ind 1))))
    (define right
      (λ (row-ind col-ind)
        (cons row-ind (+ col-ind 1))))
    (define neighbors?
      (λ (elem step-elem)
        (or
         ;; Height can be lower than height of current
         ;; position/platform.
         (<= step-elem elem)
         ;; Or at max 1 heigher than height of current
         ;; position.
         (= (+ elem 1) step-elem))))
    (let ([directions (list right up down left)])
      (filter (λ (elem) elem)
              (map (λ (step)
                     (let* ([elem (array-ref landscape-replaced row-ind col-ind)]
                            [next-pos (step row-ind col-ind)])
                       (and
                        (array-in-bounds? arr (car next-pos) (cdr next-pos))
                        (let ([step-elem (array-ref landscape-replaced (car next-pos) (cdr next-pos))])
                          (and (neighbors? elem step-elem) next-pos)))))
                   directions)))))


(define neighborhood
  (let ([rows (array-len-in-dim landscape-replaced 0)]
        [cols (array-len-in-dim landscape-replaced 1)])
    (let ([neighborhood (make-array '() rows cols)])
      (let iter-rows ([row° 0])
        (let iter-cols ([col° 0])
          (cond
           [(>= col° cols) (iter-rows (+ row° 1))]
           [(>= row° rows) neighborhood]
           [else (array-set! neighborhood
                             (neighbors landscape-replaced row° col°)
                             row° col°)
                 (iter-cols (+ col° 1))]))))))


(define make-empty-set
  (λ ()
    (make-set
     (λ (p1 p2)
       (or (< (car p1) (car p2))
           (and (= (car p1) (car p2))
                (< (cdr p1) (cdr p2))))))))


(define set-insert-multiple
  (λ (myset items)
    (cond
     [(null? items) myset]
     [else
      (set-insert-multiple (set-insert myset (car items))
                           (cdr items))])))


(define update-finge
  (λ (landscape fringe visited)
    (let iter ([fringe-set° (make-empty-set)]
               [fringe° fringe])
      (cond
       [(null? fringe°) (set->list fringe-set°)]
       [else
        (let ([pos (car fringe°)])
          (iter (-> (array-ref neighborhood (car pos) (cdr pos))
                    (filter (λ (pos) (not (set-member? visited pos))) #|arg|#)
                    (set-insert-multiple fringe-set° #|arg|#))
                (cdr fringe°)))]))))


(define made-progress?
  (λ (visited-before visited-after)
    (> (set-size visited-after)
       (set-size visited-before))))


(define find-shortest-path
  (λ (landscape neighborhood start-pos end-pos)
    (let iter ([fringe° (list start-pos)]
               [visited° (make-empty-set)]
               [step-count° 0])
      (let ([end-reached
             (reduce (λ (elem acc) (or acc elem))
                     #f
                     (parallel-map (λ (pos ind) (equal? pos end-pos))
                                   fringe°))])
        (cond
         [end-reached
          (simple-format #t "result for start position ~a: ~a\n" start-pos step-count°)
          step-count°]
         [else
          (let ([updated-visited° (set-insert-multiple visited° fringe°)])
            ;; (simple-format #t "visited before: ~a\n" (set-size visited°))
            ;; (simple-format #t "visited after : ~a\n" (set-size updated-visited°))
            (cond
             [(made-progress? visited° updated-visited°)
              (iter (update-finge landscape fringe° updated-visited°)
                    updated-visited°
                    (+ step-count° 1))]
             [else
              ;; (simple-format #t "no more progress possible from starting pos: ~a\n" start-pos)
              +inf.0]))])))))


(define a-indices
  (array-indices-of landscape-replaced (λ (elem) (= elem 0))))


(let ([result
       (inexact->exact
        (run-in-parallel a-indices
                         (λ (indices-vec _ind)
                           ;; (simple-format #t "checking for start position: ~a\n" indices-vec)
                           (find-shortest-path landscape-replaced
                                               neighborhood
                                               (cons (vector-ref indices-vec 0)
                                                     (vector-ref indices-vec 1))
                                               end-pos))
                         (λ (elem acc) (min elem acc))
                         +inf.0))])
  (simple-format #t "result: ~a\n" result))