;;; -*- Mode:LISP; Package:USER; Readtable:CL; Base:10 -*-

;;; COPYRIGHT.LISP

;;; Puts out (almost-)formatted copyright pages for Gigamos manuals.

;;; Do SAVE-COPYR then INDENT-COPYR to save all/selected copyright pages
;;; Print the file output by INDENT-COPYR

(defvar *default-copyr-directory* "it:keith.release-3;")

(defvar *docs*
	'((3odm  :author "Janet E. Ressler"
		:contents "ODM, the Lambda On-Line Document Manager utility"
		:partno 3142-0000)
	  (3sited :contents "the Site Data Editor"
		 :trademarks (unix vax/vms pdp decsystem-20 ti855 toshiba imagen)
		 :partno 3239-0000)
	  (3fonted :contents "the Font Editor utility"
		  :trademarks (helvetica "Times Roman")
		  :partno 3141-0000)
	  (3tape :contents "the Lambda tape software facilities"
		:author "Meryl Cohen, Dave Goodine"
		:trademarks (unix)
		:partno 3138-0000)
	  (3printer :contents "the Lambda printer software facilities"
		   :author "Meryl Cohen, George Carrette"
		   :trademarks (ti855 toshiba unix vax vms ("IDS Paper Tiger" "IDS"))
		   :partno 2202-0000)
	  (3bugs :contents "software bugs and limitations known at the time of release"
		:author "Meryl Cohen"
		:trademarks (unix)
		:partno 3075-0000)
	  (3notes :contents "new software features and changes"
		  :author "Robert J.P. Ingria and Meryl Cohen"
		  :trademarks (unix vms)
		  :partno 2921-0000)
	  (3ops :contents "Lambda operating, management, and software installation procedures"
	       :product "Lambda ZetaLISP-Plus / UNIX NuSystem 5"
	       :trademarks
	       ("LMI Lambda/Plus" "LMI Lambda/2x2" "LMI Lambda/2x2/Plus" "LMI Lambda/3x3"
		unix ethernet multibus nubus)
	       :partno 3149-0000)
	  (3obj-user :contents "ObjectLISP, an object-oriented programming tool created by Gary L. Drescher"
		    :author "Janet Ressler"
		    :trademarks (objectlisp)
		    :partno 3057-0000)
	  (3obj-notes :contents "release information for ObjectLISP"
		     :author "Janet Ressler"
		     :trademarks (objectlisp)
		     :partno 3240-0000)
	  (3patch :contents "release and installation information for the ZetaLISP-Plus 3.1 patch update"
		  :accompanies
		  "the 3.1 Patch Update Distribution tape with Gigamos/LMI part number 3328-0000 (rev A)"
		  :author "Keith Corbett, Robert Putnam"
		  :release "Release 3.1"
		  :partno 3329-0000
		  :copyrights 1987)
	  (3tcp-user :product "Lambda ZetaLISP-Plus TCP/IP"
		     :partno 3167-0000
		     :contents "usage procedures for TCP/IP"
		     :trademarks (UNIX EXOS/EXCELAN IBM-PC ETHERNET))
	  (3tcp-notes :product "Lambda ZetaLISP-Plus TCP/IP"
		      :partno 3168-0000
		      :contents "release information and installation procedures for TCP/IP"
		      :trademarks (unix exos/excelan vax/vms pdp imagen explorer symbolics multibus ethernet 3com))
	  (3vista-lib-instl :product "Lambda ZetaLISP-Plus Vista Graphics"
			    :partno 3232-0000
			    :contents "the installation procedure for the Vista Library (a subset of Vista)")
	  (3iris-notes :product "Lambda ZetaLISP-Plus Iris Graphics"
		       :partno 3233-0000
		       :contents "release and installation information for Iris interface software")
	  (3vista-instl :product "Lambda ZetaLISP-Plus Vista Graphics"
			:partno 3235-0000
			:contents "the installation procedure for Vista graphics")
	  (3vista-user :product "Lambda ZetaLISP-Plus Vista Graphics"
		       :partno 3272-0000
		       :author "Peter Cann, Janet Ressler, and Mike Grandfield"
		       :contents "the Vista Visobs object-oriented graphics system")
	  (3vista-notes :product "Lambda ZetaLISP-Plus Vista Graphics"
			:partno 3273-0000
			:author "Peter Cann and Janet Ressler"
			:contents "release information for Vista Graphics")
	  (3vista-lib-user :product "Lambda ZetaLISP-Plus Vista Graphics"
			   :partno 3276-0000
			   :author "Peter Cann, Janet Ressler, and Ed Hardebeck"
			   :contents "the Vista Graphics function library")
	  (3lplus :product "Lambda Laser1-Plus Printer Interface"
		  :partno 3300-0000
		  :contents "the installation procedure for the Laser1-Plus printer driver")
	  ))


