Loading .DS_Store 0 → 100755 +12 KiB File added.No diff preview for this file type. View file README 0 → 100644 +24 −0 Original line number Diff line number Diff line cl-menusystem, a third release This is cl-menusystem as of 9/14/2003, its third release. It's now usable for a wider variety of tasks - the file DOCUMENTATION and the example in test.lisp should help you get started. To use it, load the supplied .asd one way or another. You should also be able to use asdf-install to install it. Read the file test.lisp to get an example of how to define a menu. To run that menu (once test.lisp has been loaded) try: (cl-menusystem:do-menu cl-menusystem-test:*test-menu* *standard-output* *standard-input*) Note that some of the classes specified in inputable.lisp are left unimplemented in tty-interface.lisp - I'll add features as I need them. If other people actually start using this I may be inclined to take feature requests too. :-) This source code has been placed into the public domain. Brian Mastenbrook bmastenb@cs.indiana.edu http://www.cs.indiana.edu/~bmastenb/ No newline at end of file cl-menusystem.lisp 0 → 100644 +42 −0 Original line number Diff line number Diff line ;;;; cl-menusystem.lisp ;;; I wasn't sure where to put the defpackage. (defpackage #:cl-menusystem (:use #:common-lisp) (:export ;; presentable.lisp #:presentable #:presentable-description #:extended-help #:present-object #:display-object #:display-object-briefly #:request-object #:simple-format-message ;; menus.lisp #:menu #:presentables #:menu-tag ;; inputable.lisp #:inputable #:current-state #:instance-valid-input-predicate #:valid-inputable-state-p #:integer-valued-inputable #:one-line-string-valued-inputable #:expression-valued-inputable #:flags-valued-inputable #:available-flags #:flag-descriptions ;; easy-menus.lisp #:*menu-output* #:*menu-input* #:make-menu #:defmenu #:menu-action #:make-menu-action #:do-menu #:make-state-presentable #:make-state-presentable-no-hiding #:request-one-line-string #:make-preference-menu)) easy-menus.lisp 0 → 100644 +152 −0 Original line number Diff line number Diff line ;;;; easy-menus.lisp - macros and classes which make the construction of menus easier (in-package #:cl-menusystem) (defvar *menu-output*) (defvar *menu-input*) (defmacro with-gensyms (names &body forms) `(let ,(mapcar #'(lambda (name) (list name '(gensym))) names) ,@forms)) (defmacro generate-do-menu-action (menu-object output-device input-device) (with-gensyms (start-entry previous-menu end-entry menu-object-name chosen current-state return-value v) `(let ((,menu-object-name ,menu-object) (*menu-output* ,output-device) (*menu-input* ,input-device) (,return-value nil)) (tagbody ,start-entry (let ((,current-state (cl-menusystem-sys:do-menu-loop ,menu-object-name *menu-output* *menu-input*))) (when (eql ,current-state (1+ (length (presentables ,menu-object-name)))) ; help was chosen (if (not (extended-help ,menu-object-name)) (simple-format-message *menu-output* "Please choose a valid option from the menu. (No extended help is available.)~&") (simple-format-message *menu-output* "~A~&" (extended-help ,menu-object-name))) (go ,start-entry)) (let ((,chosen (nth (1- ,current-state) (presentables ,menu-object-name)))) (cond ((typep ,chosen 'menu-action) (restart-case (progn (funcall (action ,chosen) ',previous-menu) (go ,start-entry)) (,previous-menu (&optional ,v) (setf ,return-value ,v) (go ,end-entry)))) ((typep ,chosen 'menu) (do-menu ,chosen *menu-output* *menu-input*) (go ,start-entry)) ((typep ,chosen 'inputable) (cl-menusystem-sys:do-inputable-loop ,chosen *menu-output* *menu-input*) (go ,start-entry)) ((typep ,chosen 'presentable) (display-object ,chosen *menu-output*) (go ,start-entry))))) ,end-entry) ,return-value))) (defclass easy-menu (cl-menusystem-sys:sys-menu) ((do-menu-action :initarg :do-menu-action :accessor do-menu-action))) (defmacro make-menu (description help &rest menu-items) `(make-instance 'easy-menu :presentable-description ,description :extended-help ,help :presentables (list ,@menu-items) :do-menu-action #'(lambda (menu-object object-device input-device) (generate-do-menu-action menu-object object-device input-device)))) (defmacro defmenu (name description help &rest menu-items) `(defparameter ,name (make-menu ,description ,help ,@menu-items))) (defclass menu-action (menu-tag) ((action :initarg :action :accessor action))) (defmacro make-menu-action (description help lambda-args &body lambda-form) (if (not (eql (length lambda-args) 1)) (error "lambda-args must be of length 1!")) `(make-instance 'menu-action :presentable-description ,description :extended-help ,help :action #'(lambda ,lambda-args ,@lambda-form))) (defun do-menu (menu-object output-device input-device) (funcall (do-menu-action menu-object) menu-object output-device input-device)) (defclass state-presentable (presentable) ((display-state-function :accessor display-state-function :initarg :display-state-function) (hide-state-p :accessor hide-state-p :initarg :hide-state-p :initform nil))) (defmethod display-object ((presentable-object state-presentable) output-device) (simple-format-message output-device "~A~&" (presentable-description presentable-object)) (simple-format-message output-device "~A~& "(funcall (display-state-function presentable-object)))) (defmethod display-object-briefly ((presentable-object state-presentable) output-device) (if (hide-state-p presentable-object) (simple-format-message output-device "State hidden for: ~A~&" (presentable-description presentable-object)) (simple-format-message output-device "~A: ~A~&" (presentable-description presentable-object) (funcall (display-state-function presentable-object))))) (defmacro make-state-presentable (description &body forms) `(make-instance 'state-presentable :presentable-description ,description :extended-help nil :hide-state-p t :display-state-function (lambda () ,@forms))) (defmacro make-state-presentable-no-hiding (description &body forms) `(make-instance 'state-presentable :presentable-description ,description :extended-help nil :hide-state-p nil :display-state-function (lambda () ,@forms))) (defun request-one-line-string (output-device input-device description &optional extended-help &key valid-test) (let ((foo (if valid-test (make-instance 'one-line-string-valued-inputable :presentable-description description :extended-help extended-help :instance-valid-input-predicate #'(lambda (i) (funcall valid-test (current-state i)))) (make-instance 'one-line-string-valued-inputable :presentable-description description :extended-help extended-help)))) (cl-menusystem-sys:do-inputable-loop foo output-device input-device))) (defun request-integer (output-device input-device description &optional extended-help &key valid-test) (let ((foo (if valid-test (make-instance 'integer-valued-inputable :presentable-description description :extended-help extended-help :instance-valid-input-predicate #'(lambda (i) (funcall valid-test (current-state i)))) (make-instance 'integer-valued-inputable :presentable-description description :extended-help extended-help)))) (cl-menusystem-sys:do-inputable-loop foo output-device input-device))) (defun request-expression (output-device input-device description &optional extended-help &key valid-test) (let ((foo (make-instance 'one-line-string-valued-inputable :presentable-description description :extended-help (format nil "Please enter an expression on one line.~%~%~A" extended-help) :instance-valid-input-predicate #'(lambda (v) (let ((*read-eval* nil)) (handler-case (let ((rfs (read-from-string (current-state v)))) (if valid-test (funcall valid-test rfs) t)) (reader-error (c) (let ((*print-escape* t)) (values nil (format nil "Reader error: ~A" c)))) (end-of-file () (values nil "Please enter an expression.")))))))) (values (read-from-string (cl-menusystem-sys:do-inputable-loop foo output-device input-device))))) (defmacro make-preference-menu (var &key description extended-help type present-form default-values valid-test (convert-function #'(lambda (v) v))) `(make-menu ,description ,extended-help (make-state-presentable ,(format nil "Current value of ~A" description) (funcall ,present-form)) (make-menu-action ,(format nil "Edit the value of ~A" description) nil (rst) (setf ,var (funcall ,convert-function (,(cond ((eq type :one-line-string) 'request-one-line-string) ((eq type :integer) 'request-integer) ((eq type :expression) 'request-expression) (t (error "Unknown type of preference: ~A" type))) *menu-output* *menu-input* ,(format nil "Edit the value of ~A" description) nil ,@(if valid-test `(:valid-test ,valid-test)))))) ,@(mapcar #'(lambda (v) `(make-menu-action ,(format nil "Set to ~A" (car v)) nil (rst) (setf ,var ,(cadr v)))) default-values) (make-menu-action "Exit to previous menu" nil (rst) (invoke-restart rst)))) Loading
README 0 → 100644 +24 −0 Original line number Diff line number Diff line cl-menusystem, a third release This is cl-menusystem as of 9/14/2003, its third release. It's now usable for a wider variety of tasks - the file DOCUMENTATION and the example in test.lisp should help you get started. To use it, load the supplied .asd one way or another. You should also be able to use asdf-install to install it. Read the file test.lisp to get an example of how to define a menu. To run that menu (once test.lisp has been loaded) try: (cl-menusystem:do-menu cl-menusystem-test:*test-menu* *standard-output* *standard-input*) Note that some of the classes specified in inputable.lisp are left unimplemented in tty-interface.lisp - I'll add features as I need them. If other people actually start using this I may be inclined to take feature requests too. :-) This source code has been placed into the public domain. Brian Mastenbrook bmastenb@cs.indiana.edu http://www.cs.indiana.edu/~bmastenb/ No newline at end of file
cl-menusystem.lisp 0 → 100644 +42 −0 Original line number Diff line number Diff line ;;;; cl-menusystem.lisp ;;; I wasn't sure where to put the defpackage. (defpackage #:cl-menusystem (:use #:common-lisp) (:export ;; presentable.lisp #:presentable #:presentable-description #:extended-help #:present-object #:display-object #:display-object-briefly #:request-object #:simple-format-message ;; menus.lisp #:menu #:presentables #:menu-tag ;; inputable.lisp #:inputable #:current-state #:instance-valid-input-predicate #:valid-inputable-state-p #:integer-valued-inputable #:one-line-string-valued-inputable #:expression-valued-inputable #:flags-valued-inputable #:available-flags #:flag-descriptions ;; easy-menus.lisp #:*menu-output* #:*menu-input* #:make-menu #:defmenu #:menu-action #:make-menu-action #:do-menu #:make-state-presentable #:make-state-presentable-no-hiding #:request-one-line-string #:make-preference-menu))
easy-menus.lisp 0 → 100644 +152 −0 Original line number Diff line number Diff line ;;;; easy-menus.lisp - macros and classes which make the construction of menus easier (in-package #:cl-menusystem) (defvar *menu-output*) (defvar *menu-input*) (defmacro with-gensyms (names &body forms) `(let ,(mapcar #'(lambda (name) (list name '(gensym))) names) ,@forms)) (defmacro generate-do-menu-action (menu-object output-device input-device) (with-gensyms (start-entry previous-menu end-entry menu-object-name chosen current-state return-value v) `(let ((,menu-object-name ,menu-object) (*menu-output* ,output-device) (*menu-input* ,input-device) (,return-value nil)) (tagbody ,start-entry (let ((,current-state (cl-menusystem-sys:do-menu-loop ,menu-object-name *menu-output* *menu-input*))) (when (eql ,current-state (1+ (length (presentables ,menu-object-name)))) ; help was chosen (if (not (extended-help ,menu-object-name)) (simple-format-message *menu-output* "Please choose a valid option from the menu. (No extended help is available.)~&") (simple-format-message *menu-output* "~A~&" (extended-help ,menu-object-name))) (go ,start-entry)) (let ((,chosen (nth (1- ,current-state) (presentables ,menu-object-name)))) (cond ((typep ,chosen 'menu-action) (restart-case (progn (funcall (action ,chosen) ',previous-menu) (go ,start-entry)) (,previous-menu (&optional ,v) (setf ,return-value ,v) (go ,end-entry)))) ((typep ,chosen 'menu) (do-menu ,chosen *menu-output* *menu-input*) (go ,start-entry)) ((typep ,chosen 'inputable) (cl-menusystem-sys:do-inputable-loop ,chosen *menu-output* *menu-input*) (go ,start-entry)) ((typep ,chosen 'presentable) (display-object ,chosen *menu-output*) (go ,start-entry))))) ,end-entry) ,return-value))) (defclass easy-menu (cl-menusystem-sys:sys-menu) ((do-menu-action :initarg :do-menu-action :accessor do-menu-action))) (defmacro make-menu (description help &rest menu-items) `(make-instance 'easy-menu :presentable-description ,description :extended-help ,help :presentables (list ,@menu-items) :do-menu-action #'(lambda (menu-object object-device input-device) (generate-do-menu-action menu-object object-device input-device)))) (defmacro defmenu (name description help &rest menu-items) `(defparameter ,name (make-menu ,description ,help ,@menu-items))) (defclass menu-action (menu-tag) ((action :initarg :action :accessor action))) (defmacro make-menu-action (description help lambda-args &body lambda-form) (if (not (eql (length lambda-args) 1)) (error "lambda-args must be of length 1!")) `(make-instance 'menu-action :presentable-description ,description :extended-help ,help :action #'(lambda ,lambda-args ,@lambda-form))) (defun do-menu (menu-object output-device input-device) (funcall (do-menu-action menu-object) menu-object output-device input-device)) (defclass state-presentable (presentable) ((display-state-function :accessor display-state-function :initarg :display-state-function) (hide-state-p :accessor hide-state-p :initarg :hide-state-p :initform nil))) (defmethod display-object ((presentable-object state-presentable) output-device) (simple-format-message output-device "~A~&" (presentable-description presentable-object)) (simple-format-message output-device "~A~& "(funcall (display-state-function presentable-object)))) (defmethod display-object-briefly ((presentable-object state-presentable) output-device) (if (hide-state-p presentable-object) (simple-format-message output-device "State hidden for: ~A~&" (presentable-description presentable-object)) (simple-format-message output-device "~A: ~A~&" (presentable-description presentable-object) (funcall (display-state-function presentable-object))))) (defmacro make-state-presentable (description &body forms) `(make-instance 'state-presentable :presentable-description ,description :extended-help nil :hide-state-p t :display-state-function (lambda () ,@forms))) (defmacro make-state-presentable-no-hiding (description &body forms) `(make-instance 'state-presentable :presentable-description ,description :extended-help nil :hide-state-p nil :display-state-function (lambda () ,@forms))) (defun request-one-line-string (output-device input-device description &optional extended-help &key valid-test) (let ((foo (if valid-test (make-instance 'one-line-string-valued-inputable :presentable-description description :extended-help extended-help :instance-valid-input-predicate #'(lambda (i) (funcall valid-test (current-state i)))) (make-instance 'one-line-string-valued-inputable :presentable-description description :extended-help extended-help)))) (cl-menusystem-sys:do-inputable-loop foo output-device input-device))) (defun request-integer (output-device input-device description &optional extended-help &key valid-test) (let ((foo (if valid-test (make-instance 'integer-valued-inputable :presentable-description description :extended-help extended-help :instance-valid-input-predicate #'(lambda (i) (funcall valid-test (current-state i)))) (make-instance 'integer-valued-inputable :presentable-description description :extended-help extended-help)))) (cl-menusystem-sys:do-inputable-loop foo output-device input-device))) (defun request-expression (output-device input-device description &optional extended-help &key valid-test) (let ((foo (make-instance 'one-line-string-valued-inputable :presentable-description description :extended-help (format nil "Please enter an expression on one line.~%~%~A" extended-help) :instance-valid-input-predicate #'(lambda (v) (let ((*read-eval* nil)) (handler-case (let ((rfs (read-from-string (current-state v)))) (if valid-test (funcall valid-test rfs) t)) (reader-error (c) (let ((*print-escape* t)) (values nil (format nil "Reader error: ~A" c)))) (end-of-file () (values nil "Please enter an expression.")))))))) (values (read-from-string (cl-menusystem-sys:do-inputable-loop foo output-device input-device))))) (defmacro make-preference-menu (var &key description extended-help type present-form default-values valid-test (convert-function #'(lambda (v) v))) `(make-menu ,description ,extended-help (make-state-presentable ,(format nil "Current value of ~A" description) (funcall ,present-form)) (make-menu-action ,(format nil "Edit the value of ~A" description) nil (rst) (setf ,var (funcall ,convert-function (,(cond ((eq type :one-line-string) 'request-one-line-string) ((eq type :integer) 'request-integer) ((eq type :expression) 'request-expression) (t (error "Unknown type of preference: ~A" type))) *menu-output* *menu-input* ,(format nil "Edit the value of ~A" description) nil ,@(if valid-test `(:valid-test ,valid-test)))))) ,@(mapcar #'(lambda (v) `(make-menu-action ,(format nil "Set to ~A" (car v)) nil (rst) (setf ,var ,(cadr v)))) default-values) (make-menu-action "Exit to previous menu" nil (rst) (invoke-restart rst))))