/[cl-menusystem]/cl-menusystem/inputable.lisp
ViewVC logotype

Contents of /cl-menusystem/inputable.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Tue Sep 23 23:53:00 2003 UTC (10 years, 6 months ago) by bmastenbrook
Branch: MAIN, cl-menusystem
CVS Tags: start, HEAD
Changes since 1.1: +0 -0 lines
Initial import
1 ;;;; inputable.lisp
2
3 (in-package #:cl-menusystem)
4
5 (defclass inputable (requestable)
6 ((current-state :initarg :current-state :accessor current-state)
7 (instance-valid-input-predicate :initarg :instance-valid-input-predicate :accessor instance-valid-input-predicate :initform #'(lambda (e) t))))
8
9 (defmethod initialize-instance :after ((inputable-object inputable) &rest whatever)
10 (declare (ignore whatever))
11 (if (not (typep (instance-valid-input-predicate inputable-object) 'function))
12 (error "instance-valid-input-predicate must be a function!")))
13
14 (defgeneric valid-inputable-state-p (inputable-object))
15
16 (defmethod valid-inputable-state-p ((inputable-object inputable))
17 (funcall (instance-valid-input-predicate inputable-object) inputable-object))
18
19 (defclass integer-valued-inputable (inputable) ())
20
21 (defmethod valid-inputable-state-p :around ((inputable-object integer-valued-inputable))
22 (if (not (slot-boundp inputable-object 'current-state))
23 (error "current-state must be bound!")
24 (if (not (typep (current-state inputable-object) 'integer))
25 (values nil "This input must be an integer.")
26 (if (next-method-p) (call-next-method) t))))
27
28 (defclass one-line-string-valued-inputable (inputable) ())
29
30 (defmethod valid-inputable-state-p :around ((inputable-object one-line-string-valued-inputable))
31 (if (not (slot-boundp inputable-object 'current-state))
32 (error "current-state must be bound!")
33 (if (position #\Newline (current-state inputable-object))
34 (values nil "This string must not contain a newline.")
35 (if (next-method-p) (call-next-method) t))))
36
37 (defclass flags-valued-inputable (inputable)
38 ((available-flags :initarg available-flags :accessor available-flags)
39 (flag-descriptions :initarg flag-descriptions :accessor flag-descriptions :initform nil)))
40
41 (defmethod valid-inputable-state-p :around ((inputable-object flags-valued-inputable))
42 (if (not (slot-boundp inputable-object 'current-state))
43 (error "current-state must be bound!")
44 (let ((the-state (current-state inputable-object))
45 (flags (available-flags inputable-object)))
46 (if (not (listp the-state))
47 (error "current-state must be a list!")
48 (let ((bad-val (some #'(lambda (e) (if (not (member e flags :test #'eql)) e nil)) the-state)))
49 (if bad-val
50 (values nil (format nil "The flag ~A is not an acceptable flag!" bad-val))
51 (if (next-method-p) (call-next-method) t)))))))
52
53 (defmethod initialize-instance :after ((fvi flags-valued-inputable) &rest whatever)
54 (declare (ignore whatever))
55 (if (not (slot-boundp fvi 'available-flags))
56 (error "available-flags must be bound!")
57 (if (not (and (consp 'available-flags) (listp 'available-flags)))
58 (error "available-flags must be a non-empty list!")))
59 (if (not (and (slot-boundp fvi 'flag-descriptions) (listp (flag-descriptions fvi))))
60 (error "flag-descriptions must be an alist (possibly empty)")))

  ViewVC Help
Powered by ViewVC 1.1.5