mes/module/nyacc/util.scm

;;; nyacc/util.scm
;;;
;;; Copyright (C) 2014-2016 Matthew R. 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (nyacc util)
  #:export (
	    fmtstr fmtout fmterr fmt
	    wrap-action
	    obj->str
	    fixed-point prune-assoc
	    map-attr->vector
	    x-flip x-comb
	    write-vec
	    ugly-print
	    tzort
	    )
  #:use-module (ice-9 optargs)
  #:use-module ((srfi srfi-43) #:select (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)

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

;; @item wrap-action (n . guts) => `(lambda ($n ... $2 $1 . $rest) ,@guts)
;; Wrap user-specified action (body, as list) of n arguments in a lambda.
;; The rationale for the arglist format is that we can @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 iter ((al1 '()) (al0 al))
    (if (null? al0) al1
	(iter (if (assoc (caar al0) al1) al1 (cons (car al0) al1)) (cdr al0)))))

;; @deffn fixed-point proc seed
;; .item fixed-point-by-elt proc seed
;; @example
;; proc: element list -> list
;; @end example
;; proc will take an element and insert updates at the front of list
;; and return the list
;; seed is a list
;; fixed-point processes 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.
;; It 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
(define (fixed-point proc seed)
  ;; (let ((seed (if (null? seed) (fixed-point proc (proc seed '())))))
  (let iter ((prev '()) (item seed) (curr seed) (next seed))
    (cond
     ((not (eqv? item prev))
      (iter prev (cdr item) curr (proc (car item) next)))
     ((not (eqv? next curr))
      (iter curr next next next))
     (else
      curr))))

;; @deffn vector-fixed-point proc vec => vec
;; (proc vec) => chg (boolean)
;; Not used yet (in step3).
(define (vector-fixed-point proc vec)
  (let iter ((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 iter ((result '()) (tail (cdr al)))
    (if (null? tail) result
	(iter (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 iter ((res '()) (al a) (bl b))
    (cond
     ((null? al) res)
     ((pair? bl) (iter (acons (car al) (car bl) res) al (cdr bl)))
     ((pair? al) (iter res (cdr al) b)))))

(define (write-vec port vec)
  (let* ((nv (vector-length vec)))
    (fmt port "  #(")
    (let iter ((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)
	      (iter (+ 4 leng) (1+ ix)))
	     (else
	      (fmt port "~A" stng)
	      (iter (+ col leng) (1+ ix)))))))
    (fmt port ")")))


;; @deffn ugly-print sexp [#:indent 4] [#:extent 78] [#:port port]
;; This will print in compact form which shows no structure.
(define* (ugly-print sexp #:optional port #:key (indent 4) (extent 78))

  (define (obj->str obj)
    (simple-format #f "~S" obj))

  ;; @deffn make-strout indent extent port
  ;; This will generate a procedure of signature @code{(proc col str)} which
  ;; takes a column and string, prints the string and returns updated column.
  (define (make-strout ind ext port)
    (let ((leader (make-string ind #\space)))
      (lambda (col str)
	(let* ((len (string-length str)))
	  (cond
	   ((> (+ col len) ext)
	    (newline port)
	    (display leader port)
	    (unless (string-every #\space str) (display str port))
	    (+ ind len))
	   (else
	    (display str port)
	    (+ col len)))))))

  (letrec ((out-p (or port (current-output-port)))
	   (leader (make-string 2 #\space))
	   (strout (make-strout indent extent out-p))

	   (iter1
	    (lambda (col sx)
	      (cond
	       ((pair? sx) (strout (iter2 (strout col "(") sx) ")"))
	       ((vector? sx)
		(strout
		 (vector-fold
		  (lambda (ix col elt)
		    (iter1 (if (zero? ix) col (strout col " ")) elt))
		  (strout col "#(") sx) ")"))
	       (else (strout col (obj->str sx))))))
	   
	   (iter2
	    (lambda (col sx)
	      (cond
	       ((pair? sx)
		(if (null? (cdr sx))
		    (iter2 (iter1 col (car sx)) (cdr sx))
		    (iter2 (strout (iter1 col (car sx)) " ") (cdr sx))))
	       ((null? sx) col)
	       (else (strout (strout col ". ") (obj->str sx))))))
	   )
    ;;(simple-format out-p leader)
    (iter1 (if (pair? sexp) (strout indent "'") indent) sexp)
    ;;(iter1 indent sexp)
    ;;(newline out-p)
    ))

;; stuff

;; @deffn 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
(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 iter ((l (cdr (vector-ref gv k))))
		    (if (not (null? l))
			(let ((ix (hashq-ref ht (car l))))
			  (unless (vector-ref tv ix)
				  (pp 0 "set-pv! ~a ~a" ix k)
				  (vector-set! pv ix k)
				  (visit ix))
			  (iter (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 iter1 ((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))
	    (iter1 ol '() uh)))
       (else
	(let* ((ix (car ut)))
	  (if (zero? (vector-ref cv ix))
	      (iter1
	       (let iter2 ((l (cdr (vector-ref nv ix))))
		     (if (null? l) (cons ix ol)
			 (begin
			   (decr (hashq-ref ht (car l)))
			   (iter2 (cdr l)))))
	       uh
	       (cdr ut))
	      (iter1 ol (cons ix uh) (cdr ut)))))))))

;;; --- last line ---