Skip to content
Snippets Groups Projects
Commit fc195c60 authored by dtc's avatar dtc
Browse files

CMUCL MP support by Douglas Crosher.

Enhancements including a CLX menu, rewrite of the greynetic demo, and
other fixes by Fred Gilham.
parent c45a3fa3
No related branches found
No related tags found
No related merge requests found
...@@ -2,8 +2,8 @@ Package Name: ...@@ -2,8 +2,8 @@ Package Name:
DEMOS DEMOS
Description: Description:
Graphics demonstration programs for CMU Common Lisp using version 11 of the Graphics demonstration programs for CMU Common Lisp using version 11
X Window System. of the X Window System.
Author: Author:
CMU Common Lisp Group. CMU Common Lisp Group.
...@@ -17,22 +17,23 @@ Address: ...@@ -17,22 +17,23 @@ Address:
Pittsburgh, PA 15213 Pittsburgh, PA 15213
Net Address: Net Address:
slisp-group@b cmucl-imp@cons.org
Copyright Status: Copyright Status:
Public Domain. Public Domain.
Files: Files:
demos.lisp, demos.fasl, demos.catalog. demos.lisp, demos.fasl, demos.catalog.menu.lisp
How to Get: How to Get:
The following unix command will copy the pertinent files into directory The following unix command will copy the pertinent files into directory
<spec>: <spec>:
cp /afs/cs.cmu.edu/project/slisp/library/demos/* <spec> cp .../library/demos/* <spec>
Portability: Portability:
Should run in any Common Lisp supporting CLX V11R3. Should run in any Common Lisp supporting CLX V11R4.
Instructions: Instructions:
The function DEMOS:DO-ALL-DEMOS will run through each of the demos once, and The function DEMOS:DO-ALL-DEMOS will run through each of the demos
the function DEMOS:DEMO will present a menu of all the demos. once, and the function DEMOS:DEMO will present a menu of all the
demos.
This diff is collapsed.
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1988 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
;;;----------------------------------------------------------------------------------+
;;; |
;;; These functions demonstrate a simple menu implementation described in |
;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. |
;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. |
;;; |
;;;----------------------------------------------------------------------------------+
(defstruct (menu)
"A simple menu of text strings."
(title "choose an item:")
item-alist ;((item-window item-string))
window
gcontext
width
title-width
item-width
item-height
(geometry-changed-p t)) ;nil iff unchanged since displayed
(defun create-menu (parent-window text-color background-color text-font)
(make-menu
;; Create menu graphics context
:gcontext (CREATE-GCONTEXT :drawable parent-window
:foreground text-color
:background background-color
:font text-font)
;; Create menu window
:window (CREATE-WINDOW
:parent parent-window
:class :input-output
:x 0 ;temporary value
:y 0 ;temporary value
:width 16 ;temporary value
:height 16 ;temporary value
:border-width 2
:border text-color
:background background-color
:save-under :on
;; :override-redirect :on ;override window mgr when positioning
:event-mask (MAKE-EVENT-MASK :leave-window :exposure))))
(defun menu-set-item-list (menu item-strings)
;; Assume the new items will change the menu's width and height
(setf (menu-geometry-changed-p menu) t)
;; Destroy any existing item windows
(dolist (item (menu-item-alist menu))
(DESTROY-WINDOW (first item)))
;; Add (item-window item-string) elements to item-alist
(setf (menu-item-alist menu)
(let (alist)
(dolist (item item-strings (nreverse alist))
(push (list (CREATE-WINDOW
:parent (menu-window menu)
:x 0 ;temporary value
:y 0 ;temporary value
:width 16 ;temporary value
:height 16 ;temporary value
:background (GCONTEXT-BACKGROUND (menu-gcontext menu))
:event-mask (MAKE-EVENT-MASK :enter-window
:leave-window
:button-press
:button-release))
item)
alist)))))
(defparameter *menu-item-margin* 4
"Minimum number of pixels surrounding menu items.")
(defun menu-recompute-geometry (menu)
(when (menu-geometry-changed-p menu)
(let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu)))
(title-width (TEXT-EXTENTS menu-font (menu-title menu)))
(item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font)))
(item-width 0)
(items (menu-item-alist menu))
menu-width)
;; Find max item string width
(dolist (next-item items)
(setf item-width (max item-width
(TEXT-EXTENTS menu-font (second next-item)))))
;; Compute final menu width, taking margins into account
(setf menu-width (max title-width
(+ item-width *menu-item-margin* *menu-item-margin*)))
(let ((window (menu-window menu))
(delta-y (+ item-height *menu-item-margin*)))
;; Update width and height of menu window
(WITH-STATE (window)
(setf (DRAWABLE-WIDTH window) menu-width
(DRAWABLE-HEIGHT window) (+ *menu-item-margin*
(* (1+ (length items))
delta-y))))
;; Update width, height, position of item windows
(let ((item-left (round (- menu-width item-width) 2))
(next-item-top delta-y))
(dolist (next-item items)
(let ((window (first next-item)))
(WITH-STATE (window)
(setf (DRAWABLE-HEIGHT window) item-height
(DRAWABLE-WIDTH window) item-width
(DRAWABLE-X window) item-left
(DRAWABLE-Y window) next-item-top)))
(incf next-item-top delta-y))))
;; Map all item windows
(MAP-SUBWINDOWS (menu-window menu))
;; Save item geometry
(setf (menu-item-width menu) item-width
(menu-item-height menu) item-height
(menu-width menu) menu-width
(menu-title-width menu) title-width
(menu-geometry-changed-p menu) nil))))
(defun menu-refresh (menu)
(xlib:set-wm-properties (menu-window menu)
:name (menu-title menu)
:icon-name (menu-title menu)
:resource-name (menu-title menu))
(let* ((gcontext (menu-gcontext menu))
(baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext))))
;; Show title centered in "reverse-video"
(let ((fg (GCONTEXT-BACKGROUND gcontext))
(bg (GCONTEXT-FOREGROUND gcontext)))
(WITH-GCONTEXT (gcontext :foreground fg :background bg)
(DRAW-IMAGE-GLYPHS
(menu-window menu)
gcontext
(round (- (menu-width menu)
(menu-title-width menu)) 2) ;start x
baseline-y ;start y
(menu-title menu))))
;; Show each menu item (position is relative to item window)
(dolist (item (menu-item-alist menu))
(DRAW-IMAGE-GLYPHS
(first item) gcontext
0 ;start x
baseline-y ;start y
(second item)))))
(defun menu-choose (menu x y)
;; Display the menu so that first item is at x,y.
(menu-present menu x y)
(let ((items (menu-item-alist menu))
(mw (menu-window menu))
selected-item)
;; Event processing loop
(do () (selected-item)
(EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t)
(:exposure (count)
;; Discard all but final :exposure then display the menu
(when (zerop count) (menu-refresh menu))
t)
(:button-release (event-window)
;;Select an item
(setf selected-item (second (assoc event-window items)))
t)
(:enter-notify (window)
;;Highlight an item
(let ((position (position window items :key #'first)))
(when position
(menu-highlight-item menu position)))
t)
(:leave-notify (window kind)
(if (eql mw window)
;; Quit if pointer moved out of main menu window
(setf selected-item (when (eq kind :ancestor) :none))
;; Otherwise, unhighlight the item window left
(let ((position (position window items :key #'first)))
(when position
(menu-unhighlight-item menu position))))
t)
(otherwise ()
;;Ignore and discard any other event
t)))
;; Erase the menu
;;; (UNMAP-WINDOW mw)
;; Return selected item string, if any
(unless (eq selected-item :none) selected-item)))
(defun menu-highlight-item (menu position)
(let* ((box-margin (round *menu-item-margin* 2))
(left (- (round (- (menu-width menu) (menu-item-width menu)) 2)
box-margin))
(top (- (* (+ *menu-item-margin* (menu-item-height menu))
(1+ position))
box-margin))
(width (+ (menu-item-width menu) box-margin box-margin))
(height (+ (menu-item-height menu) box-margin box-margin)))
;; Draw a box in menu window around the given item.
(DRAW-RECTANGLE (menu-window menu)
(menu-gcontext menu)
left top
width height)))
(defun menu-unhighlight-item (menu position)
;; Draw a box in the menu background color
(let ((gcontext (menu-gcontext menu)))
(WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext))
(menu-highlight-item menu position))))
(defun menu-present (menu x y)
;; Make sure menu geometry is up-to-date
(menu-recompute-geometry menu)
;; Try to center first item at the given location, but
;; make sure menu is completely visible in its parent
(let ((menu-window (menu-window menu)))
;; (multiple-value-bind (tree parent) (QUERY-TREE menu-window)
;; (declare (ignore tree))
;; (WITH-STATE (parent)
;; (let* ((parent-width (DRAWABLE-WIDTH parent))
;; (parent-height (DRAWABLE-HEIGHT parent))
;; (menu-height (+ *menu-item-margin*
;; (* (1+ (length (menu-item-alist menu)))
;; (+ (menu-item-height menu) *menu-item-margin*))))
;; (menu-x (max 0 (min (- parent-width (menu-width menu))
;; (- x (round (menu-width menu) 2)))))
;; (menu-y (max 0 (min (- parent-height menu-height)
;; (- y (round (menu-item-height menu) 2/3)
;; *menu-item-margin*)))))
;; (WITH-STATE (menu-window)
;; (setf (DRAWABLE-X menu-window) menu-x
;; (DRAWABLE-Y menu-window) menu-y)))))
;; Make menu visible
(MAP-WINDOW menu-window)))
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