;;; nyacc/util.scm

;; Copyright (C) 2014-2017,2021,2023 Matthew Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>

;;; Code:

(define-module (nyacc util)
  #:export (fixpoint
            fmtstr fmtout fmterr fmt
            atomize-terminal
            wrap-action
            obj->str
            prune-assoc
            map-attr->vector
            x-flip x-comb
            write-vec
            ugly-print
            tzort
            vector-map vector-for-each vector-any vector-fold))

(define (fmtstr fmt . args)
  (apply simple-format #f fmt args))
(define (fmtout fmt . args)
  (apply simple-format (current-output-port) fmt args))
(define (fmterr fmt . args)
  (apply simple-format (current-error-port) fmt args))
(define fmt simple-format)

;; replacement for same from (srfi srfi-43)
(define (vector-map proc . vecs)
  (let* ((size (apply min (map vector-length vecs)))
         (retv (make-vector size)))
    (let loop ((ix 0))
      (cond
       ((= ix size) retv)
       (else
        (vector-set! retv ix
                     (apply proc ix (map (lambda (v) (vector-ref v ix)) vecs)))
        (loop (1+ ix)))))))

;; replacement for same from (srfi srfi-43)
(define (vector-for-each proc . vecs)
  (let ((size (apply min (map vector-length vecs))))
    (let loop ((ix 0))
      (cond
       ((= ix size) (if #f #f))
       (else
        (apply proc ix (map (lambda (v) (vector-ref v ix)) vecs))
        (loop (1+ ix)))))))

;; hack to replace same from (srfi srfi-43)
;; the real one takes more args
(define (vector-any pred? vec)
  (let ((size (vector-length vec)))
    (let loop ((ix 0))
      (cond
       ((= ix size) #f)
       ((pred? ix (vector-ref vec ix)) #t)
       (else (loop (1+ ix)))))))

;; replacement for same from (srfi srfi-43)
(define (vector-fold proc seed . vecs)
  (let ((size (apply min (map vector-length vecs))))
    (let loop ((seed seed) (ix 0))
      (cond
       ((= ix size) seed)
       (else
        (loop
         (apply proc ix seed (map (lambda (v) (vector-ref v ix)) vecs))
         (1+ ix)))))))

;; @deffn {Procedure} atomize-terminal terminal => object
;; Generate an atomic object for a terminal.   Expected terminals are strings,
;; characters and symbols.  This will convert the strings @code{s} to symbols
;; of the form @code{'$:s}.
;; @end deffn
(define (atomize-terminal terminal)
  (if (string? terminal)
      (string->symbol (string-append "$:" terminal))
      terminal))

;; @deffn {Procedure} make-arg-list N => '($N $Nm1 $Nm2 ... $1 . $rest)
;; This is a helper for @code{mkact}.
;; @end deffn
(define (make-arg-list n)
  (let ((mkarg
         (lambda (i) (string->symbol (string-append "$" (number->string i))))))
    (let loop ((r '(. $rest)) (i 1))
      (if (> i n) r (loop (cons (mkarg i) r) (1+ i))))))

;; @deffn {Procedure} wrap-action (n . guts) => quoted procedure
;; Wrap user-specified action (body, as a quoted list of expressions) with
;; n arguments to generate a quoted lambda.  That is,
;; @example
;;  `(lambda ($n ... $2 $1 . $rest) ,@guts)
;; @end example
;; The rationale for the arglist format is that we @code{apply} this
;; lambda to the the semantic stack.
(define (wrap-action actn)
  (cons* 'lambda (make-arg-list (car actn)) (cdr actn)))

;; @deffn obj->str object => string
;; Convert terminal (symbol, string, character) to string.
;; This is like @code{write} but will prefix symbols with @code{'}.
(define (obj->str obj)
  (cond ((string? obj) (simple-format #f "~S" obj))
        ((symbol? obj) (string-append "'" (symbol->string obj)))
        ((char? obj) (simple-format #f "~S" obj))))

;; @deffn prune-assoc al
;; Prune obsolete entries from an a-list.  This is order n^2.
(define (prune-assoc al)
  (let loop ((al1 '()) (al0 al))
    (if (null? al0) al1
        (loop (if (assoc (caar al0) al1) al1 (cons (car al0) al1)) (cdr al0)))))

;; @deffn {Procedure} fixpoint proc seed
;; This generates the fixpoint for @var{proc} applied to @var{seed},
;; a list.  The procedure @code{proc} takes as arguments an element from
;; the list and the entire list.   Updates should be cons'd onto the front
;; of the list.
;;
;; The routine works by setting prev to the empty list and next, curr and
;; item to the seed.  The item reference is propagated through the current
;; list until it reaches prev.  The calls to proc will update @code{next}.
;; @example
;; next-> +---+
;;        |   |
;; curr-> +---+
;;        |   |
;; item-> |   |
;;        |   |
;; prev-> +---+
;;        |   |
;;        +---+
;; @end example
;; @end deffn
(define (fixpoint proc seed)
  (let loop ((prev '()) (item seed) (curr seed) (next seed))
    (cond
     ((not (eqv? item prev))
      (loop prev (cdr item) curr (proc (car item) next)))
     ((not (eqv? next curr))
      (loop curr next next next))
     (else
      curr))))

;; @deffn vector-fixpoint proc vec => vec
;; (proc vec) => chg (boolean)
;; Not used yet (in step3).
(define (vector-fixpoint proc vec)
  (let loop ((chg #t))
    (if chg (proc vec) vec)))

;; @deffn map-attr->vector list-of-alists key => vector
;; map list of attribute lists to vector of attr
;; @example
;; (map-attr->vector '(((a . 1) ...) ((a . 2) ...) ...) => #(1 2 ...)
;; @end example
(define (map-attr->vector al-l key)
  (list->vector (map (lambda (al) (assq-ref al key)) al-l)))

;; @deffn flip al => a-list
;; change (a 1 2 3) to ((1 . a) (2 . a) (3 . a))
(define (x-flip al)
  (let loop ((result '()) (tail (cdr al)))
    (if (null? tail) result
        (loop (acons (car tail) (car al) result) (cdr tail)))))

;; @deffn x-comb (a1 a2 a3) (b1 b2 b3) => (a1 b1) (a1 b2) ...
;; The implementation needs work.
(define (x-comb a b)
  (let loop ((res '()) (al a) (bl b))
    (cond
     ((null? al) res)
     ((pair? bl) (loop (acons (car al) (car bl) res) al (cdr bl)))
     ((pair? al) (loop res (cdr al) b)))))

(define (write-vec port vec)
  (let* ((nv (vector-length vec)))
    (fmt port "  #(")
    (let loop ((col 4) (ix 0))
      (if (eq? ix nv) #f
          (let* ((item (vector-ref vec ix))
                 (stng (fmt #f "~S " item))
                 (leng (string-length stng)))
            (cond
             ((> (+ col leng) 78)
              (fmt port "\n    ~A" stng)
              (loop (+ 4 leng) (1+ ix)))
             (else
              (fmt port "~A" stng)
              (loop (+ col leng) (1+ ix)))))))
    (fmt port ")")))


;; @deffn {Procedure} ugly-print sexp [port] [options]
;; This will print in compact form which shows no structure.  The optional
;; keyword argument @var{#:pre-line-prefix} prints the provided string
;; at the start of each continued line.  The default is four spaces.
;; @end deffn
(define* (ugly-print sexp #:optional (port (current-output-port))
                     #:key (per-line-prefix "") (width 79) trim-ends)

  (define plplen (string-length per-line-prefix))

  (define obj->str object->string)

  ;; @deffn {Procedure} strout column string-or-number
  ;; Nominally takes a column and string, prints the string and returns updated
  ;; column.  If passed a number instead of string guarantee that many chars.
  ;; @end deffn
  (define (strout col str)
    (cond
     ((number? str)
      (if (>= (+ col str) width) (strout col "\n") col))
     ((string=? "\n" str)
      (newline port)
      (display per-line-prefix port)
      (display " " port)
      (1+ plplen))
     ((and (string=? str ")") (= width col))
      (display str port)
      (1+ col))
     ((>= (+ col (string-length str)) width)
      (cond
       ((string-every #\space str) (strout col "\n"))
       (else (strout (strout col "\n") str))))
     (else
      (display str port)
      (+ col (string-length str)))))

  (letrec
      ((loop1
        (lambda (col sx)
          (cond
           ((pair? sx)
            ;;(fmterr "[car sx=~S]" (car sx))
            (case (car sx)
              ((quote) (loop2 (strout (strout col 3) "'") (cdr sx)))
              ((quasiquote) (loop2 (strout (strout col 3) "`") (cdr sx)))
              ((unquote) (loop2 (strout (strout col 2) ",") (cdr sx)))
              ((unquote-splicing) (loop2 (strout (strout col 3) ",@") (cdr sx)))
              ;;(else (strout (loop2 (strout col "(") sx) ")"))))
              ;; (strout col 8) is kludge to prevent lone `(' at end of line
              (else (strout (loop2 (strout (strout col 8) "(") sx) ")"))))
           ((vector? sx)
            (strout
             (vector-fold
              (lambda (ix col elt)
                (loop1 (if (zero? ix) col (strout col " ")) elt))
              (strout col "#(") sx) ")"))
           ;;((null? sx) (strout col "'()"))
           ((null? sx) (strout col "()"))
           (else (strout col (obj->str sx))))))
       (loop2
        (lambda (col sx)
          (cond
           ((pair? sx)
            (if (null? (cdr sx))
                (loop2 (loop1 col (car sx)) (cdr sx))
                (loop2 (strout (loop1 col (car sx)) " ") (cdr sx))))
           ((null? sx) col)
           (else (strout (strout col ". ") (obj->str sx)))))))

    (if (not trim-ends) (strout 0 per-line-prefix))
    (loop1 plplen sexp)
    (if (not trim-ends) (newline port))
    (if #f #f)))

;; stuff

;; @deffn {Procedure} depth-first-search graph => (values ht gv tv xl)
;; The argument @var{gfraph} is a list of verticies and adjacency nodes:
;; @example
;; graph => ((1 2 3 4) (2 6 7) ...)
;; @end example
;; @noindent
;; @table @var
;; @item ht
;; hash of vertex to index
;; @item gv
;; vector of index to vertex
;; @item tv
;; vector of (d . f)
;; @end table
;; ref: Algorithms, p 478
;; @end deffn
(define (depth-first-search graph)
  (let* ((n (length graph))
           (ht (make-hash-table n))     ; vertex -> index
           (gv (make-vector n))         ; index -> vertex
           (tv (make-vector n #f))      ; index -> times
           (pv (make-vector n #f))      ; index -> predecessor :unused
           (xl '()))
    (letrec
        ((next-t (let ((t 0)) (lambda () (set! t (+ 1 t)) t)))
         (visit (lambda (k)
                  (vector-set! tv k (cons (next-t) #f))
                  (let loop ((l (cdr (vector-ref gv k))))
                    (if (not (null? l))
                        (let ((ix (hashq-ref ht (car l))))
                          (unless (vector-ref tv ix)
                                  (fmtout "set-pv! ~a ~a" ix k)
                                  (vector-set! pv ix k)
                                  (visit ix))
                          (loop (cdr l)))))
                  (set! xl (cons k xl))
                  (set-cdr! (vector-ref tv k) (next-t)))))
      ;; Set up hash of vertex to index.
      (do ((i 0 (+ i 1)) (l graph (cdr l))) ((= i n))
        (vector-set! gv i (car l)) ; (vector-ref gv i) = (list-ref graph i)
        (hashq-set! ht (caar l) i)) ; (hash-ref ht (list-ref graph i)) = i
      ;; Run through vertices.
      (do ((i 0 (+ 1 i))) ((= i n))
        (unless (vector-ref tv i) (visit i)))
      (values ht gv tv xl))))

;; @deffn tzort dag
;; Given DAG return order of nodes.  The DAG is provided as list of:
;; (<node> <priors>)
;; ref: D.E.Knuth - The Art of C.P., Vol I, Sec 2.2.3
(define (tzort dag)
  (let* ((n (length dag))
         (ht (make-hash-table n))       ; node -> ix
         (nv (make-vector n #f))        ; ix -> (node . adj-list)
         (cv (make-vector n 0))         ; ix -> count
         (incr (lambda (ix) (vector-set! cv ix (+ (vector-ref cv ix) 1))))
         (decr (lambda (ix) (vector-set! cv ix (- (vector-ref cv ix) 1)))))
    ;; Set up ht and nv.
    (do ((i 0 (+ i 1)) (l dag (cdr l))) ((= n i))
      (vector-set! nv i (car l))
      (hashq-set! ht (caar l) i))
    ;; set up cv
    (do ((i 0 (+ i 1))) ((= n i))
      (for-each (lambda (n) (incr (hashq-ref ht n)))
                (cdr (vector-ref nv i))))
    ;; Iterate through nodes until cv all zero.
    (let loop1 ((ol '()) (uh '())       ; ordered list, unordered head 
                (ut (let r ((l '()) (x 0)) ; unordered tail
                      (if (= x n) l (r (cons x l) (+ x 1))))))
      (cond
       ((null? ut)
        (if (null? uh) 
            (reverse (map (lambda (e) (car (vector-ref nv e))) ol))
            (loop1 ol '() uh)))
       (else
        (let* ((ix (car ut)))
          (if (zero? (vector-ref cv ix))
              (loop1
               (let loop2 ((l (cdr (vector-ref nv ix))))
                     (if (null? l) (cons ix ol)
                         (begin
                           (decr (hashq-ref ht (car l)))
                           (loop2 (cdr l)))))
               uh
               (cdr ut))
              (loop1 ol (cons ix uh) (cdr ut)))))))))

;;; --- last line ---
