Return-Path: Received: from proof.ergo.cs.cmu.edu by K.GP.CS.CMU.EDU id aa16859; 29 Nov 89 21:54:01 EST Received: from proof.ergo.cs.cmu.edu by PROOF.ERGO.CS.CMU.EDU id aa04128; 29 Nov 89 21:34:14 EST To: bovik@K.GP.CS.CMU.EDU Subject: clx and color Date: Wed, 29 Nov 89 21:34:08 EST Message-ID: <4126.628396448@PROOF.ERGO.CS.CMU.EDU> From: Timothy.Freeman@PROOF.ERGO.CS.CMU.EDU I posted a note asking how to use CLX and color under X. Here's the response: Replied: Thu, 16 Nov 89 14:47:26 EST Replied: "Christopher McConnell " Return-Path: Received: from a.gp.cs.cmu.edu by PROOF.ERGO.CS.CMU.EDU id aa10021; 16 Nov 89 14:43:58 EST From: Christopher McConnell Date: Thu, 16 Nov 89 14:43:48 EST To: Timothy.Freeman@PROOF.ERGO.CS.CMU.EDU In-reply-to: Timothy.Freeman's post of 15-Nov-89 22:26 Subject: CLX and color? Through last spring the code in /afs/cs/user/ccm/critters/interface.lisp worked with clx in lucid on a color sun. It does some simple color stuff. I think it was R4. Date: Fri, 17 Nov 89 12:38:40 est From: Anonymous To: timothy.freeman@CS.CMU.EDU Subject: CLX and Color Timothy, The following code runs under version 4 of CLX. I've tested the code under Lucid 2.0 and Allegro ??. The code implements very simple color menus. The last function in the file might be of interest to you. The function is called "choose-color". It allows you to mix colors using the mouse. I've sketched a quick proof (it's too large to fit in this mail message) that this is the ugliest piece of Lisp Code ever written. I don't even know if this is the "right" way to use colors in CLX. You must load the whole file before running choose-color as it depends on other stuff in the file. Anyway, I hope this helps. If you have any questions, please feel free to give me a call. -Anonymous PS: Could I get a copy of the other color examples that you get? This seems to be the easiest way to figure out how to use CLX. ----snip snip snip snip snip snip snip snip snip snip snip------- ;;; -*- Syntax: Common-Lisp; Package: USER; Base: 10; Mode: LISP -*- ;;; ;;; ;;; File: newest-menu ;;; Package: ;;; Description: color menus ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; can be changed (defvar *default-menu-font-name* "vr-20") (defvar *default-menu-fg-color-name* 'black) (defvar *default-menu-bg-color-name* 'white) (defvar *default-menu-border-color-name* 'white) (defvar *default-menu-border-width* 2) (defvar *default-menu-height-spacing* 10) (defvar *default-menu-width-spacing* 10) ;; (defvar *menu-up-arrow-image* nil) ;; (defvar *menu-up-arrow-image-file-name* "circle-up.btm") ;; (defvar *menu-down-arrow-image* nil) ;; (defvar *menu-down-arrow-image-file-name* "circle-down.btm") (defvar *menu-debug* nil) (defvar *menu-test-menu0*) (defvar *menu-test-menu1*) (defvar *menu-host-name* #-allegro (machine-instance) #+allegro (progn (format t "~%You are running in allegro common lisp.") (format t "~%Please enter your machine name: ") (string-downcase (string (read *standard-input* nil 'henry))))) #| (defun menu-initialize-arrows () (unless *menu-up-arrow-image* (setf *menu-up-arrow-image* (xlib:read-bitmap-file *menu-up-arrow-image-file-name*))) (unless *menu-down-arrow-image* (setf *menu-down-arrow-image* (xlib:read-bitmap-file *menu-down-arrow-image-file-name*)))) |# (defvar *menu-display* (xlib:open-display *menu-host-name*)) (defvar *menu-screen* (xlib:display-default-screen *menu-display*)) (defvar *menu-root* (xlib:screen-root *menu-screen*)) (defvar *menu-color-map* (xlib:screen-default-colormap *menu-screen*)) ;; (defvar *menu-temporary* (menu-initialize-arrows)) (defvar *menu-font-alist* nil) (defvar *menu-color-alist* nil) (defvar *menu-color-name-value-alist* nil) (setq *menu-color-name-value-alist* '((black :red 0.0 :green 0.0 :blue 0.0) (white :red 1.0 :green 1.0 :blue 1.0) (red :red 1.0 :green 0.0 :blue 0.0) (green :red 0.0 :green 1.0 :blue 0.0) (blue :red 0.0 :green 0.0 :blue 1.0) (hot-pink :red 1.0 :green 0.0 :blue 1.0))) (defun menu-reset-globals () (setf *menu-display* (xlib:open-display *menu-host-name*)) (setf *menu-screen* (xlib:display-default-screen *menu-display*)) (setf *menu-root* (xlib:screen-root *menu-screen*)) (setf *menu-color-map* (xlib:screen-default-colormap *menu-screen*)) ;; (menu-initialize-arrows) ) (defmacro with-color ((gc color) &rest body) `(let ((old-color (xlib:gcontext-foreground ,gc))) (setf (xlib:gcontext-foreground ,gc) ,color) ,@ body (setf (xlib:gcontext-foreground ,gc) old-color))) (defstruct menu (title "Untitled Menu") (choices nil) (centered-p nil) (multi-p nil) (horizontal-p nil) (font-name *default-menu-font-name*) (fg-color-name *default-menu-fg-color-name*) (bg-color-name *default-menu-bg-color-name*) (border-color-name *default-menu-border-color-name*) (border-width *default-menu-border-width*) (height-spacing *default-menu-height-spacing*) (width-spacing *default-menu-width-spacing*) (max-choices-per-menu nil) (x 0) (y 0) ;; the following should not be set by the user (short-p nil) char-width char-height entry-width entry-height window window-width window-height font fg-color bg-color border-color gc) (defstruct choice name ;; actions can be ;; menus ;; symbols ;; strings ;; functions action ;; internal -- do not change. (selected-p nil)) (defun menu-open-font (font-name) (let ((font (cdr (assoc font-name *menu-font-alist*)))) (unless font (unless (xlib:list-font-names *menu-display* font-name) (error "Font: ~a is not available. Type 'xlsfonts' at the shell to find the available fonts.")) (setf font (xlib:open-font *menu-display* font-name)) (push (cons font-name font) *menu-font-alist*)) font)) (defun menu-open-color (color-name) (let ((color (cdr (assoc color-name *menu-color-alist*))) (color-rgb nil)) (unless color (setf color-rgb (cdr (assoc color-name *menu-color-name-value-alist*))) (unless color-rgb (error "Unable to find color: ~a~%Use 'menu-add-color' to add a color." color-name)) (setf color (xlib:alloc-color *menu-color-map* (eval `(xlib:make-color ,@color-rgb)))) (push (cons color-name color) *menu-color-alist*)) color)) (defun menu-erase (menu) (when (menu-window menu) (xlib:unmap-window (menu-window menu)) (xlib:display-force-output *menu-display*))) (defun menu-create-window (menu) (setf (menu-window menu) (xlib:create-window :parent *menu-root* :x (menu-x menu) :y (menu-y menu) :width (menu-window-width menu) :height (menu-window-height menu) :background (menu-bg-color menu) :backing-store :always :colormap *menu-color-map* :event-mask '(:button-press) :border-width (menu-border-width menu) :border (menu-border-color menu) :override-redirect :on)) (setf (menu-gc menu) (xlib:create-gcontext :drawable (menu-window menu) :foreground (menu-fg-color menu) :background (menu-bg-color menu) :fill-style :solid :font (menu-font menu) :function boole-1)) menu) (defun menu-make-window (menu) (if (menu-horizontal-p menu) (menu-make-window-horiz menu) (menu-make-window-vert menu))) (defun menu-reset-params (menu) (let ((window (menu-window menu)) (gc (menu-gc menu))) (setf (menu-font menu) (menu-open-font (menu-font-name menu))) (setf (menu-fg-color menu) (menu-open-color (menu-fg-color-name menu))) (setf (menu-bg-color menu) (menu-open-color (menu-bg-color-name menu))) (setf (menu-border-color menu) (menu-open-color (menu-border-color-name menu))) (if (menu-horizontal-p menu) (menu-reset-params-horiz menu) (menu-reset-params-vert menu)) (when window (setf (xlib:gcontext-font gc) (menu-font menu)) (setf (xlib:gcontext-foreground gc) (menu-fg-color menu)) (setf (xlib:window-background window) (menu-bg-color menu)) (setf (xlib:drawable-x window) (menu-x menu)) (setf (xlib:drawable-y window) (menu-y menu)) (setf (xlib:drawable-height window) (menu-window-height menu)) (setf (xlib:drawable-width window) (menu-window-width menu))))) (defun menu-make-window-vert (menu) (menu-reset-params menu) (menu-create-window menu) (menu-redraw-vert menu)) (defun find-longest-string (lst font) (let ((longest-string-len -1) (longest-string nil) (tmp-len -1)) (dolist (string lst longest-string) (when (> (setq tmp-len (xlib:text-width font string)) longest-string-len) (setq longest-string-len tmp-len) (setq longest-string string))))) (defun menu-reset-params-vert (menu) (let ((choices (menu-choices menu)) (char-width 0) (char-height 0) (entry-width 0) (entry-height 0) (max-string 0) (max-choices-per-menu 0) (font (menu-font menu))) (setq max-string (find-longest-string (cons (menu-title menu) (mapcar #'choice-name choices)) font)) (setq char-height (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) (setf (menu-char-height menu) char-height) (setq char-width (xlib:max-char-width font)) (setf (menu-char-width menu) char-width) (setq entry-width (xlib:text-width font max-string)) (setq entry-height (+ (menu-height-spacing menu) char-height)) (when (menu-multi-p menu) (setq entry-width (+ entry-width (* 3 char-width)))) (setf (menu-entry-width menu) entry-width) (setf (menu-entry-height menu) entry-height) ;; set the height appropriately (if (and (setf max-choices-per-menu (menu-max-choices-per-menu menu)) (< max-choices-per-menu (length choices))) (progn (setf (menu-short-p menu) t) (setf (menu-window-height menu) (* (+ 2 max-choices-per-menu) entry-height))) (progn (setf (menu-max-choices-per-menu menu) (length choices)) (setf (menu-window-height menu) (* (1+ (length choices)) entry-height)))) (setf (menu-window-width menu) entry-width) (when *menu-debug* (format t "~%MAKE-MENU-WINDOW: max-string-len: ~s" max-string) (format t "~%MAKE-MENU-WINDOW: char-height: ~d" char-height) (format t "~%MAKE-MENU-WINDOW: char-width: ~d" char-width) (format t "~%MAKE-MENU-WINDOW: entry-width: ~d" entry-width) (format t "~%MAKE-MENU-WINDOW: entry-height: ~d" entry-height) (format t "~%MAKE-MENU-WINDOW: window-height: ~d" (menu-window-height menu)) menu))) (defun menu-make-window-horiz (menu) (menu-reset-params menu) (menu-create-window menu) (menu-redraw-horiz menu)) (defun menu-reset-params-horiz (menu) (let ((choices (menu-choices menu)) (char-width 0) (char-height 0) (entry-width 0) (entry-height 0) (max-string 0) (font (menu-font menu))) (setq max-string (find-longest-string (cons (menu-title menu) (mapcar #'choice-name choices)) font)) (setq char-height (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) (setf (menu-char-height menu) char-height) (setq char-width (xlib:max-char-width font)) (setf (menu-char-width menu) char-width) (setq entry-width (+ (xlib:text-width font max-string) (menu-width-spacing menu))) (setq entry-height (+ (menu-height-spacing menu) char-height)) (when (menu-multi-p menu) (setq entry-width (+ entry-width (* 3 char-width)))) (setf (menu-entry-width menu) entry-width) (setf (menu-entry-height menu) entry-height) (setf (menu-window-width menu) (* (1+ (length choices)) entry-width)) (setf (menu-window-height menu) entry-height) (when *menu-debug* (format t "~%MAKE-MENU-WINDOW: max-string-len: ~s" max-string) (format t "~%MAKE-MENU-WINDOW: char-height: ~d" char-height) (format t "~%MAKE-MENU-WINDOW: char-width: ~d" char-width) (format t "~%MAKE-MENU-WINDOW: entry-width: ~d" entry-width) (format t "~%MAKE-MENU-WINDOW: entry-height: ~d" entry-height) (format t "~%MAKE-MENU-WINDOW: window-width: ~d" (menu-window-width menu))) menu)) (defun menu-redraw-vert-choices (menu &key (first-choice-num 0) (clear-p nil)) (let ((window (menu-window menu)) (gc (menu-gc menu)) (fg-color (menu-fg-color menu)) (bg-color (menu-bg-color menu)) (entry-width (menu-entry-width menu)) (entry-height (menu-entry-height menu)) (char-width (menu-char-width menu)) (height-spacing (menu-height-spacing menu)) (centered-p (menu-centered-p menu)) (multi-p (menu-multi-p menu)) (last-choice-num 0) (actual-choice-num 0) (string "") (choices (menu-choices menu)) (font (menu-font menu)) (y-start 0) (actual-y-start 0) (x-start 0) (max-char-descent 0) (choice nil)) (flet ((compute-x-y-start (n string) (setq y-start (* (+ 2 n) entry-height)) (if centered-p (setq x-start (floor (- entry-width (xlib:text-width font string)) 2)) (setq x-start 0)) ;; move over for multiple menus. (when multi-p (if centered-p (setq x-start (+ (floor (* 3 char-width) 2) x-start)) (setq x-start (+ (* 3 char-width) x-start)))))) (setf max-char-descent (xlib:max-char-descent font)) (with-color (gc fg-color) (xlib:draw-line window gc 0 entry-height entry-width entry-height) (if (menu-short-p menu) (setf last-choice-num (menu-max-choices-per-menu menu)) (setf last-choice-num (length choices))) (when clear-p (with-color (gc bg-color) (xlib:clear-area window :x 0 :y entry-height :width entry-width :height (* entry-height last-choice-num)))) (dotimes (n last-choice-num) (setf actual-choice-num (+ n first-choice-num)) (setf choice (nth actual-choice-num choices)) (setq string (choice-name choice)) (compute-x-y-start n string) ;; draw the line (unless (= n (1- last-choice-num)) (xlib:draw-line window gc 0 y-start entry-width y-start)) (setf actual-y-start (- y-start max-char-descent (floor height-spacing 2))) (xlib:draw-glyphs window gc x-start actual-y-start string) (when (choice-selected-p choice) (xlib:draw-glyph window gc char-width actual-y-start #\*))) ;; draw the "Up | Down" Menu item. (when (and (menu-short-p menu) (not clear-p)) (setf centered-p t) (setf multi-p nil) (setf string "UP | DOWN") (compute-x-y-start last-choice-num string) (xlib:draw-line window gc 0 (- y-start entry-height) entry-width (- y-start entry-height)) (setf actual-y-start (- y-start max-char-descent (floor height-spacing 2))) (xlib:draw-glyphs window gc x-start actual-y-start string)))))) #| (xlib:put-image window gc *menu-up-arrow-image* :x x-start :y (- y-start entry-height) :bitmap-p t) (xlib:put-image window gc *menu-down-arrow-image* :x (+ x-start (floor entry-width 2)) :y (- y-start entry-height) :bitmap-p t) |# (defun menu-redraw-vert (menu) (let ((window (menu-window menu)) (gc (menu-gc menu)) (fg-color (menu-fg-color menu)) (bg-color (menu-bg-color menu)) (entry-width (menu-entry-width menu)) (entry-height (menu-entry-height menu)) (height-spacing (menu-height-spacing menu)) (width-spacing (menu-width-spacing menu)) (string "") (font (menu-font menu))) (with-color (gc bg-color) (xlib:clear-area window)) ;; now draw the stuff on the menu (setq string (menu-title menu)) ;; inverse video the title box (with-color (gc fg-color) (xlib:draw-rectangle window gc 0 0 entry-width entry-height t)) ;; draw the title. Don't ever center it. (with-color (gc bg-color) (xlib:draw-glyphs window gc (floor width-spacing 2) (- (- entry-height (xlib:max-char-descent font)) (floor height-spacing 2)) string)) (menu-redraw-vert-choices menu))) (defun menu-redraw-horiz (menu) (let ((window (menu-window menu)) (gc (menu-gc menu)) (fg-color (menu-fg-color menu)) (bg-color (menu-bg-color menu)) (entry-width (menu-entry-width menu)) (entry-height (menu-entry-height menu)) (char-width (menu-char-width menu)) (height-spacing (menu-height-spacing menu)) (width-spacing (menu-width-spacing menu)) (centered-p (menu-centered-p menu)) (multi-p (menu-multi-p menu)) (string "") (font (menu-font menu)) (choices (menu-choices menu)) (text-y 0) (line-x 0) (x-start 0)) ;; this is where we draw all of the text. (setq text-y (- (- entry-height (xlib:max-char-descent font)) (floor height-spacing 2))) (with-color (gc bg-color) (xlib:clear-area window)) ;; now draw the stuff on the menu (setq string (menu-title menu)) ;; (setq x-start ;; (if centered-p ;; (floor (- width (* char-width (length string))) 2) ;; 0)) ;; inverse video the title box (with-color (gc fg-color) (xlib:draw-rectangle window gc 0 0 entry-width entry-height t)) ;; draw the title. Don't ever center it. (with-color (gc bg-color) (xlib:draw-glyphs window gc (floor width-spacing 2) text-y string)) (with-color (gc fg-color) (xlib:draw-line window gc entry-width 0 entry-width entry-height) (dotimes (n (length choices)) (setq x-start (* (1+ n) entry-width)) (setq line-x x-start) (setq string (choice-name (nth n choices))) (when centered-p (setq x-start (+ x-start (floor (- entry-width (xlib:text-width font string)) 2)))) ;; move over for multiple menus. (when multi-p (if centered-p (setq x-start (+ x-start (floor (* 3 char-width) 2))) (setq x-start (+ x-start (* 3 char-width))))) (xlib:draw-line window gc line-x 0 line-x entry-height) (xlib:draw-glyphs window gc x-start text-y string)) ) ) ) (defun menu-choose (menu) (let ((return-value nil) (horiz-p (menu-horizontal-p menu))) (unless (menu-window menu) (if horiz-p (menu-make-window-horiz menu) (menu-make-window-vert menu))) (menu-clear-events) ;; reset the choices for a multi-menu (when (menu-multi-p menu) (dolist (choice (menu-choices menu)) (setf (choice-selected-p choice) nil))) (if horiz-p (menu-redraw-horiz menu) (menu-redraw-vert menu)) (xlib:map-window (menu-window menu)) (xlib:display-force-output *menu-display*) (if horiz-p (setf return-value (menu-get-choice-horiz menu)) (setf return-value (menu-get-choice-vert menu))) return-value)) ;; This will clear events that happened when we were not looking for them. (defun menu-clear-events () (xlib:display-finish-output *menu-display*) (loop (unless (xlib:discard-current-event *menu-display*) (return)))) (defun menu-get-choice-vert (menu) (let ((win (menu-window menu)) (gc (menu-gc menu)) (bg-color (menu-bg-color menu)) (fg-color (menu-fg-color menu)) (entry-height (menu-entry-height menu)) (half-entry-width (floor (menu-entry-width menu) 2)) (char-width (menu-char-width menu)) (height-spacing (menu-height-spacing menu)) (multi-p (menu-multi-p menu)) (choices (menu-choices menu)) (max-descent (xlib:max-char-descent (menu-font menu))) (max-choices-per-menu (menu-max-choices-per-menu menu)) (y-start 0) (first-choice-num 0) (object-number nil)) (unwind-protect (loop (xlib:event-case (*menu-display* :discard-p t :force-output-p t) (button-press (window x y) (when (xlib:window-equal window win) (setq object-number (floor y entry-height)) (when *menu-debug* (format t "~%MENU-GET-CHOICE: Button press at: <~d,~d>" x y) (format t "~%MENU-GET-CHOICE: --- guess ~d" object-number)) (cond ((= object-number (1+ max-choices-per-menu)) (if (< x half-entry-width) ;; rotate up (when (> first-choice-num 0) (when *menu-debug* (format t "~%MENU-GET-CHOICE: Rotate up")) (setf first-choice-num (1- first-choice-num)) (menu-redraw-vert-choices menu :first-choice-num first-choice-num :clear-p t)) (when (< first-choice-num (- (length choices) max-choices-per-menu)) (when *menu-debug* (format t "~%MENU-GET-CHOICE:Rotate down")) (setf first-choice-num (1+ first-choice-num)) (menu-redraw-vert-choices menu :first-choice-num first-choice-num :clear-p t)))) (multi-p (cond ((or (< object-number 0) (> object-number (length choices))) nil) ((= object-number 0) (xlib:discard-current-event *menu-display*) ;; get rid of the menu if necessary (xlib:unmap-window win) (xlib:display-force-output *menu-display*) (return-from menu-get-choice-vert (mapcar #'(lambda (choice) (menu-eval-choice choice)) (get-selected-choices choices)))) (t (setq y-start (* (1+ object-number) entry-height)) (if (choice-selected-p (nth (+ (1- object-number) first-choice-num) choices)) (with-color (gc bg-color) (xlib:draw-glyph win gc char-width (- y-start max-descent (floor height-spacing 2)) #\*)) (with-color (gc fg-color) (xlib:draw-glyph win gc char-width (- y-start max-descent (floor height-spacing 2)) #\*))) (setf (choice-selected-p (nth (+ (1- object-number) first-choice-num) choices)) (not (choice-selected-p (nth (+ (1- object-number) first-choice-num) choices)))) nil))) (t (cond ((or (< object-number 0) (> object-number (length choices))) nil) ((not (= object-number 0)) (xlib:discard-current-event *menu-display*) ;; get rid of the menu if necessary (xlib:unmap-window win) (xlib:display-force-output *menu-display*) (return-from menu-get-choice-vert (menu-eval-choice (nth (+ (1- object-number) first-choice-num) choices)))) (t nil)))))) (otherwise () (when *menu-debug* (format t "~%MENU-GET-CHOICE: Unexpexcted event")) nil))) (xlib:unmap-window win) (xlib:display-force-output *menu-display*)))) (defun menu-get-choice-horiz (menu) (let ((win (menu-window menu)) (menu-y-end nil) (entry-width (menu-entry-width menu)) (choices (menu-choices menu)) (object-number nil)) ;; (setf menu-y-end (+ (xlib:drawable-y win) (xlib:drawable-height win) ;; (* 2 (menu-border-width menu)))) (setf menu-y-end (+ (menu-y menu) (menu-window-height menu) (* 2 (menu-border-width menu)))) (unwind-protect (loop (xlib:event-case (*menu-display* :discard-p t :force-output-p t) (button-press (window x y) (when (xlib:window-equal window win) (setq object-number (floor x entry-width)) (when *menu-debug* (format t "~%MENU-GET-CHOICE: Button press at: <~d,~d>" x y) (format t "~%MENU-GET-CHOICE: --- guess ~d" object-number)) (cond ((= object-number 0) (return-from menu-get-choice-horiz nil)) ((or (< object-number 0) (> object-number (length choices))) nil) ((not (= object-number 0)) (xlib:discard-current-event *menu-display*) ;; get rid of the menu if necessary (menu-eval-choice (nth (1- object-number) choices) (+ (* (floor x entry-width) entry-width) (menu-x menu) (menu-border-width menu)) menu-y-end) ;; why isn't this effective??? (menu-clear-events) nil) (t nil)))) (otherwise () (when *menu-debug* (format t "~%MENU-GET-CHOICE: Unexpexcted event")) nil))) (xlib:unmap-window win) (xlib:display-force-output *menu-display*)))) (defun get-selected-choices (choices) (let ((return-value nil)) (dolist (choice choices) (when (choice-selected-p choice) (push choice return-value))) (nreverse return-value))) (defun menu-kill (menu) (when (menu-gc menu) (xlib:free-gcontext (menu-gc menu)) (setf (menu-gc menu) nil)) (when (menu-window menu) (xlib:destroy-window (menu-window menu)) (setf (menu-window menu) nil))) (defun menu-eval-choice (choice &optional (x nil) (y nil)) (let ((action (choice-action choice))) (typecase action (list (if (fboundp (car action)) (eval action) action)) (symbol (if (fboundp action) (funcall action) action)) (string action) (menu ;; if the current menu isn't horizontal then delete it. ;; (unless (menu-horizontal-p menu) ;; (xlib:unmap-window (menu-window menu)) ;; (xlib:display-force-output *menu-display*)) (when x (setf (menu-x action) x)) (when y (setf (menu-y action) y)) (when (or x y) (menu-reset-params action)) (menu-choose action)) (number action) (otherwise (error "Unexpected action in menu choice: ~a" action))))) (defun make-test-menu () (setf *menu-test-menu0* (make-menu :centered-p t :horizontal-p nil :x 0 :y 200 :fg-color-name 'red :bg-color-name 'blue :max-choices-per-menu 2 :title "A multiple menu" :multi-p t :choices (list (make-choice :name "The first choice" :action 1) (make-choice :name "and choice two" :action 2) (make-choice :name "and number three" :action 2) (make-choice :name "four" :action 3) (make-choice :name "five" :action 3) (make-choice :name "and six" :action 4)))) (setf *menu-test-menu1* (make-menu :centered-p t :horizontal-p t :title "The first menu" :choices (list (make-choice :name "da da doo it" :action *menu-test-menu0*) (make-choice :name "quit" :action 'menu-quit) (make-choice :name "Yes or No" :action '(y-or-n-p "Yes or no?")) (make-choice :name "recursion" :action *menu-test-menu0*))))) ;;; Stuff for viewing fonts............ ;; (defun make-font-menu (font-name) (make-menu :font-name font-name :multi-p t :title (format nil "Font: ~a" font-name) :choices (list (make-choice :name "ABCDEFGHIJKLMNOPQRSTUVWXYZ" :action 1) (make-choice :name "abcdefghijklmnopqrstuvwxyz" :action 2)))) (defvar *menu-test-font-menu* (make-font-menu *default-menu-font-name*)) (defun menu-test-font (font-name &optional (fm *menu-test-font-menu*)) (let ((font (menu-open-font font-name))) (setf (menu-title fm) (format nil "Font: ~a (width ~a) (height ~a)" font-name (xlib:max-char-width font) (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))) (setf (menu-font-name fm) font-name) (menu-reset-params fm) (menu-choose fm))) (defun bounds-check (num &optional (start 0.0) (end 1.0)) (cond ((< num start) start) ((> num end) end) (t num))) (defun menu-add-color () (let ((color (choose-color)) (color-name nil)) (if color (progn (format t "~%Enter the name of the color: ") (setf color-name (read *standard-input* nil nil)) (when color-name (push (cons color-name color) *menu-color-name-value-alist*) (format t "Added color '~a' = ~a" color-name color))) (format t "~%Aborted: no color added.")))) (defun choose-color (&key (font-name "vr-31") (win-height 500) (win-width 500) (red 1.0) (green 1.0) (blue 1.0)) (let ((display *menu-display*) (screen *menu-screen*) (root *menu-root*) (colormap *menu-color-map*) (font (menu-open-font font-name)) (button-down nil) (direction 0) (delta .01) (slab-height (floor (/ win-height 5))) (color-active nil) (last-color-allocated nil) (abort-p nil) (first-time t) window-pixel text-pixel red-pixel green-pixel blue-pixel gcontext win text-x-start text-y-start all-rgb-colors temp-char) (flet ((free-color (color) (unless (member color all-rgb-colors) (xlib:free-colors colormap (list color)))) (x-center-text (string) (floor (- win-width (xlib:text-width font string)) 2)) (draw-prop-colorbar (y-start color percent) (let ((bar-finish (round (* win-width percent)))) (setf (xlib:gcontext-foreground gcontext) color) (xlib:draw-rectangle win gcontext 0 y-start bar-finish slab-height t) (setf (xlib:gcontext-foreground gcontext) window-pixel) (xlib:draw-rectangle win gcontext (1+ bar-finish) y-start (- win-width bar-finish) slab-height t)))) (flet ((get-current-color () (when last-color-allocated (free-color last-color-allocated)) (setf last-color-allocated (xlib:alloc-color colormap (xlib:make-color :red red :green green :blue blue)))) (update-rgb (&optional (string nil)) (draw-prop-colorbar slab-height window-pixel 1.0) (setf (xlib:gcontext-foreground gcontext) text-pixel) (if string (xlib:draw-glyphs win gcontext (x-center-text string) text-y-start string) (xlib:draw-glyphs win gcontext text-x-start text-y-start (format nil "Red: ~4,2f Green: ~4,2f Blue: ~4,2f" red green blue))))) ;; ;; initialization ;; ;; (setf window-pixel (xlib:screen-white-pixel screen)) (setf text-pixel (xlib:screen-black-pixel screen)) (setf red-pixel (xlib:alloc-color colormap (xlib:make-color :red 1.0 :green 0.0 :blue 0.0))) (setf green-pixel (xlib:alloc-color colormap (xlib:make-color :red 0.0 :green 1.0 :blue 0.0))) (setf blue-pixel (xlib:alloc-color colormap (xlib:make-color :red 0.0 :green 0.0 :blue 1.0))) (setf gcontext (xlib:create-gcontext :drawable root :function boole-1 :foreground window-pixel :font font :background window-pixel)) (setf win (xlib:create-window :parent root :x 100 :y 100 :width win-width :height win-height :border-width 1 :override-redirect :off :background window-pixel :colormap colormap :event-mask '(:key-press :button-press :button-release :exposure :resize-redirect ))) ;;icing on the cake (setf (xlib:wm-name win) "Pick a Color") (setf (xlib:wm-icon-name win) "Pick a Color") (setf win-height (* (floor win-height 5) 5)) (setf text-x-start (x-center-text "Red: ~0.00 Green: 0.00 Blue: 0.00")) (setf text-y-start (- (* 2 slab-height) (floor (- slab-height (+ (xlib:char-ascent font (car (xlib:character->keysyms #\X))) (xlib:char-descent font (car (xlib:character->keysyms #\X))))) 2))) (setf all-rgb-colors (list red-pixel green-pixel blue-pixel text-pixel window-pixel)) (menu-clear-events) (xlib:map-window win) (unwind-protect (loop (unless (xlib:event-listen display 0) (when button-down (case color-active (2 ;; red (setf red (bounds-check (+ red (* direction delta)))) (draw-prop-colorbar (* 2 slab-height) red-pixel red)) (3 ;; green (setf green (bounds-check (+ green (* direction delta)))) (draw-prop-colorbar (* 3 slab-height) green-pixel green)) (4 ;; blue (setf blue (bounds-check (+ blue (* direction delta)))) (draw-prop-colorbar (* 4 slab-height) blue-pixel blue))) (draw-prop-colorbar 0 (get-current-color) 1.0) (update-rgb) ;; (format t "~%R: ~4,2f, G: ~4,2f, B: ~4,2f, ca: ~d, direction: ~d" ;; red green blue color-active direction) )) (when (xlib:event-case (display :discard-p t :timeout 0) ((:exposure) () (draw-prop-colorbar (* 2 slab-height) red-pixel red) (draw-prop-colorbar (* 3 slab-height) green-pixel green) (draw-prop-colorbar (* 4 slab-height) blue-pixel blue) (draw-prop-colorbar 0 (get-current-color) 1.0) (if first-time (progn (setf first-time nil) (update-rgb "'A' = abort, 'Q' = quit")) (update-rgb))) ((:resize-request) (width height) (xlib:clear-area win) (setf win-width width) (setf win-height (* (floor height 5) 5)) ;; don't want to recurse forever... (setf (xlib:window-override-redirect win) :on) (setf (xlib:drawable-width win) win-width) (setf (xlib:drawable-height win) win-height) (setf (xlib:window-override-redirect win) :off) (setf slab-height (floor (/ win-height 5))) (draw-prop-colorbar (* 2 slab-height) red-pixel red) (draw-prop-colorbar (* 3 slab-height) green-pixel green) (draw-prop-colorbar (* 4 slab-height) blue-pixel blue) (draw-prop-colorbar 0 (get-current-color) 1.0) (setf text-x-start (x-center-text "Red: ~0.00 Green: 0.00 Blue: 0.00")) (setf text-y-start (- (* 2 slab-height) (floor (- slab-height (+ (xlib:char-ascent font (car (xlib:character->keysyms #\X))) (xlib:char-descent font (car (xlib:character->keysyms #\X))))) 2))) (update-rgb) (xlib:display-force-output display)) ((:key-press) (code state) ;; why doesn't keycode->character return a char all the time? (setf temp-char (xlib:keycode->character display code state)) (when (characterp temp-char) (cond ((char-equal temp-char #\a) (setf abort-p t)) ((char-equal temp-char #\q) t) (t nil)))) ((:button-release) () (draw-prop-colorbar 0 (get-current-color) 1.0) (setf button-down nil) nil) ((:button-press) (x y code) (setf color-active (floor y slab-height)) (when (> color-active 1) (setf button-down t) (cond ((= code 2) (case color-active (2 ;; red (setf red (/ x (float win-width)))) (3 (setf green (/ x (float win-width)))) (4 (setf blue (/ x (float win-width))))) (setf direction 0)) ((or (= code 1) (= code 3)) (setf button-down t) (setf direction (if (= code 1) -1 1))))) nil)) (if abort-p (return nil) (return (list :red red :green green :blue blue))))) (xlib:free-gcontext gcontext) (xlib:destroy-window win) (xlib:display-finish-output *menu-display*))))))