(setq *docs*
      (sort *docs* 'string-lessp
      :key #'(lambda(l)
	       (or (get l :partno) ""))))

(defparameter *address*
	      '("Gigamos Systems Inc."
		"650 Suffolk St."
		"Lowell, MA    01854"
		" Attn: Documentation"))

(defvar *tms*
	'(("ObjectLISP")
	  ("ZetaLISP-Plus")
	  (UNIX "American Telephone & Telegraph")
	  (VAX/VMS "Digital Equipment Corporation")
	  (VAX "Digital Equipment Corporation")
	  (VMS "Digital Equipment Corporation")
	  (PDP "Digital Equipment Corporation")
	  (DECSYSTEM-20  "Digital Equipment Corporation")
	  (TI855 "Texas Instruments Corp.")
	  ("Toshiba" "Toshiba Inc.")
	  ("Imagen" "the Imagen Corp.")
	  ("Helvetica" "Allied Corp.")
	  ("Times Roman" "Allied Corp.")
	  ("Ethernet" "Xerox Corp.")
	  ("Multibus" "Intel Corp.")
	  ("Explorer" "Texas Instruments Corp.")
	  ("NuBus" "Texas Instruments Corp.")
	  ("EXOS/Excelan" "Excelan")
	  ("3Com" "3Com Corp.")
	  ("Symbolics" "Symbolics Inc.")
	  (IBM-PC "International Business Machines")))

(defvar *default-owner* "Gigamos Systems Inc.")

