option.lsp
 Version 1.00 31 October 2004
 Author Steven Jones

 Contact jones57@swbell.net include the word "nyquist" in subject line

 The contents of this file are released under the terms of the GNU General
 Public License. See the file LICENSE.txt

 Query user to make a selection.

function

 (option opts [head])
 Present user with list of options and wait from response.

 opts   - list. List of user options. The options are enumerated from 0 up.
 head   - String. Text to be displayed at top of menu.
 return - integer. The user's selection.

function

 (warning [msg1 [msg2 [msg3 ...]]])
 Display warning message, wait for users reaction.
 All arguments are optional, converted to strings, and used as waring
 message.  The user options are:
 1 - Abort, throw an error and return to XLISP prompt
 2 - Ignore this time and continue.
 3 - Ignore message this time and in the future. 
 Note several global flags effect the operation of warning:
 warning:*log* 
 warning:*ignore*
 warning:*force*

function

 (assert   expr [args...])
 If expr is false produce error
 
 expr   - Bool. 
          If expr is nil an error is produced.
          If expr is true, nothing happens.
 args   - Any. An arbitrary number of arguments which serve as the error 
          message text. Default "Assertion Error"

;; option.lsp
;; Version 1.00 31 October 2004
;; Author Steven Jones
;;
;; Contact jones57@swbell.net include the word "nyquist" in subject line
;;
;; The contents of this file are released under the terms of the GNU General
;; Public License. See the file LICENSE.txt
;;
;; Query user to make a selection.
;;

(current-file "option")
(provide 'option)


;; Used by option to generate menu text.
;;

(defun option:enumerate (lst)
  (let ((acc ""))
    (dotimes (n (length lst))
      (setf acc (strcat acc (format nil "~a   - ~a~%" n (nth n lst)))))
    acc))


;; @doc function option 
;; (option opts [head])
;; Present user with list of options and wait from response.
;;
;; opts   - list. List of user options. The options are enumerated from 0 up.
;; head   - String. Text to be displayed at top of menu.
;; return - integer. The user's selection.
;; 

(defun option (opts &optional (head ""))
  (let ((menu (option:enumerate opts))
	(prompt (format nil "Select option (0 - ~a)  ? " (- (length opts) 1))))
    (gc-reset)
    (gc)
    (format t "~a~%" head)
    (format t "~a~%" menu)
    (do ((result nil))
	((and result (>= result 0)(< result (length opts)))  result)
      (format t "~%~a" prompt)
      (setq result (read)))))


;; **************************************************************************
;;				Warning System
;;
;; The warning system provides a means to alert user to conditions which are
;; less serious then an error. The user is provided with a menu of options:
;;
;; 0 - Throw an error
;; 1 - Ignore and continue
;; 2 - Ignore and if we see this warning again don't bother asking about it
;; 
;; **************************************************************************

(setq warning:*log-list*   '()
      warning:*log*         t
      warning:*ignore*      nil
      warning:*force*      nil)


;; Return true iff MSG is an element in warning:*log-list*
;;

(defun warning:previous-message-p  (MSG)
  (member (format nil "~a" MSG) warning:*log-list* :test #'string=))


;; Add message msg to *log-list* IF it is not already an element of the list
;; and the *log* flag is true.
;;

(defun warning:log-message (msg)
  (if (and warning:*log* (not (warning:previous-message-p msg)))
      (setf warning:*log-list* (cons (format nil "~a" msg) warning:*log-list*))))


(defun warning:prompt  (msg-list)
  (format t "~%")
  (let* ((bar "WARNING: ******************************************************************\n")
	 (head "WARNING: *** ")
	 (acc bar)
	 (user NIL))
    (dolist (el msg-list)
      (setf acc (strcat acc (format nil "~a~a~%" head el))))
    (setf acc (strcat acc bar))
    (format t "~a~%" acc)
    (setf user (option (list (list "Throw Error ")
			     (list "Ignore this time")
			     (list "Ignore always"))))
    (cond ((= user 0)(error "Aborted"))
	  ((= user 1) nil)
	  (t (warning:log-message (car msg-list))))))


;; @doc function  warning 
;; (warning [msg1 [msg2 [msg3 ...]]])
;; Display warning message, wait for users reaction.
;; All arguments are optional, converted to strings, and used as waring
;; message.  The user options are:
;; 1 - Abort, throw an error and return to XLISP prompt
;; 2 - Ignore this time and continue.
;; 3 - Ignore message this time and in the future. 
;; Note several global flags effect the operation of warning:
;; warning:*log* 
;; warning:*ignore*
;; warning:*force*
;;

(defun warning (&rest msg)
  (if (or warning:*force* (not (or warning:*ignore* (warning:previous-message-p (car msg)))))
      (warning:prompt msg)))


;; @doc function assert
;; (assert   expr [args...])
;; If expr is false produce error
;; 
;; expr   - Bool. 
;;          If expr is nil an error is produced.
;;          If expr is true, nothing happens.
;; args   - Any. An arbitrary number of arguments which serve as the error 
;;          message text. Default "Assertion Error"
;;

(defun assert (flag &rest args)
  (if (not flag)
      (error (->string (or args "Assertion Error")))))