Skip to content
Snippets Groups Projects
Commit 4b96fab1 authored by cer's avatar cer
Browse files

Initial revision

parent 162740e0
No related branches found
No related tags found
No related merge requests found
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
"Copyright (c) 1992 by Symbolics, Inc. All rights reserved."
(in-package :silica) ;yes, this file is in the Silica package
;;; Menu bars and buttons
;;--- The main visual problem is that there is just too much whitespace...
;;; Menu bar buttons
;; Like push buttons, except that they activate when the pointer button is
;; down rather than when it is released
(defclass menu-bar-button (push-button-pane)
((next-menu :initform nil :initarg :next-menu)))
(defmethod handle-event ((pane menu-bar-button) (event pointer-enter-event))
(with-slots (armed next-menu) pane
(unless armed
(cond ((let ((pointer (pointer-event-pointer event)))
(and (pointer-button-state pointer)
(not (zerop (pointer-button-state pointer)))))
(with-sheet-medium (medium pane)
(setf armed :active)
(highlight-button pane medium)
(if (typep next-menu 'pull-down-menu)
(choose-from-pull-down-menu next-menu pane)
(activate-callback pane (gadget-client pane) (gadget-id pane)))
(setf armed t)
(highlight-button pane medium)))
(t (setf armed t)))
(armed-callback pane (gadget-client pane) (gadget-id pane)))))
(defmethod handle-event ((pane menu-bar-button) (event pointer-button-press-event))
(with-slots (armed next-menu) pane
(with-sheet-medium (medium pane)
(when armed
(setf armed :active)
(highlight-button pane medium))
(if (typep next-menu 'pull-down-menu)
(choose-from-pull-down-menu next-menu pane)
(activate-callback pane (gadget-client pane) (gadget-id pane)))
(setf armed t)
(highlight-button pane medium))))
(defmethod handle-event ((pane menu-bar-button) (event pointer-button-release-event))
(with-slots (armed) pane
(when (and (eq armed :active))
(with-sheet-medium (medium pane)
(setf armed t)
(highlight-button pane medium)))))
;;; Pull-down menu buttons
(defparameter *cascade-button-pattern*
(make-pattern #2a((1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1)
(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1))
(list +background-ink+ +foreground-ink+)))
;; Like push buttons except that the pointer button is assumed to be already down
(defclass pull-down-menu-button (push-button-pane)
((next-menu :initform nil :initarg :next-menu)))
(defmethod initialize-instance :after ((pane pull-down-menu-button) &key)
(with-slots (next-menu pattern) pane
(when next-menu
(setq pattern *cascade-button-pattern*))))
(defmethod handle-event ((pane pull-down-menu-button) (event pointer-enter-event))
(when (port pane) ;the menu is sometimes disabled...
(let* ((pointer (port-pointer (find-port)))
(pointer-button-state (pointer-button-state pointer)))
(unless (= pointer-button-state 0)
(with-slots (armed) pane
(unless (eq armed :active)
(with-sheet-medium (medium pane)
(setq armed :active)
(highlight-button pane medium))
(armed-callback pane (gadget-client pane) (gadget-id pane))))))))
(defmethod handle-event ((pane pull-down-menu-button) (event pointer-exit-event))
(when (port pane) ;the menu is often disabled...
(with-slots (armed) pane
(when armed
(with-sheet-medium (medium pane)
(setq armed nil)
(highlight-button pane medium))
(disarmed-callback pane (gadget-client pane) (gadget-id pane))))))
(defmethod handle-event ((pane pull-down-menu-button) (event pointer-motion-event))
(with-slots (next-menu x-margin normal-pattern) pane
(when next-menu
(with-bounding-rectangle* (left top right bottom) (sheet-region pane)
(declare (ignore top right bottom))
(let* ((pattern-width (pattern-width normal-pattern))
(sensitive-region 16)
(x (pointer-event-x event)))
(when (and next-menu (> x (- (+ left x-margin pattern-width) sensitive-region)))
(if (typep next-menu 'pull-down-menu)
(choose-from-pull-down-menu next-menu pane :cascade-p t)
(funcall next-menu pane))))))))
;; We really shouldn't ever get one of these - the button must have been down
;; for us to get here.
(defmethod handle-event ((pane pull-down-menu-button) (event pointer-button-press-event))
)
(defmethod handle-event ((pane pull-down-menu-button) (event pointer-button-release-event))
(with-slots (armed) pane
(when (eq armed :active)
(setf armed t)
(with-sheet-medium (medium pane)
(highlight-button pane medium))
(activate-callback pane (gadget-client pane) (gadget-id pane))
;;--- This modularity is a bit dubious. Oh well.
(throw 'exit-pull-down-menu (values)))))
;;; Pull-down menu sheets
(defclass popup-menu-sheet
(sheet-permanently-enabled-mixin
sheet-single-child-mixin
wrapping-space-mixin
space-requirement-mixin
pane)
()
(:default-initargs :medium t))
(defclass pull-down-menu (popup-menu-sheet)
((current-button :initform nil)
(buttons :initarg :buttons :accessor pull-down-menu-buttons)
(entered :initarg nil :accessor pull-down-menu-entered))
(:default-initargs :buttons nil))
(defmethod repaint-sheet :after ((pane pull-down-menu) region)
(dolist (button (slot-value pane 'buttons))
(repaint-sheet button region)))
(defmethod handle-event ((pane pull-down-menu) (event pointer-motion-event))
(when (and (plusp (pointer-event-x event))
(plusp (pointer-event-y event)))
(setf (pull-down-menu-entered pane) t)))
(defmethod handle-event ((pane pull-down-menu) (event pointer-button-press-event))
)
(defmethod handle-event ((pane pull-down-menu) (event pointer-button-release-event))
)
(defmethod handle-event ((pane pull-down-menu) (event pointer-enter-event))
(when (and (plusp (pointer-event-x event))
(plusp (pointer-event-y event)))
(setf (pull-down-menu-entered pane) t)))
(defmethod handle-event ((pane pull-down-menu) (event pointer-exit-event))
;; Don't punt if we've never entered the menu
(when (pull-down-menu-entered pane)
(throw 'exit-pull-down-menu (values))))
(defmethod handle-event :after ((pane pull-down-menu) (event pointer-event))
(deallocate-event event))
;;; Interface to pull-down menus
(define-application-frame pull-down-menu-frame ()
(menu)
(:pane
(with-slots (menu) *application-frame*
(outlining ()
(setq menu (make-pane 'pull-down-menu
:width 100 :height 100)))))
(:menu-bar nil))
(defun make-pull-down-menu (&key port)
(let ((frame (make-application-frame 'pull-down-menu-frame
:parent port
:save-under t)))
(values (slot-value frame 'menu) frame)))
;; Pull-down menus share their event queue with the owning application
(defresource pull-down-menu (port)
:constructor (make-pull-down-menu :port port)
:matcher (eq (port pull-down-menu) port)
:deinitializer
(progn
(setf (pull-down-menu-buttons pull-down-menu) nil)
(setf (pull-down-menu-entered pull-down-menu) nil)
(dolist (child (sheet-children pull-down-menu))
(sheet-disown-child pull-down-menu child))))
(defmacro initialize-pull-down-menu (menu &body buttons)
(assert (= (length buttons) 1))
`(with-look-and-feel-realization ()
(setf (pull-down-menu-buttons ,menu) ,@buttons)
(sheet-adopt-child ,menu (make-pane 'vbox-pane
:contents (pull-down-menu-buttons ,menu)
:spacing 0))
(layout-frame (pane-frame ,menu))
,menu))
(defvar *subsidiary-pull-down-menu* nil)
(defun choose-from-pull-down-menu (menu &optional button &key cascade-p)
(let ((menu-frame (pane-frame menu))
(event-queue (sheet-event-queue menu)))
(when button
(with-bounding-rectangle* (bleft btop bright bbottom)
(sheet-device-region button)
(declare (ignore bright))
(multiple-value-bind (fleft ftop fright fbottom)
(let ((tls (get-top-level-sheet button)))
(mirror-region* (port tls) tls))
(declare (ignore fright fbottom))
(if cascade-p
(let ((pattern-width (pattern-width (slot-value button 'normal-pattern)))
(button-x-margin (slot-value button 'x-margin)))
(move-sheet (frame-top-level-sheet menu-frame)
(+ bleft fleft pattern-width button-x-margin -16)
(+ btop ftop)))
(move-sheet (frame-top-level-sheet menu-frame)
(+ bleft fleft 10)
(+ bbottom ftop -10))))))
(enable-frame menu-frame)
;; Share the event queue with the application frame
(setf (sheet-event-queue (frame-top-level-sheet (pane-frame menu)))
(sheet-event-queue (frame-top-level-sheet *application-frame*)))
;; Ensure no surprise exit events
(setf (pull-down-menu-entered menu) nil)
;; Wait for an event and then handle it
(unwind-protect
(flet ((waiter ()
(not (queue-empty-p event-queue))))
(declare (dynamic-extent #'waiter))
(catch (if *subsidiary-pull-down-menu*
'|Not exit-pull-down-menu|
'exit-pull-down-menu)
(let ((*subsidiary-pull-down-menu* t))
(loop
(port-event-wait (port menu) #'waiter)
(let ((event (queue-get event-queue)))
(handle-event (event-sheet event) event))))))
(disable-frame menu-frame))))
;;--- Kludge alert
(defun get-top-level-sheet (pane)
(if (typep pane 'top-level-sheet)
pane
(get-top-level-sheet (sheet-parent pane))))
;;; Menu bars
(defclass menu-bar-pane
(menu-bar)
())
;;--- What about when the command menu tick changes?
;;--- What about graying of disabled commands?
(defun compute-menu-bar-pane (frame command-table)
(with-look-and-feel-realization ((frame-manager frame) frame)
(labels
((make-command-table-buttons (command-table top-level)
(let ((buttons nil))
(map-over-command-table-menu-items
#'(lambda (menu keystroke item)
(let ((type (command-menu-item-type item))
(value (command-menu-item-value item)))
(case type
(:command
(push (make-pane (if top-level 'push-button 'pull-down-menu-button)
:label menu
:activate-callback
#'(lambda (button)
(menu-bar-command-callback button command-table value)))
buttons))
(:function
;;--- Do something about this
)
(:menu
(push (make-pane (if top-level 'menu-bar-button 'pull-down-menu-button)
:label menu
:next-menu (make-command-table-menu value nil)
:activate-callback nil)
buttons))
(:divider
(unless top-level
;;--- Do something about this
)))))
command-table)
(nreverse buttons)))
(make-command-table-menu (command-table top-level)
(let ((buttons (make-command-table-buttons command-table top-level)))
(if top-level
(outlining ()
(make-pane 'hbox-pane :contents buttons))
(let ((menu (make-pull-down-menu :port (port frame))))
(initialize-pull-down-menu menu buttons)
menu)))))
(declare (dynamic-extent #'make-command-table-buttons #'make-command-table-menu))
(make-command-table-menu command-table t))))
(defun menu-bar-command-callback (button command-table command)
(let ((frame (pane-frame button)))
(distribute-event
(port button)
(allocate-event 'presentation-event
:frame frame
:sheet (frame-top-level-sheet frame)
:presentation-type `(command :command-table ,command-table)
:value command))))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved."
(clim-defsys:defsystem cloe-clim
(:default-pathname #+Genera "SYS:CLIM;REL-2;CLOE;"
#-Genera (frob-pathname "cloe")
:default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLOE;"
#-Genera (frob-pathname "cloe")
:needed-systems (clim-standalone)
:load-before-compile (clim-standalone))
("pkgdcl")
("wheader")
("windows")
("cloe-port")
("cloe-mirror")
("cloe-medium")
("cloe-frames")
("cloe-gadgets")
("cloe-menus"))
#+Genera
(clim-defsys:import-into-sct 'cloe-clim
:pretty-name "Cloe CLIM"
:default-pathname "SYS:CLIM;REL-2;CLOE;")
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved."
(clim-defsys:defsystem clx-clim
(:default-pathname #+Genera "SYS:CLIM;REL-2;CLX;"
#-Genera (frob-pathname "clx")
:default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLX;"
#-Genera (frob-pathname "clx")
:needed-systems (clim-standalone)
:load-before-compile (clim-standalone))
("pkgdcl")
("clx-port")
("clx-mirror")
("clx-medium")
("clx-pixmaps")
("clx-frames")
("clx-prefill" :features (or Genera Cloe-Runtime)))
#+Genera
(clim-defsys:import-into-sct 'clx-clim
:pretty-name "CLX CLIM"
:default-pathname "SYS:CLIM;REL-2;CLX;"
:required-systems '(clim)
:bug-reports "Bug-CLIM"
:patches-reviewed "Bug-CLIM-Doc")
#+Minima-Developer
(clim-defsys:import-into-sct 'clx-clim :subsystem t
:sct-name :minima-clx-clim-standalone
:pretty-name "Minima CLX CLIM Standalone"
:default-pathname "SYS:CLIM;REL-2;CLX;"
:default-destination-pathname "SYS:CLIM;REL-2;CLX;")
#+Minima-Developer
(zl:::sct:defsystem minima-clx-clim
(:pretty-name "Minima CLX CLIM"
:default-pathname "SYS:CLIM;REL-2;CLX;"
:journal-directory "SYS:CLIM;REL-2;CLX;PATCH;"
:maintain-journals nil
:default-module-type :system
:patches-reviewed "Bug-CLIM-Doc"
:source-category :optional)
(:serial "minima-clim" "minima-clx-clim-standalone"))
This diff is collapsed.
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(in-package :clim-internals)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
(defvar *clim-1-symbols*
'(*abort-characters*
*activation-characters*
*blip-characters*
*completion-characters*
*help-characters*
*possibilities-characters*
*standard-activation-characters*
*unsupplied-argument*
+background+
+dialog-view+
+foreground+
+menu-view+
activation-character-p
add-output-record-element
add-pointer-gesture-name
add-text-style-mapping
blip-character-p
bounding-rectangle-position*
call-presentation-generic-function
command-enabled-p
compose-rotation-transformation
compose-scaling-tansformation
compose-translation-transformation
cursor-position*
cursor-set-position*
delete-output-record-element
dialog-view
disable-command
dragging-output-record
draw-character
draw-character*
draw-icon
draw-icon*
draw-string
draw-string*
enable-command
frame-top-level-window
input-position
insertion-pointer
make-color-ihs
make-color-rgb
map-over-output-record-elements
map-over-output-record-elements-containing-point*
map-over-output-record-elements-overlapping-region
menu-view
open-root-window
open-window-stream
output-record-element-count
output-record-elements
output-record-end-position*
output-record-position*
output-record-refined-sensitivity-test
output-record-set-position*
output-record-set-end-position*
output-record-set-start-position*
output-record-start-position
output-record-start-position*
output-recording-stream-current-output-record-stack
output-recording-stream-output-record
output-recording-stream-replay
point-position*
pointer-set-position*
pointer-event-shift-mask
pointer-position*
position-window-near-carefully
position-window-near-pointer
region-contains-point*-p
redisplay-1
replay-1
remove-pointer-gesture-name
rescanning-p
set-frame-layout
size-menu-appropriately
stream-cursor-position*
stream-set-cursor-position*
stream-draw-p
stream-increment-cursor-position*
stream-pointer-position*
stream-set-pointer-position*
stream-record-p
stream-vsp
transform-point*
untransform-point*
window-viewport-position*
window-set-viewport-position*
with-activation-characters
with-blip-characters
with-frame-state-variables))
#+Genera
(defmacro with-package-unlocked ((package) &body body)
`(si:with-package-lock package nil
,@body))
#-Genera
(defmacro with-package-unlocked ((package) &body body)
(declare (ignore package))
`(progn ,@body))
;; Import the above symbols into the CLIM package, then export them
(eval-when (compile load eval)
(let ((clim (find-package :clim)))
(dolist (symbol *clim-1-symbols*)
(import symbol clim)
(export symbol clim))))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved."
(clim-defsys:defsystem clim-compatibility
(:default-pathname #+Genera "SYS:CLIM;REL-2;COMPATIBILITY;"
#-Genera (frob-pathname "compatibility")
:default-binary-pathname #+Genera "SYS:CLIM;REL-2;COMPATIBILITY;"
#-Genera (frob-pathname "compatibility")
:needed-systems (clim-standalone)
:load-before-compile (clim-standalone))
("packages")
("clim1-compatibility"))
#+Genera
(clim-defsys:import-into-sct 'clim-compatibility
:pretty-name "CLIM Compatibility"
:default-pathname "SYS:CLIM;REL-2;COMPATIBILITY;"
:required-systems '(clim))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(in-package :clim-demo)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
(define-application-frame color-chooser ()
((color :accessor color :initform +black+)
red blue green
intensity hue saturation)
(:menu-bar nil)
(:panes
(display :application
:scroll-bars nil
:display-function 'display-color
;; Make sure we don't have a useless cursor blinking away...
:initial-cursor-visibility nil)
(exit push-button
:label "Exit"
:activate-callback #'(lambda (button)
(frame-exit (pane-frame button))))
(rgb (with-slots (red green blue) *application-frame*
(outlining ()
(horizontally ()
(setq red (make-pane 'slider
:label "Red" :foreground +red+
:orientation :vertical
:min-value 0.0 :max-value 1.0
:show-value-p t :decimal-places 3
:client 'color :id 'red))
(setq green (make-pane 'slider
:label "Green" :foreground +green+
:orientation :vertical
:min-value 0.0 :max-value 1.0
:show-value-p t :decimal-places 3
:client 'color :id 'green))
(setq blue (make-pane 'slider
:label "Blue" :foreground +blue+
:orientation :vertical
:min-value 0.0 :max-value 1.0
:show-value-p t :decimal-places 3
:client 'color :id 'blue))))))
(ihs (with-slots (intensity hue saturation) *application-frame*
(outlining ()
(horizontally ()
(setq intensity (make-pane 'slider
:label "Intensity"
:orientation :vertical
:min-value 0.0 :max-value (sqrt 3)
:show-value-p t :decimal-places 3
:client 'color :id 'intensity))
(setq hue (make-pane 'slider
:label "Hue"
:orientation :vertical
:min-value 0.0 :max-value 1.0
:show-value-p t :decimal-places 3
:client 'color :id 'hue))
(setq saturation (make-pane 'slider
:label "Saturation"
:orientation :vertical
:min-value 0.0 :max-value 1.0
:show-value-p t :decimal-places 3
:client 'color :id 'saturation)))))))
(:layouts
(default
(horizontally ()
(outlining ()
(vertically () display exit))
rgb ihs))))
(defmethod display-color ((frame color-chooser) stream)
(with-bounding-rectangle* (left top right bottom) (window-viewport stream)
(with-output-recording-options (stream :record nil)
(draw-rectangle* stream left top right bottom
:filled t :ink (color frame)))))
(defmacro define-rgb-callbacks (color)
(check-type color (member red green blue))
(let* ((rgb '(red green blue))
(new-rgb (substitute 'value color rgb)))
`(progn
(defmethod value-changed-callback
((slider slider) (client (eql 'color)) (id (eql ',color)) value)
(let ((frame (pane-frame slider)))
(multiple-value-bind (,@rgb) (color-rgb (color frame))
(declare (ignore ,color))
(setf (color frame) (make-rgb-color ,@new-rgb)))
(update-ihs frame)))
(defmethod drag-callback
((slider slider) (client (eql 'color)) (id (eql ',color)) value)
(let ((frame (pane-frame slider)))
(multiple-value-bind (,@rgb) (color-rgb (color frame))
(declare (ignore ,color))
(setf (color frame) (make-rgb-color ,@new-rgb)))
(update-ihs frame))))))
(define-rgb-callbacks red)
(define-rgb-callbacks green)
(define-rgb-callbacks blue)
(defmethod update-ihs ((frame color-chooser))
(with-slots (intensity hue saturation) frame
(multiple-value-bind (ii hh ss) (color-ihs (color frame))
(setf (gadget-value intensity :invoke-callback nil) ii)
(setf (gadget-value hue :invoke-callback nil) hh)
(setf (gadget-value saturation :invoke-callback nil) ss))))
(defmacro define-ihs-callbacks (color)
(check-type color (member intensity hue saturation))
(let* ((ihs '(intensity hue saturation))
(new-ihs (substitute 'value color ihs)))
`(progn
(defmethod value-changed-callback
((slider slider) (client (eql 'color)) (id (eql ',color)) value)
(let ((frame (pane-frame slider)))
(multiple-value-bind (,@ihs) (color-ihs (color frame))
(declare (ignore ,color))
(setf (color frame) (make-ihs-color ,@new-ihs)))
(update-rgb frame)))
(defmethod drag-callback
((slider slider) (client (eql 'color)) (id (eql ',color)) value)
(let ((frame (pane-frame slider)))
(multiple-value-bind (,@ihs) (color-ihs (color frame))
(declare (ignore ,color))
(setf (color frame) (make-ihs-color ,@new-ihs)))
(update-rgb frame))))))
(define-ihs-callbacks intensity)
(define-ihs-callbacks hue)
(define-ihs-callbacks saturation)
(defmethod update-rgb ((frame color-chooser))
(with-slots (red green blue) frame
(multiple-value-bind (rr gg bb) (color-rgb (color frame))
(setf (gadget-value red :invoke-callback nil) rr)
(setf (gadget-value green :invoke-callback nil) gg)
(setf (gadget-value blue :invoke-callback nil) bb))))
(defmethod value-changed-callback :after ((slider slider) (client (eql 'color)) id value)
(declare (ignore id value))
(redisplay-frame-pane (pane-frame slider) 'display))
(defvar *color-choosers* nil)
(defun do-color-chooser (&key (port (find-port)) (force nil))
(let* ((framem (find-frame-manager :port port))
(frame
(let* ((entry (assoc port *color-choosers*))
(frame (cdr entry)))
(when (or force (null frame))
(setq frame (make-application-frame 'color-chooser
:frame-manager framem)))
(if entry
(setf (cdr entry) frame)
(push (cons port frame) *color-choosers*))
frame)))
(run-frame-top-level frame)
(color frame)))
(define-demo "Color Chooser" do-color-chooser)
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved."
(clim-defsys:defsystem genera-clim
(:default-pathname #+Genera "SYS:CLIM;REL-2;GENERA;"
#-Genera (frob-pathname "genera")
:default-binary-pathname #+Genera "SYS:CLIM;REL-2;GENERA;"
#-Genera (frob-pathname "genera")
:needed-systems (clim-standalone)
:load-before-compile (clim-standalone))
("pkgdcl")
("genera-port")
("genera-mirror")
("genera-medium")
("genera-pixmaps")
("genera-frames")
("genera-activities")
("genera-prefill"))
#+Genera
(clim-defsys:import-into-sct 'genera-clim
:pretty-name "Genera CLIM"
:default-pathname "SYS:CLIM;REL-2;GENERA;"
:required-systems '(clim)
:bug-reports "Bug-CLIM"
:patches-reviewed "Bug-CLIM-Doc")
#include "/vapor/x11/R4/src/mit/lib/Xt/IntrinsicI.h"
/* $fiHeader$ */
/* Some systems running NTP daemons are known to return strange usec
* values from gettimeofday. At present (3/90) this has only been
* reported on SunOS...
*/
#ifndef NEEDS_NTPD_FIXUP
# if defined(sun) || defined(MOTOROLA)
# define NEEDS_NTPD_FIXUP 1
# else
# define NEEDS_NTPD_FIXUP 0
# endif
#endif
#if NEEDS_NTPD_FIXUP
#define FIXUP_TIMEVAL(t) { \
while ((t).tv_usec >= 1000000) { \
(t).tv_usec -= 1000000; \
(t).tv_sec++; \
} \
while ((t).tv_usec < 0) { \
if ((t).tv_sec > 0) { \
(t).tv_usec += 1000000; \
(t).tv_sec--; \
} else { \
(t).tv_usec = 0; \
break; \
} \
}}
#else
#define FIXUP_TIMEVAL(t)
#endif /*NEEDS_NTPD_FIXUP*/
/*
* Private routines
*/
#define ADD_TIME(dest, src1, src2) { \
if(((dest).tv_usec = (src1).tv_usec + (src2).tv_usec) >= 1000000) {\
(dest).tv_usec -= 1000000;\
(dest).tv_sec = (src1).tv_sec + (src2).tv_sec + 1 ; \
} else { (dest).tv_sec = (src1).tv_sec + (src2).tv_sec ; \
if(((dest).tv_sec >= 1) && (((dest).tv_usec <0))) { \
(dest).tv_sec --;(dest).tv_usec += 1000000; } } }
#define TIMEDELTA(dest, src1, src2) { \
if(((dest).tv_usec = (src1).tv_usec - (src2).tv_usec) < 0) {\
(dest).tv_usec += 1000000;\
(dest).tv_sec = (src1).tv_sec - (src2).tv_sec - 1;\
} else (dest).tv_sec = (src1).tv_sec - (src2).tv_sec; }
#define IS_AFTER(t1, t2) (((t2).tv_sec > (t1).tv_sec) \
|| (((t2).tv_sec == (t1).tv_sec)&& ((t2).tv_usec > (t1).tv_usec)))
#define IS_AT_OR_AFTER(t1, t2) (((t2).tv_sec > (t1).tv_sec) \
|| (((t2).tv_sec == (t1).tv_sec)&& ((t2).tv_usec >= (t1).tv_usec)))
/*
* This is what it's all for
*/
unsigned long XtAppIntervalNextTimer(app)
XtAppContext app;
{
struct timeval cur_time;
struct timeval wait_time;
(void) gettimeofday (&cur_time, NULL);
FIXUP_TIMEVAL(cur_time);
if(app->timerQueue != NULL && IS_AFTER(cur_time, app->timerQueue->te_timer_value))
{
TIMEDELTA (wait_time, app->timerQueue->te_timer_value, cur_time);
/*
* We add an extra 1 to ensure that events due to happen in less than
* 1000us are not lost by the rounding error of the integer divide
*/
return (1+wait_time.tv_sec*1000+wait_time.tv_usec/1000);
}
else
return 0;
}
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved."
(clim-defsys:defsystem postscript-clim
(:default-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;"
#-Genera (frob-pathname "postscript")
:default-binary-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;"
#-Genera (frob-pathname "postscript")
:needed-systems (clim-standalone)
:load-before-compile (clim-standalone))
("pkgdcl")
("postscript-port")
("postscript-medium")
("laserwriter-metrics"))
#+Genera
(clim-defsys:import-into-sct 'postscript-clim
:pretty-name "PostScript CLIM"
:default-pathname "SYS:CLIM;REL-2;POSTSCRIPT;"
:required-systems '(clim)
:bug-reports "Bug-CLIM"
:patches-reviewed "Bug-CLIM-Doc")
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;;; $fiHeader$
(defun flush-clim ()
(when (find-package 'clim-defsys)
(set (intern "*SYSTEMS*" 'clim-defsys) nil))
(dolist (pkg '(clim-lisp clim-utils clim clim-user clim-defsys defsys
clim-demo clim-graphics-editor clim-browser
;; CLIM 2.0
clim-sys clim-silica clim-internals clx-clim genera-clim
;; CLIM 0.9
clim-conditions clim-shared clim-stream
silica windshield on-x on-genera))
(when (find-package pkg)
(pkg-kill pkg)))
(dolist (sys '(clim-utils clim-standalone clim clim-demo
;; CLIM 2.0
clim-internals clim-silica genera-clim clx-clim postscript-clim
;; CLIM 0.9
silica silica-low silica-core ws ws-core ws-panes
silica-x silica-genera silica-coral-2 silica-postscript
clim-stream ws-demo clim-test ptk))
(sct:undefsystem sys)))
(defun rename-clim1 ()
(loop for (old new) in '((clim-lisp clim1-lisp)
(clim-utils clim1-utils)
(clim clim1)
(clim-user clim1-user)
(clim-demo clim1-demo)
(defsystem clim1-defsystem))
do (rename-package old new)))
(defun compile-clim2 ()
(compile-file #p"sys:clim;rel-2;sys;defsystem.lisp")
(load #p"sys:clim;rel-2;sys;defsystem")
(load #p"sys:clim;rel-2;sys;sysdcl")
(load #p"sys:clim;rel-2;genera;sysdcl")
(load #p"sys:clim;rel-2;clx;sysdcl")
(load #p"sys:clim;rel-2;postscript;sysdcl")
(sct:compile-system 'clim
:query nil :recompile t :reload t
:batch #p"sys:clim;rel-2;sys;clim.cwarns")
(sct:compile-system 'genera-clim :include-components nil
:query nil :recompile t :reload t
:batch #p"sys:clim;rel-2;sys;genera-clim.cwarns")
(sct:compile-system 'clx-clim :include-components nil
:query nil :recompile t :reload t
:batch #p"sys:clim;rel-2;sys;clx-clim.cwarns")
(sct:compile-system 'postscript-clim :include-components nil
:query nil :recompile t :reload t
:batch #p"sys:clim;rel-2;sys;postscript-clim.cwarns"))
(defun load-clim2 ()
(unless (find-package 'clim-defsys)
(load #p"sys:clim;rel-2;sys;defsystem"))
(load #p"sys:clim;rel-2;sys;sysdcl")
(load #p"sys:clim;rel-2;genera;sysdcl")
(load #p"sys:clim;rel-2;clx;sysdcl")
(load #p"sys:clim;rel-2;postscript;sysdcl")
(sct:load-system 'clim
:query nil :reload t)
(sct:load-system 'genera-clim :include-components nil
:query nil :reload t)
(sct:load-system 'clx-clim :include-components nil
:query nil :reload t)
(sct:load-system 'postscript-clim :include-components nil
:query nil :reload t))
(defun compile-clim2-demo ()
(load #p"sys:clim;rel-2;demo;sysdcl")
(sct:compile-system 'clim-demo
:query nil :recompile t :reload t
:batch #p"sys:clim;rel-2;sys;clim-demo.cwarns"))
(defun load-clim2-demo ()
(load #p"sys:clim;rel-2;demo;sysdcl")
(sct:load-system 'clim-demo
:query nil :reload t))
(defun compile-clim2-tests ()
(compile-file #p"sys:clim;rel-2;test;test-suite.lisp")
(compile-file #p"sys:clim;rel-2;test;test.lisp")
(compile-file #p"sys:clim;rel-2;test;test-sliders.lisp")
(compile-file #p"sys:clim;rel-2;test;test-buttons.lisp"))
(defun load-clim2-tests ()
(load #p"sys:clim;rel-2;test;test-suite")
(load #p"sys:clim;rel-2;test;test")
(load #p"sys:clim;rel-2;test;test-sliders")
(load #p"sys:clim;rel-2;test;test-buttons"))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment