/[cello]/cello/application.lisp
ViewVC logotype

Contents of /cello/application.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Fri Apr 11 09:22:46 2008 UTC (6 years ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.10: +20 -20 lines
*** empty log message ***
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 (export! *sys*)
20
21 (defparameter *sys* nil)
22
23 (defparameter *first-kill-all-the-windows* nil)
24
25 (export! cello-reset mg-system)
26
27 #+test
28 (cello-reset nil)
29
30 (defun cello-reset (&optional (system-type 'mg-system))
31
32 ;; Reset CFFI, CFFI Extender
33 (ffx-reset)
34
35 ;; Reset CELLS
36 (cells-reset 'tk-user-queue-handler) ; :debug t)
37
38 ;; Reset OpenGL special vars
39 (makunbound 'ogl::*gl-stop*)
40
41 (setf *ctk-dbg* nil)
42
43 (cl-ftgl-reset) ;; 2006-09-27 back in temporarily ...
44 ;; new 2006-08-28: in face of weird OGL 1282 when
45 ;; new chars hit in ratios
46
47 (ft:initialize-ft)
48 (mgk::wands-clear)
49
50 ;; Init global *sys* ... needed for Cello context ops
51 (when system-type
52 (setf *sys* (make-instance system-type))
53 #+rms-s3 (rms-reset))
54 (values))
55
56 (defmd mg-system (family)
57 (main-window (c-in nil))
58 (mouse nil :cell nil)
59 (sys-time (c-in (now)))
60 (user-preferences (c-in nil))
61 :kids (c-in nil))
62
63 (defun sys-now ()
64 (sys-time *sys*))
65
66 (defmethod initialize-instance :after ((self mg-system) &key)
67 (setf (mouse self) (cells::make-instance 'mouse))) ;; 2006-06-01 was make-be
68
69 (defmethod sys-close (other)
70 (declare (ignore other)))
71
72 (defun user-pref-set (key value)
73 ;; weird sequence necessary to trigger cell ///
74 (setf (user-preferences *sys*)
75 (cons (cons key value)
76 (delete (assoc key (user-preferences *sys*))
77 (user-preferences *sys*)))))
78
79 (defun user-pref-toggle (key)
80 (user-pref-set key (not (user-pref key))))
81
82 (defun user-pref (key)
83 (cdr (assoc key (user-preferences *sys*))))
84
85 (defmacro ^user-pref (key)
86 `(bwhen (ups (^user-preferences *sys*))
87 (user-pref ,key)))
88
89 ;---------------------------------------------------
90
91 (defun current-application-time ()
92 (ymdhmsh (current-app-universal-time *sys*)))
93
94 (defmethod current-app-universal-time (system)
95 (declare (ignore system))
96 (get-universal-time))
97
98 ;may write globals to file when set, then read in at startup time for continuity
99
100 (defun fm-find-system (md)
101 (upper md mg-system))

  ViewVC Help
Powered by ViewVC 1.1.5