cpsa-2.2.12: src/cpsaperm.scm
#!/usr/bin/guile \
-e main -s
!#
(use-modules (ice-9 pretty-print))
;;; For an R6RS script, add an import statement.
;;; Synopsis: renumber strands in skeletons
;;; A permutation of length n is represented as a list of natural
;;; numbers that contains all the numbers less than n.
;;; This program renumbers all the skeletons in a file that have the
;;; same number of strands as is the length of the permutation.
;;; Everything else is passed through unchanged.
;;; Usage: cpsaperm [-h] [-o FILE] FILE INT...
;;; where INT... specifies a permutation.
;;; Use - in place of FILE for the standard port
;;; Example: cpsaperm -o out.txt in.txt 1 0
;;; Swaps the strands in skeletons with two strands.
;;; This program does not check that the given permutation is in fact
;;; a valid permutation, so be sure to check your output carefully.
;;; Make sure your permutation has no repeats.
;;; John D. Ramsdell -- October 2012
;;; Create a function that applies a permutation to a form
(define (apply-perm perm)
(let ((n (length perm)))
(lambda (form)
(let ((skel (parse-skel form)))
(cond ((not skel) form) ; Ignore non-skeletons
;; Ignore skeletons with the wrong number of strands
((not (= n (length (skel-strands skel)))) form)
(else
(let ((skel (apply-perm-to-skel perm skel)))
`(defskeleton
,(skel-protocol skel)
,(skel-vars skel)
,@(append (skel-strands skel) (skel-alist skel))))))))))
;;; A skeleton is represented as list with the following fields.
(define (skel-protocol skel) (car skel))
(define (skel-vars skel) (cadr skel))
(define (skel-strands skel) (caddr skel))
(define (skel-alist skel) (cdddr skel))
(define (make-skel protocol vars strands alist)
(cons protocol (cons vars (cons strands alist))))
;;; Creates a skeleton structure or returns #f on error.
(define (parse-skel form)
(and (skel? form)
(let loop ((body (cdddr form)) (strands '()))
(cond ((null? body)
(make-skel (cadr form) (caddr form)
(reverse strands) body))
((or (eq? 'defstrand (caar body))
(eq? 'deflistener (caar body)))
(loop (cdr body) (cons (car body) strands)))
(else
(make-skel (cadr form) (caddr form)
(reverse strands) body))))))
;;; Is form a defskeleton
(define (skel? form)
(and (list? form)
(<= 4 (length form))
(eq? 'defskeleton (car form))
(alist? (cddr form))))
(define (alist? form) ; Is form a list of pairs?
(or (null? form)
(and (pair? form)
(pair? (car form))
(alist? (cdr form)))))
;;; To apply a permutation to a skeleton, permute the strands and the
;;; node orderings.
(define (apply-perm-to-skel perm skel)
(let ((strands (skel-strands skel)))
(make-skel
(skel-protocol skel)
(skel-vars skel)
(map (lambda (index)
(list-ref strands index))
perm)
(map (apply-perm-to-alist perm) (skel-alist skel)))))
;;; Apply a permutation to the node orderings
(define (apply-perm-to-alist perm)
(lambda (entry)
(if (eq? (car entry) 'precedes)
(cons (car entry)
(map (apply-perm-to-pair perm) (cdr entry)))
entry)))
(define (apply-perm-to-pair perm)
(lambda (ordered-pair)
(if (and (list? ordered-pair) (= 2 (length ordered-pair)))
(list (apply-perm-to-node perm (car ordered-pair))
(apply-perm-to-node perm (cadr ordered-pair)))
ordered-pair)))
(define (apply-perm-to-node perm node)
(if (and (list? node) (= 2 (length node)))
(list (list-ref perm (car node)) (cadr node))
node))
;;; The main driver loop and command-line processing
;;; The main loop calls the transformer on each S-expression read from
;;; the current input.
(define (filter perm)
(let ((transformer (apply-perm perm)))
(lambda ()
(do ((form (read) (read)))
((eof-object? form))
(pretty-print (transformer form))))))
;;; A file description is #f for the standard port, or a file name
;;; that is a non-empty string that does not start with hyphen.
(define (file-description? file)
(or (not file)
(and (> (string-length file) 0)
(not (char=? #\- (string-ref file 0))))))
;;; After command-line processing, this routine opens files as needed.
(define (go input output perm)
(let ((thunk (filter perm)))
(cond ((not (file-description? input))
(display-error "bad input file name"))
((not (file-description? output))
(display-error "bad output file name"))
(input
(with-input-from-file input
(lambda ()
(if output
(with-output-to-file output thunk)
(thunk)))))
(output
(with-output-to-file output thunk))
(else
(thunk)))))
;;; Parse command-line arguments and pass the result to the go function.
(define (main args)
(let loop ((args (cdr args)) (output #f))
(cond ((null? args) ; No input file specified
(display-error "bad args"))
((string=? (car args) "-h")
(display-help)) ; Print help message
((string=? (car args) "-o")
(if (null? (cdr args))
(display-error "bad args")
(loop (cddr args) (cadr args)))) ; Found an output file
((string=? (car args) "-")
(check-perm #f output (cdr args)))
(else ; Found input file
(check-perm (car args) output (cdr args))))))
;;; Make sure a permutation is a list of non-negative integers less
;;; that the length of the permutation.
(define (check-perm input output args)
(let ((n (length args)))
(let loop ((args args) (perm '()))
(if (null? args)
(go input output (reverse perm))
(let ((index (string->number (car args))))
(if (and (integer? index)
(not (negative? index))
(< index n))
(loop (cdr args) (cons index perm))
(display-error "bad permutation")))))))
(define (display-help)
(display-error "cpsaperm [-h] [-o FILE] FILE INT...")
(display-error "where INT... specifies a permutation.")
(display-error "Use - as FILE for the standard input."))
(define (display-error obj)
(display obj (current-error-port))
(newline (current-error-port)))
;;; For an R6RS script, add the following:
;;; (main (command-line))