[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
too many contacts? part IV, src
To: Kerry Kimbrough, and anyone else willing to try it.
This is the program that results in the 44 contacts as a max number.
I originally mailed it to Kerry, but the mail all bounced.
original letter follows
!
----- Unsent message follows -----
Received: by tilde id AA17997; Thu, 3 Aug 89 10:34:17 CDT
Received: from squire.cme.nist.gov by ti.com id AA05300; Thu, 3 Aug 89 10:30:40 CDT
Received: by squire.cme.nist.gov (4.0/SMI-3.2-del.5)
id AA00691; Thu, 3 Aug 89 11:31:35 EDT
Date: Thu, 3 Aug 89 11:31:35 EDT
From: chang@cme.nist.gov (Forrest Chang)
Message-Id: <8908031531.AA00691@squire.cme.nist.gov>
To: Kimbrough@csc.ti.com
Subject: the program
The contact making program is called clue-crash, the variable
*contact*, tells it how many windows to make per button-press.
You may want to try this with both clue 6.0 and clue-1-15.
Unfortunately,since we don't have clue-1-13 anymore, I can't see if I
get 44 as the max number for that (even tho' the original application
worked on that)
thanx much
Forrest
NIST
=======================
;;;-*- Mode: LISP; Syntax: Common-lisp; Package: clue-test; Base: 10 -*-
(in-package 'clue-test :use '(lisp clue))
(defvar *display*)
(defvar *trace* nil)
(defvar *contacts* 44)
(defvar *main*)
(defvar *debug* nil)
(defvar *white*)
(defvar *black*)
(defvar *gc*)
(defvar *x* 10)
(defvar *y* 10)
;;; PROLOGUE ================================================================
;;; Function Name: setup
;;; Author List: fkc
;;; Creation Date: lta
;;; Arguments: host
;;; Global Variables: none, but defines some..
;;; Description: does necessary X setup
;;;
;;; Return Value/Side Effects: below, globals are initialized
;;; ENDPROLOGUE ------------------------------------------------------------
(defun setup (host)
(when *debug* (format t "~%setup"))
(setf *x* 0)
(setf *y* 10)
(setq *display* (open-contact-display 'clue-crash :host host))
(when *trace* (xlib:trace-display *display*))
(print "open-display")
(setq *black* (xlib:screen-black-pixel
(xlib:display-default-screen *display*)))
(setq *white* (xlib:screen-white-pixel
(xlib:display-default-screen *display*)))
(setq *gc* (xlib:create-gcontext :drawable (display-root *display*)
:foreground *black*
:background *white*)))
;;; PROLOGUE ================================================================
;;; Function Name: quit
;;; Author List: fkc
;;; Creation Date: lta
;;; Arguments:
;;; Global Variables:
;;; Description: an action, usually to a button click, in this program
;;; that exits the program by throwing to the catch in the main lop
;;;
;;; Return Value/Side Effects: nil, exits program
;;; ENDPROLOGUE ------------------------------------------------------------
(defaction quit ((window composite))
(when *debug* (format t "~%action: quit"))
(throw 'loop-exit-catcher nil))
;;; PROLOGUE ================================================================
;;; Function Name: DO-THROW
;;; Author List: FKC, ORIGINALLY LAMOTT
;;; Creation Date: AVLTA
;;; Arguments: TAG VALUE
;;; Global Variables:
;;; Description: CAN'T USE A SPECIAL FORM -- THROW AS AN ACTION...
;;;
;;; Return Value/Side Effects: None
;;; ENDPROLOGUE ------------------------------------------------------------
(defun do-throw (tag value) (throw tag value))
;;; PROLOGUE ================================================================
;;; Function Name: MAKE-WINDOWS
;;; Author List: FKC
;;; Creation Date: LTA
;;; Arguments:
;;; Global Variables: *DISPLAY*, *MAIN*,
;;; Description: CREATES THE WINDOWS
;;;
;;; Return Value/Side Effects: None
;;; ENDPROLOGUE ------------------------------------------------------------
(defun make-windows ()
(when *debug* (format t "~%make-window2"))
(setq *main*
(make-contact 'composite :parent *display*
:name 'top-level-window
:border-width 2
:contact-background *white*
:height 720
:width 900
:x 100 :y 100
:border *black*
:event-translations '(
(:key-press make-new-contacts)
(:button-press quit))
:documentation "this is the top-level-window"))
)
(defaction make-new-contacts ((window composite))
(expose-line *contacts*))
(defun expose-line (i)
(cond ((> i 0)
(present (make-contact 'composite :parent *main2*
:name 'win
:border-width 2
:contact-background *white*
:height 20
:width 20
:x *x* :y *y*
:border *white*
:event-translations '()
:documentation "foo"))
(setf *x* (+ *x* 3))
(expose-line (- i 1)))
(t
(print "x change")
(setf *x* 0)
(setf *y* (+ *y* 25)))))
;;; PROLOGUE ================================================================
;;; Function Name: CLUE-CRASH
;;; Author List: FKC
;;; Creation Date: 28 july 89
;;; Arguments: OPTIONAL HOST
;;; Global Variables: *DISPLAY*
;;; Description: CREATES main and loops
;;; Return Value/Side Effects: None
;;; ENDPROLOGUE ------------------------------------------------------------
(defun clue-crash (&optional (host "plan"))
(when *debug* (format t "~%crash2"))
(setup host)
(process-all-events *display*)
(unwind-protect
(progn
(make-window2)
(present *main2*)
(catch 'loop-exit-catcher
(loop
(process-next-event *display*)
)))
(xlib:close-display *display*)))