/[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 - (hide 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 cfruhwirth 1.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