too many contacts? part IV, src

[chang@cme.nist.gov (Forrest Chang)]

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*)))