#!/usr/bin/guile \
-e "(scripts bit-field-diagram)" -s
!#
;;; bit-field-diagram --- Display bit-field diagrams in different ways

;; 	Copyright (C) 2002,2003,2004 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: bit-field-diagram [--file FILE | BITSPEC]
;;
;; Display a bit field diagram representing BITSPEC.  Option `--file'
;; means read the bitspec from FILE.  A BITSPEC is a Scheme list of
;; the form:
;;
;;   (CONFIGURATION* [FIELD-SPEC...])
;;
;; CONFIGURATION is an optionally-omitted list with car #:config
;; followed by CONFIG-SPEC forms, described below.  FIELD-SPEC is a
;; list (NAME WIDTH), where NAME is a symbol or string, and WIDTH an
;; integer.
;;
;; For example:
;; $ guile-tools bit-field-diagram "((hello 5) (there 10))"
;;  hello     there
;; +---------+-------------------+
;; | | | | | | | | | | | | | | | |
;; +---------+-------------------+
;;
;; Specifying CONFIG-SPEC forms, each a keyword/value pair, changes
;; the appearance of the output.  Currently supported:
;;
;;   #:columns-per-bit       2       this includes a bar "|"
;;   #:suppress-sep-bars     #f      omit internal "|"
;;   #:field-name-justify    #:left  can also be #:right
;;   #:field-name-placement  #:over  can also be #:internal or #:under
;;   #:height                1       lines for the body of the field
;;   #:group                 #f      number of bits in a group, or #f
;;   #:merge-group-borders?  #f      merge internal borders
;;
;; When #:merge-group-borders? is set, #:field-name-placement must be
;; #:internal, otherwise an error is signalled.  A #:field-name-placement
;; of #:internal automatically sets #:suppress-sep-bars.  When #:group is
;; specified, an error is signalled if the fields do not align to it.
;;
;; Here is a more complicated example.  This form is placed in a file:
;;
;;   ((#:config (#:columns-per-bit . 3)
;;              (#:field-name-justify . #:right)
;;              (#:field-name-placement . #:internal)
;;              (#:height . 3)
;;              (#:group . 16)
;;              (#:merge-group-borders? . #t))
;;    (hello 6)
;;    (there 10)
;;    (how 2)
;;    (are 3)
;;    (you 8)
;;    (doing 3)
;;    ("well i hope?" 11))
;;
;; The result is:
;;
;;   +-----------------+-----------------------------+
;;   |            hello|                        there|
;;   |                 |                             |
;;   |                 |                             |
;;   +-----+--------+--+--------------------+--------+
;;   |  how|     are|                    you|   doing|
;;   |     |        |                       |        |
;;   |     |        |                       |        |
;;   +-----+--------+-----------------+-----+--------+
;;   |                    well i hope?|
;;   |                                |
;;   |                                |
;;   +--------------------------------+
;;
;;
;; Usage from a Scheme program:
;;
;;   (bit-field-diagram out spec/port)
;;
;; OUT specifies where to write the output.  OUT #f means return a
;; string, otherwise the return value is unspecified.  SPEC/PORT is
;; either a BITSPEC sexp or a port where a BITSPEC can be `read'.
;;
;;
;; TODO: Support #:group-justify, #:border-style, #:bit-numbering,
;;               #:endian, per-group #:prefix and #:suffix, etc. etc.

;;; Code:

