/[mcclim]/mcclim/Doc/Guided-Tour/simple-spreadsheet.lisp
ViewVC logotype

Contents of /mcclim/Doc/Guided-Tour/simple-spreadsheet.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Mon Jan 30 16:14:01 2006 UTC (8 years, 2 months ago) by cfruhwirth
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4, McCLIM-0-9-6, McCLIM-0-9-3, McCLIM-0-9-2, HEAD
Move docs/guided-tour to Doc/Guided-Tour.
Add line-breaks to guided-tour.tex.
1 (eval-when (:compile-toplevel)
2 (asdf:oos 'asdf:load-op :clim)
3 (asdf:oos 'asdf:load-op :clim-clx))
4
5 (in-package :clim-user)
6
7 (defclass cell () ((content :accessor content :initarg :content)))
8
9 (defun make-cell (&rest args)
10 (apply #'make-instance 'cell args))
11
12 (define-presentation-type cell ())
13
14 (defvar loop-detector nil)
15
16 (defun c (h w)
17 (if (not loop-detector)
18 (error "No loop-detector in dynamic environment.")
19 (if (aref loop-detector h w)
20 (error "Evaluation loop detected.")
21 (progn
22 (setf (aref loop-detector h w) t)
23 (eval (content (aref (frame-cells *application-frame*) h w)))))))
24
25 (define-presentation-method present (cell (type cell) stream (view textual-view) &key)
26 (let ((loop-detector (make-array (array-dimensions (frame-cells *application-frame*)) :initial-element nil)))
27 (format stream "~A" (eval (content cell)))))
28
29 (defclass cell-unparsed-text (textual-dialog-view) ())
30
31 (defconstant +cell-unparsed-text-view+ (make-instance 'cell-unparsed-text))
32
33 (define-presentation-method present (cell (type cell) stream (view cell-unparsed-text) &key)
34 (format stream "~A" (content cell)))
35
36 (define-presentation-method accept ((type cell) stream (view cell-unparsed-text) &key)
37 (make-cell :content (read stream)))
38
39 (defmethod print-object ((cell cell) stream)
40 (format stream "<CELL ~A>" (content cell)))
41
42 (defun initial-cells ()
43 (insert-column (insert-column (insert-row (insert-row #2A() 0) 0) 0) 0))
44
45 (defun insert-row (old-cells insert-before)
46 (destructuring-bind (height width) (array-dimensions old-cells)
47 (let ((new-cells (make-array `(,(1+ height) ,width))))
48 (dotimes (i (1+ height))
49 (dotimes (j width)
50 (setf (aref new-cells i j)
51 (cond
52 ((eq i insert-before) (make-cell :content 0))
53 ((< i insert-before) (aref old-cells i j))
54 ((> i insert-before) (aref old-cells (1- i) j))))))
55 new-cells)))
56
57 (defun insert-column (old-cells insert-before)
58 (destructuring-bind (height width) (array-dimensions old-cells)
59 (let ((new-cells (make-array `(,height ,(1+ width)))))
60 (dotimes (i height)
61 (dotimes (j (1+ width))
62 (setf (aref new-cells i j)
63 (cond
64 ((eq j insert-before) (make-cell :content 0))
65 ((< j insert-before) (aref old-cells i j))
66 ((> j insert-before) (aref old-cells i (1- j)))))))
67 new-cells)))
68
69 (defun cell-to-grid-position (cell cells)
70 (destructuring-bind (height width) (array-dimensions cells)
71 (dotimes (i height)
72 (dotimes (j width)
73 (if (eq cell (aref cells i j))
74 (return-from cell-to-grid-position (values i j)))))))
75
76
77 (define-application-frame spreadsheet ()
78 ((cells :accessor frame-cells :initform (initial-cells)))
79 (:panes
80 (cellpane :application :display-function #'display-cells) (interactor :interactor))
81 (:layouts
82 (default (vertically () cellpane interactor))))
83
84 (defmethod frame-standard-output ((frame spreadsheet))
85 (find-pane-named frame 'interactor))
86
87 (defun display-cells (frame pane &rest args)
88 (destructuring-bind (height width) (array-dimensions (frame-cells frame))
89 (formatting-table (pane)
90 (dotimes (i height)
91 (formatting-row (pane)
92 (dotimes (j width)
93 (formatting-cell (pane)
94 (present (aref (frame-cells frame) i j) 'cell :stream pane))))))))
95
96 (define-spreadsheet-command (com-change-cell :name t) ((cell 'cell :gesture :select))
97 (let ((frame-input (frame-standard-input *application-frame*))
98 new-cell)
99 (accepting-values (frame-input)
100 (setq new-cell (accept 'cell :stream frame-input :view +cell-unparsed-text-view+ :default cell)))
101 (setf (content cell) (content new-cell))))
102
103 (defmacro with-cell-position (args cell &body body)
104 `(multiple-value-bind (,(first args) ,(second args))
105 (cell-to-grid-position ,cell (frame-cells *application-frame*))
106 ,@body))
107
108 (define-spreadsheet-command (com-cell-to-position :name t) ((cell 'cell :gesture :menu))
109 (with-cell-position (y x) cell
110 (format t "X: ~A Y: ~A~&" x y)))
111
112 (define-spreadsheet-command (com-insert-row-before-cell :name t) ((cell 'cell :gesture :menu))
113 (with-application-frame (frame)
114 (with-cell-position (y x) cell
115 (setf (frame-cells frame)
116 (insert-row (frame-cells frame) x)))))
117
118 (define-spreadsheet-command (com-insert-row-after-cell :name t) ((cell 'cell :gesture :menu))
119 (with-application-frame (frame)
120 (with-cell-position (y x) cell
121 (setf (frame-cells frame)
122 (insert-row (frame-cells frame) (1+ x))))))
123
124 (define-spreadsheet-command (com-insert-column-before-cell :name t) ((cell 'cell :gesture :menu))
125 (with-application-frame (frame)
126 (with-cell-position (y x) cell
127 (setf (frame-cells frame)
128 (insert-column (frame-cells frame) y)))))
129
130 (define-spreadsheet-command (com-insert-column-after-cell :name t) ((cell 'cell :gesture :menu))
131 (with-application-frame (frame)
132 (with-cell-position (y x) cell
133 (setf (frame-cells frame)
134 (insert-column (frame-cells frame) (1+ y))))))

  ViewVC Help
Powered by ViewVC 1.1.5