(defun string-lines(str)
  (unless (listp str)
      (setq str (coerce str 'list)))
  (when str
    (do((s str (cdr s))
	(s2 nil))
       ((or (null s)(char-equal (car s) #\newline))
	(cons (string-append (coerce (reverse s2) 'string)
			     #\newline)
	      (string-lines (cdr s))))
      (push (car s) s2))))
    
(defun indent-within(str &optional (indent 4))
  (apply #'string-append
	 (mapcar #'(lambda(s)
		     (if (greaterp (string-length s))
			 (string-append (make-string indent
						     :initial-element #\space)
					s)
		       s))
		 (string-lines str))))

(defun fill-within (width str)
  (let((len (string-length str))
       pos)
  (cond
    ((string-equal (string-trim " " str) "") "")
    ((setq pos (position #\newline str))
     (cond
       ((equal pos len)
	(string-append
	  (fill-within width (subseq str 0 pos))
	  #\newline))
       ((zerop pos)
	(string-append #\newline
		       (fill-within width (subseq str 1))))
       ((char-equal (char str (1+ pos)) #\newline) ;paragraph
	 (string-append
	   (fill-within width (subseq str 0 pos))
	   #\newline
	   (fill-within width (subseq str (1+ pos)))))
       (t (fill-within width
		       (string-append (subseq str 0 pos)
				      #\space
				      (subseq str (1+ pos)))))))
    ((<= len width) str)
    ((setq pos (position #\space str :end width :from-end t))
     (string-append (subseq str 0 pos)
		    #\newline
		    (fill-within width
				 (string-left-trim #\space (subseq str pos)))))
    ((setq pos (position #\space str))
     (string-append
	 (subseq str 0 pos)
	 #\newline
	 (fill-within width
		      (string-left-trim #\space (subseq str pos)))))
    (t str))))

(defun copyr-page(&key
		  (title nil)
		  (author nil)
		  (contents nil)
		  (accompanies nil)
		  (product "Lambda ZetaLISP-Plus")
		  (release "Release 3.0")
		  (default-owner *default-owner*)
		  (default-trademarks '("LMI Lambda" "ZetaLISP-Plus"))
		  trademarks
		  release-date
		  (copyrights '(1986 1987))
		  (width 72)
		  partno)
  (let((s standard-output)
       (tm-notices
	    (loop for tms in (append default-trademarks
				   trademarks)
		  as tm = (if (listp tms) (car tms) tms)
		  as info = (assoc tm *tms* :test #'string-equal)
		  as mark = (or (car info) tm)
		  as holder = (if (listp tms) (cadr tms)
				(or (cadr info) default-owner))
		  when tm
		  collect (list mark holder))))
    (format s "~3%")
    (format s "~:[~;~%Title:           ~:*~a~]" title)
    (format s "~:[~;~%Part Number:     ~:*~a~]" partno)
    (format s "~:[~;~%Product/Release: ~:*~a ~a~]" product release)
    (format s "~:[~;~%Release Date:    ~:*~a~]" release-date)
    (format s "~:[~;~%Contributing:    ~:*~a~]" author)
    (format s "~2%~~v,,,'_a~{~a~}~" width "")
    (when (or contents accompanies)
      (format s "~2%~a"
		(fill-within
			width
			(string-append
			  (format nil "~@[This document covers ~a. ~]" contents)
			  (format nil "~:[~;~:[This document~;It~] accompanies ~a.~]"
				  accompanies contents accompanies)))))
    (format s "~3%Please direct comments and inquiries to:")
    (format s "~%~{~%~5t~a~}~2%" *address*)
    (format s "~2%~v,,,'_a~3%" width "")
    (format s "~2%~:[~3%~]~:[~3%~]~v%"
	    contents accompanies
	    (max 0 (- 12 (length tm-notices))))
    (when tm-notices
	(format s "~%Trademark notice~P:" (length tm-notices))
	(format s "~{~%~3t~{- ~a(tm) is a trademark of ~a~}~}"
		tm-notices))
    (format s "~@[~3%Copyright (c) ~a ~a~@[, rev. ~{~a ~}~]~]"
	    (if (listp copyrights) (car copyrights) copyrights)
	    default-owner
	    (if (listp copyrights) (cdr copyrights)))
    (format s "~%")
    t))

(defun copyr-doc(doc)
  (let((args (cdr (assoc doc *docs*))))
    (if args
	(apply #'copyr-page args)
      (format query-io "~%No document definition for ~s" doc))))

(defun copyr-docs(&optional docnames)
  (unless docnames (setq docnames (mapcar #'car *docs*)))
  (do*((docs docnames (cdr docs))
       (doc (car docs) (car docs)))
      ((null docs))
    (copyr-doc doc)
    (when (cdr docs)
      (format standard-output "More>")
      (tyi))))

(defun save-copyr(&optional docnames (pathname *default-copyr-directory*))
  (unless docnames (setq docnames (mapcar #'car *docs*)))
  (dolist (doc docnames)
    (with-open-file
      (standard-output (make-pathname
			 :defaults pathname
			 :name (string-append "COPYR-" doc)
			 :type (or (pathname-type pathname)
				   :text))
		       :direction :output)
      (copyr-doc doc))))

(defun indent-copyr(&optional docnames (indent 4) filename
		    &aux
		    (ind (make-string indent :initial-element #\space))
		    (outputfile
		      (merge-pathnames (or filename "copyr-pages.text")
				       *default-copyr-directory*)))
  (unless docnames (setq docnames (mapcar #'car *docs*)))
  (when docnames
    (with-open-file(out outputfile :direction :output)
      (do*((docs docnames (cdr docs))
	   (doc (car docs) (car docs)))
	  ((null docs))
      (with-open-file(in (make-pathname
			   :defaults filename
			   :name (string-append "COPYR-" doc)
			   :type :text))
	(do((line (readline in :eof) (readline in :eof)))
	   ((eq line :eof))
	  (send out :line-out
		(string-append
		  (if (zerop(string-length line))
		      "" ind)
		  line))))
      (when (cdr docs)
	(format out "~|"))))
    outputfile))