(define-module (scripts bit-field-diagram)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:use-module (ice-9 format)
  #:export (bit-field-diagram))

(define name:  car)
(define width: cadr)

(define *default-config*
  '((#:columns-per-bit . 2)
    (#:suppress-sep-bars . #f)
    (#:field-name-justify . #:left)
    (#:field-name-placement . #:over)
    (#:height . 1)
    (#:group . #f)
    (#:merge-group-borders? . #f)))

(define (default-config)
  (map (lambda (x)
         (cons (car x) (cdr x)))
       *default-config*))

(define (bf-description<-port/spec port/spec)
  (let ((cfg (default-config))
        (raw (if (port? port/spec)
                 (read port/spec)
                 port/spec)))
    (cond ((and (pair? raw) (pair? (car raw))
                (eq? #:config (caar raw))
                (cdar raw))
           => (lambda (overrides)
                (set! raw (cdr raw))
                (for-each (lambda (pair)
                            (assq-set! cfg (car pair) (cdr pair)))
                          overrides))))
    (cons cfg raw)))

(define (>>plus-dash-1 out mult widths)
  (format out "+~:{~V,,,'-A+~}\n"
          (map (lambda (w)
                 (list (1- (* mult w)) ""))
               widths)))

(define (>>space-space-1 out mult widths)
  (format out "|~:{~VA|~}\n"
          (map (lambda (w)
                 (list (1- (* mult w)) ""))
               widths)))

(define (>>bar-space-1 out mult widths)
  (format out "|~{~A|~}\n"
          (make-list (apply + widths)
                     (make-string (1- mult) #\space))))

(define (merge-widths ls-1 ls-2)
  (define (as-cols ls)
    (let loop ((ls ls) (acc (list 0)))
      (if (null? ls)
          (cdr (reverse! acc))
          (loop (cdr ls) (cons (+ (car ls) (car acc)) acc)))))
  (let loop ((ls (sort (append! (as-cols ls-1) (as-cols ls-2)) <))
             (prev-head 0)
             (acc '()))
    (if (null? ls)
        (reverse! acc)                  ; rv
        (let* ((head (car ls))
               (tail (cdr ls))
               (skip? (and (pair? tail) (= head (car tail)))))
          (loop tail
                (if skip? prev-head head)
                (if skip? acc (cons (- head prev-head) acc)))))))

(define (bit-field-diagram out port/spec)
  (let* ((return (lambda () (flush-all-ports) (if #f #f)))
         (bf-description (bf-description<-port/spec port/spec))
         (config (car bf-description))
         (C      (lambda (key) (assq-ref config key)))
         (fspecs (cdr bf-description))
         (cols/b (C #:columns-per-bit))
         (name-placement (C #:field-name-placement))
         (name-delim (if (eq? #:internal name-placement) "|" " "))
         (field-name-format (string-append
                             name-delim "~:{~V"
                             (case (C #:field-name-justify)
                               ((#:left) "")
                               ((#:right) "@")
                               (else ""))
                             "A" name-delim "~}\n"))
         (groups #f)
         (merge-borders? (C #:merge-group-borders?)))
    ;; sanity checks
    (and merge-borders?
         (not (eq? #:internal name-placement))
         (error (simple-format #f "incompatible: ~A and ~A ~A"
                               #:merge-group-borders?
                               #:field-name-placement
                               name-placement)))
    ;; check grouping
    (cond ((C #:group)
           => (lambda (n)
                (let loop ((ls fspecs) (partial 0) (acc '()))
                  (if (null? ls)
                      (or (null? acc)
                          (set! groups (cons (reverse! acc) groups)))
                      (let* ((head (car ls))
                             (one (width: head))
                             (so-far (+ one partial)))
                        (cond ((< so-far n)
                               (loop (cdr ls) so-far (cons head acc)))
                              ((= so-far n)
                               (set! groups (cons (reverse! (cons head acc))
                                                  (or groups '())))
                               (loop (cdr ls) 0 '()))
                              (else
                               (error "cannot group:" head)))))))))
    ;; do it!
    (or out (begin (set! out (open-output-string))
                   (set! return (lambda ()
                                  (let ((rv (get-output-string out)))
                                    (close-port out)
                                    rv)))))
    (let loop ((ls (if groups (reverse! groups) (list fspecs)))
               (prev-widths #f))
      (or (null? ls)
          (let* ((group (car ls))
                 (spread (map (lambda (pair)
                                (list (1- (* cols/b (width: pair)))
                                      (name: pair)))
                              group))
                 (widths (map width: group)))
            (and (eq? #:over name-placement)
                 (format out field-name-format spread))
            (>>plus-dash-1 out cols/b (if (and prev-widths merge-borders?)
                                          (merge-widths prev-widths widths)
                                          widths))
            (let* ((int? (eq? #:internal name-placement))
                   (style (if (or int? (C #:suppress-sep-bars))
                              >>space-space-1
                              >>bar-space-1)))
              (and int? (format out field-name-format spread))
              (let loop ((vpad (- (C #:height) (if int? 1 0))))
                (or (= 0 vpad)
                    (begin
                      (style out cols/b widths)
                      (loop (1- vpad))))))
            (and (or (not merge-borders?)
                     (null? (cdr ls)))
                 (>>plus-dash-1 out cols/b widths))
            (and (eq? #:under name-placement)
                 (format out field-name-format spread))
            (loop (cdr ls) widths))))
    (return)))

(define (main args)
  (HVQC-MAIN args (lambda (qop)
                    (bit-field-diagram
                     #t (or (qop 'file open-input-file)
                            (open-input-string (car (qop '())))))
                    #t)
             '(usage . commentary)
             '(package . "Guile")
             '(version . "2.0")
             `(option-spec (file (single-char #\f) (value #t)
                                 (predicate ,file-exists?)))))

;;; bit-field-diagram ends here
