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

Contents of /mcclim/Doc/Guided-Tour/scheduler.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 ; LTAG-start:scheduler-part1
8 (defvar *days* #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
9
10 ;; Alist of day number and appointment strings
11 (defvar *test-data*
12 '((0) (1 "Dentist") (2 "Staff meeting") (3 "Performance Evaluation" "Bowling")
13 (4 "Interview at ACME" "The Simpsons") (5 "TGIF") (6 "Sailing")))
14
15 (define-presentation-type weekday ())
16
17 (define-presentation-method accept
18 ((type weekday) stream (view textual-view) &key)
19 (values (completing-from-suggestions (stream)
20 (dotimes (i 7)
21 (suggest (aref *days* i) i)))))
22
23 (define-presentation-method present
24 (daynumber (type weekday) stream (view textual-view) &key)
25 (write-string (aref *days* daynumber) stream))
26
27
28 (define-application-frame scheduler ()
29 ((appointments :initarg :appointments :initform *test-data*)
30 (current-day :initform nil))
31 (:panes (scheduler-display :application
32 :display-function '(display-appointments))
33 (interactor :interactor))
34 (:layouts (default-layout
35 (vertically ()
36 scheduler-display
37 interactor))
38 (alternative-layout
39 (horizontally ()
40 interactor
41 scheduler-display)))
42 (:menu-bar t))
43
44 ;;; Chooses which day to see in detail,
45 (define-scheduler-command (com-select-day :name t :menu t)
46 ((day 'weekday :gesture :select))
47 (with-slots (current-day) *application-frame*
48 (setq current-day day)))
49
50 ;;; Show weekly summary.
51 (define-scheduler-command (com-show-summary :name t :menu t) ()
52 (with-slots (current-day) *application-frame*
53 (setq current-day nil)))
54
55 (define-scheduler-command (com-toggle-layout :name t :menu t) ()
56 (with-accessors ((layout frame-current-layout)) *application-frame*
57 (setf layout (if (eq layout 'default-layout)
58 'alternative-layout
59 'default-layout))))
60 ; LTAG-end
61 ; LTAG-start:scheduler-part2
62 ;;; Complex display function, shows two completely different displays.
63 (defmethod display-appointments ((frame scheduler) pane)
64 (clear-output-record (stream-output-history pane))
65 (with-slots (current-day appointments) frame
66 (if (null current-day)
67 (show-weekly-summary pane appointments)
68 (show-appointments pane
69 current-day
70 (rest (assoc current-day appointments))))))
71
72 ;;; Show a summary of the week, with an appointment count for each
73 ;;; day. You can see the appointments for a specific day by clicking on
74 ;;; the day name.
75 (defun show-weekly-summary (pane appointments)
76 (formatting-table (pane) ;; Table headings
77 (formatting-row (pane)
78 (formatting-cell (pane)
79 (write-string "Day of week " pane))
80 (formatting-cell (pane)
81 (write-string "number of appointments" pane)))
82 (dolist (day appointments)
83 (formatting-row (pane)
84 (formatting-cell (pane)
85 (present (first day) 'weekday :stream pane))
86 (formatting-cell (pane)
87 (format pane "~D appointment ~&"
88 (length (rest day))))))))
89
90 ;;; Show detailed appointment list for day
91 (defun show-appointments (pane current-day current-day-appointments)
92 ;; Show all days at top so you can switch to another
93 ;; day with one click.
94 (dotimes (day 7)
95 (with-text-face (pane (if (eql day current-day) ':bold ':roman))
96 (present day 'weekday :stream pane))
97 (write-string " " pane))
98 (terpri pane) (terpri pane)
99 ;; Show all the appointments, one per line
100 (write-string "Appointments for " pane)
101 (present current-day 'weekday :stream pane)
102 (terpri pane) (terpri pane)
103 (dolist (appointment current-day-appointments)
104 (write-string appointment pane)
105 (terpri pane)))
106 ; LTAG-end

  ViewVC Help
Powered by ViewVC 1.1.5