Skip to content
Snippets Groups Projects
Commit 18f90101 authored by cer's avatar cer
Browse files

from cer: Mon Jun 21 13:43:34 PDT 1993

parent eba0087d
No related branches found
No related tags found
No related merge requests found
-------------------------------------------------------------------------------
from cer: Mon Jun 21 13:43:34 PDT 1993
Makefile.defs Use devel.13
clim/accept-values.lisp Make accept-values-pane-display take a view argument
clim/frames.lisp Name the restarts for pane redisplay errors
clim/interactive-protocol.lisp frame-manager-display-help
pops up a window if the frame type is
accept-values
clim/presentations.lisp find-appropriate-window only does it
if its extended-input-stream
climtoys/booch.lisp Made it cool
climtoys/ib.lisp many changes
climtoys/ibed.lisp many changes
climtoys/ibparse.lisp many changes
climtoys/ibgen.lisp many changes
climtoys/ibparse.lisp many changes
climtoys/ibtest.lisp many changes
postscript/postscript-medium.lisp Fix line-style problem
postscript/postscript-port.lisp Line style cache
silica/db-box.lisp Fixed bulletin-board-pane
silica/db-layout.lisp Removed duplicate bulletin-board-pane
silica/layout.lisp Added window-refresh for top-level-sheet
test/test-demos.lisp Added test for out bounds lines
test/test-driver.lisp Added xsync, query-identifier styff
test/test.lisp Fixed bulletin-board-pane
tk-silica/xt-graphics.lisp Fixed problem with clipper return NIL
when line should not be drawn
-------------------------------------------------------------------------------
from cer: Fri Jun 4 09:05:19 PDT 1993
......
# $fiHeader: Makefile.defs,v 1.11 1993/06/02 18:40:12 cer Exp $
# $fiHeader: Makefile.defs,v 1.12 1993/06/04 16:06:12 cer Exp $
#
# Makefile.defs for CLIM 2.0
#
CL = /usr/fi/dcl-4.2.beta2.0
CL = /usr/fi/dcl-4.2.devel.13
PWD = /usr/tech/cer/stuff/clim-2.0
DUMP-CL = $(CL)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: accept-values.lisp,v 1.63 1993/05/25 20:40:32 cer Exp $
;; $fiHeader: accept-values.lisp,v 1.64 1993/06/02 18:40:21 cer Exp $
(in-package :clim-internals)
......@@ -1283,24 +1283,27 @@
(defun accept-values-pane-displayer-1 (frame pane displayer align-prompts view)
(let ((avv-stream (make-instance 'accept-values-stream
:stream pane :align-prompts align-prompts))
(avv-record nil))
:stream pane :align-prompts align-prompts))
(avv-record nil)
(view (or view
(frame-manager-dialog-view (frame-manager frame)))))
(setf (slot-value avv-stream 'avv-frame) frame)
(letf-globally (((stream-default-view pane)
(or view
(frame-manager-dialog-view (frame-manager frame)))))
view))
(setq avv-record
(updating-output (avv-stream)
(with-new-output-record
(avv-stream 'accept-values-output-record avv-record)
(setf (slot-value avv-stream 'avv-record) avv-record)
(if align-prompts
(formatting-table (avv-stream)
(funcall displayer frame avv-stream))
(funcall displayer frame avv-stream))))))
(updating-output (avv-stream)
(with-new-output-record
(avv-stream 'accept-values-output-record avv-record)
(setf (slot-value avv-stream 'avv-record) avv-record)
(if align-prompts
(formatting-table (avv-stream)
(funcall displayer frame avv-stream))
(progn
(display-view-background avv-stream view)
(funcall displayer frame avv-stream)))))))
(unless *sizing-application-frame*
(setf (gethash pane (frame-pane-to-avv-stream-table frame))
(cons avv-stream avv-record)))))
(cons avv-stream avv-record)))))
(define-command (com-edit-avv-pane-choice :command-table accept-values-pane)
((choice 'accept-values-choice)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: frames.lisp,v 1.67 1993/05/13 16:23:04 cer Exp $
;; $fiHeader: frames.lisp,v 1.68 1993/05/25 20:40:43 cer Exp $
(in-package :clim-internals)
......@@ -1110,9 +1110,9 @@
(redisplay-p (if (listp ir) (first ir) ir))
(check-overlapping (or (atom ir) ;default is T
(getf (rest ir) :check-overlapping t))))
(with-simple-restart (nil "Skip redisplaying pane ~S" pane)
(with-simple-restart (skip-pane-redisplay "Skip redisplaying pane ~S" pane)
(loop
(with-simple-restart (nil "Retry displaying pane ~S" pane)
(with-simple-restart (retry-pane-redisplay "Retry displaying pane ~S" pane)
(when *frame-layout-changing-p*
(setq force-p t))
(unless *sizing-application-frame*
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: interactive-protocol.lisp,v 1.27 1993/05/13 16:29:07 colin Exp $
;; $fiHeader: interactive-protocol.lisp,v 1.28 1993/05/25 20:40:55 cer Exp $
(in-package :clim-internals)
......@@ -1025,7 +1025,8 @@
(declare (ignore framem frame))
;;-- Yuck but think of a better way
(let ((old-help *accept-help*))
(if (typep (encapsulating-stream-stream stream) '(or accept-values-pane accept-values-stream))
(if (or (typep (encapsulating-stream-stream stream) '(or accept-values-pane accept-values-stream))
(typep *application-frame* 'accept-values))
(accepting-values (stream :exit-boxes '(:exit)
:label "Input editor help"
:own-window t)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: presentations.lisp,v 1.19 92/11/20 08:44:51 cer Exp $
;; $fiHeader: presentations.lisp,v 1.20 92/12/03 10:27:35 cer Exp $
(in-package :clim-internals)
......@@ -468,10 +468,11 @@
(defun find-appropriate-window (stream)
;;--- How do we hack multiple pointers?
(let* ((pointer (stream-primary-pointer stream))
(window (pointer-sheet pointer)))
;; It ain't no good if it doesn't have a history.
(when (and window
(port window)
(output-recording-stream-p window))
window)))
(when (extended-input-stream-p stream)
(let* ((pointer (stream-primary-pointer stream))
(window (pointer-sheet pointer)))
;; It ain't no good if it doesn't have a history.
(when (and window
(port window)
(output-recording-stream-p window))
window))))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
;; $fiHeader: postscript-medium.lisp,v 1.14 93/03/31 10:39:18 cer Exp $
;; $fiHeader: postscript-medium.lisp,v 1.15 93/04/23 09:18:07 cer Exp $
(in-package :postscript-clim)
......@@ -33,23 +33,29 @@
forms)))))
(defun use-line-style (medium line-style)
(let ((printer-stream (slot-value medium 'printer-stream))
(thickness (ecase (line-style-unit line-style)
(:normal (normal-line-thickness
(port medium) (line-style-thickness line-style)))
(:point (line-style-thickness line-style))))
(dashes (line-style-dashes line-style)))
(format printer-stream " ~D setlinewidth~%" (round thickness))
(when dashes
(when (eq dashes t)
(setq dashes '(4 4)))
(making-ps-array (printer-stream)
(let ((limit (length dashes)))
(dotimes (i limit)
(write (elt dashes i) :stream printer-stream :escape nil)
(unless (>= (1+ i) limit)
(write-char #\space printer-stream)))))
(format printer-stream "0 setdash~%"))))
(let* ((printer-stream (slot-value medium 'printer-stream))
(thickness (ecase (line-style-unit line-style)
(:normal (normal-line-thickness
(port medium) (line-style-thickness line-style)))
(:point (line-style-thickness line-style))))
(dashes (line-style-dashes line-style))
(new-line-style (cons thickness dashes)))
(with-slots (current-line-style) medium
(unless (equalp current-line-style new-line-style)
(setq current-line-style new-line-style)
(format printer-stream " ~D setlinewidth~%" (round thickness))
(if dashes
(progn
(when (eq dashes t)
(setq dashes '(4 4)))
(making-ps-array (printer-stream)
(let ((limit (length dashes)))
(dotimes (i limit)
(write (elt dashes i) :stream printer-stream :escape nil)
(unless (>= (1+ i) limit)
(write-char #\space printer-stream)))))
(format printer-stream "0 setdash~%"))
(format printer-stream "[] 0 setdash~%"))))))
(defun color-equal (c1 c2)
(or (eq c1 c2)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
;; $fiHeader: postscript-port.lisp,v 1.19 1993/05/13 16:23:58 cer Exp $
;; $fiHeader: postscript-port.lisp,v 1.20 1993/06/02 18:41:40 cer Exp $
(in-package :postscript-clim)
......@@ -252,12 +252,13 @@
(defclass postscript-medium (basic-medium)
((printer-stream :initarg :stream)
(current-color :initform nil) ;for decoding stippled inks
(features-sent :initform nil)
(curfont :initform nil) ;a psfck structure
(ch1buf :initform (make-array 1 :element-type #+ANSI-90 'character
#-ANSI-90 'string-char))))
((printer-stream :initarg :stream)
(current-color :initform nil) ;for decoding stippled inks
(features-sent :initform nil)
(curfont :initform nil) ;a psfck structure
(ch1buf :initform (make-array 1 :element-type #+ANSI-90 'character
#-ANSI-90 'string-char))
(current-line-style :initform nil)))
(defmethod implementation-pixels-per-point ((medium postscript-medium))
(float (/ *1-pixel=points*) 0f0))
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;; $fiHeader: db-box.lisp,v 1.24 93/03/19 09:44:31 cer Exp $
;; $fiHeader: db-box.lisp,v 1.25 93/03/31 10:39:29 cer Exp $
(in-package :silica)
......@@ -192,17 +192,15 @@
;;;
(defclass bulletin-board-pane (layout-pane)
((contents :initarg :contents)))
((contents :initarg :contents :initform nil)))
(defmacro bulletin-board (options &rest contents)
`(make-pane 'bulletin-board-pane
:contents (list ,@contents)
,@options))
(defmethod handle-event :after ((pane bulletin-board-pane) (event pointer-motion-event))
(deallocate-event event))
(defmethod initialize-instance :after ((pane bulletin-board-pane) &key contents)
(dolist (content contents)
(destructuring-bind (x y child) content
(declare (ignore x y))
(defmethod initialize-instance :after ((pane bulletin-board-pane) &key contents)
(dolist (item contents)
(destructuring-bind (position child) item
(check-type position (or point cons))
(sheet-adopt-child pane child))))
(defmethod compose-space ((pane bulletin-board-pane) &key width height)
......@@ -211,10 +209,17 @@
(let ((max-x 0)
(max-y 0))
(dolist (content contents)
(destructuring-bind (x y pane) content
(let ((sr (compose-space pane)))
(maxf max-x (+ x (space-requirement-width sr)))
(maxf max-y (+ y (space-requirement-height sr))))))
(destructuring-bind (position pane) content
(multiple-value-bind (x y)
(typecase position
(point (values (point-x position)
(point-y position)))
(cons
(values (first position)
(second position))))
(let ((sr (compose-space pane)))
(maxf max-x (+ x (space-requirement-width sr)))
(maxf max-y (+ y (space-requirement-height sr)))))))
(make-space-requirement :width max-x :height max-y))))
......@@ -222,10 +227,27 @@
(declare (ignore width height))
(with-slots (contents) pane
(dolist (content contents)
(destructuring-bind (x y pane) content
(destructuring-bind (position pane) content
(let ((sr (compose-space pane)))
(move-and-resize-sheet
pane x y
(space-requirement-width sr)
(space-requirement-height sr)))))))
(multiple-value-bind (x y)
(typecase position
(point (values (point-x position)
(point-y position)))
(cons
(values (first position)
(second position))))
(move-and-resize-sheet
pane x y
(space-requirement-width sr)
(space-requirement-height sr))))))))
(defmacro bulletin-board (options &rest contents)
`(make-pane 'bulletin-board-pane
:contents
(list ,@(mapcar #'(lambda (item)
(destructuring-bind (position sheet) item
`(list (list ,@position) ,sheet)))
contents))
,@options))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;; $fiHeader: db-layout.lisp,v 1.33 1993/05/05 01:39:39 cer Exp $
;; $fiHeader: db-layout.lisp,v 1.34 1993/06/04 20:46:27 cer Exp $
(in-package :silica)
......@@ -421,44 +421,3 @@
composite-pane)
())
;;--- Does this need to be more complicated?
;;--- What is the correct behavior. Should it take a space requirement?
;;--- and just call ALLOCATE-SPACE?
(defclass bboard-pane (space-requirement-mixin layout-pane)
((contents :initarg :contents :initform nil)))
(defmethod handle-event :after ((pane bboard-pane) (event pointer-motion-event))
(deallocate-event event))
(defmethod initialize-instance :after ((pane bboard-pane) &key contents)
(dolist (item contents)
(destructuring-bind (position child) item
(check-type position (or position cons))
(sheet-adopt-child pane child))))
(defmethod allocate-space ((pane bboard-pane) width height)
(declare (ignore width height))
(with-slots (contents) pane
(destructuring-bind (position child) item
(let ((space-req (compose-space child)))
(multiple-value-bind (x y)
(typecase position
(point (values (point-x position)
(point-y position)))
(cons
(values (first position)
(second position)))))
(move-and-resize-sheet
child x y
(space-requirement-width space-req)
(space-requirement-height space-req))))))
(defmacro bulletin-board (options &rest contents)
`(make-pane 'bboard-pane
(list ,@(mapcar #'(lambda (item)
(destructuring-bind (position sheet) item
`(list (list ,@position ,sheet))))
contents))
,@options))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;; $fiHeader: layout.lisp,v 1.30 1993/05/13 16:24:06 cer Exp $
;; $fiHeader: layout.lisp,v 1.31 1993/06/02 18:41:53 cer Exp $
(in-package :silica)
......@@ -361,6 +361,9 @@
;;--- More of same...
(:default-initargs :text-cursor nil :text-margin most-positive-fixnum))
(defmethod window-refresh ((sheet top-level-sheet))
nil)
;;--- Needed methods include:
;;--- INVOKE-WITH-RECORDING-OPTIONS
;;--- DEFAULT-TEXT-MARGIN
......
(in-package :clim-user)
;; $fiHeader: test-demos.lisp,v 1.1 93/03/19 09:46:37 cer Exp $
;; $fiHeader: test-demos.lisp,v 1.2 1993/05/13 16:24:18 cer Exp $
(define-frame-test test-puzzle-demo (clim-demo::puzzle)
(
......@@ -82,6 +82,8 @@
:colon-prefix t)
(:command clim-demo::interactor clim-demo::com-show-some-commands
:colon-prefix t)
"(clim:draw-line* *standard-output* -51070 149 -51070 164)
"
)
(:command clim-demo::interactor clim-demo::com-quit-listener
:colon-prefix t)
......
......@@ -87,6 +87,10 @@
(defvar *default-input-state-timeout* 300)
(defun wait-for-clim-input-state (invocation &optional (timeout *default-input-state-timeout*))
(let ((process (invocation-process invocation)))
;;-- there really should be a port-finish-output
(let ((port (port (invocation-frame invocation))))
(when port
(x11:xsync (tk-silica::port-display port) 0)))
(mp:process-allow-schedule)
(if timeout
(let ((done nil))
......@@ -252,11 +256,11 @@
(let ((*invocation* invocation))
(unwind-protect
(etypecase command-continuation
(null (sleep 5))
(list
(execute-commands-in-invocation
invocation command-continuation))
(function (funcall command-continuation))
(null (sleep 5)))
(function (funcall command-continuation)))
(terminate-invocation invocation exit-command)
(mp::process-kill (invocation-process invocation))
(unless (wait-for-death (invocation-process invocation))
......@@ -694,10 +698,12 @@
(defun find-avv-query (avv-stream prompt)
(maphash #'(lambda (query-id query)
(when (and (consp query-id)
(when (if (consp query-id) ;;--yuck
(and
(eq (car query-id) :query-identifier)
(consp (cdr query-id))
(equal (cadr query-id) prompt))
(eq query-id prompt))
(return-from find-avv-query query)))
(slot-value (slot-value avv-stream 'clim-internals::avv-record) 'clim-internals::query-table)))
......
......@@ -19,7 +19,7 @@
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: test.lisp,v 1.48 93/04/23 09:18:21 cer Exp $
;; $fiHeader: test.lisp,v 1.49 1993/05/13 16:24:27 cer Exp $
(in-package :clim-user)
......@@ -1003,17 +1003,17 @@
(:command-table test-frame)
(:pane
(bulletin-board ()
(list 10 10 (make-clim-interactor-pane
((10 10) (make-clim-interactor-pane
:height '(10 :line)
:width '(50 :character)
:foreground +green+
:background +red+))
(list 50 200 (make-pane 'push-button
((50 200) (make-pane 'push-button
:label (with-menu (menu (graft *application-frame*))
(with-output-to-pixmap (stream menu :width 100 :height 100)
(draw-rectangle* stream 0 0 100 100 :ink +background-ink+)
(draw-rectangle* stream 10 10 90 90 :ink +red+)))))
(list 90 300 (make-pane 'push-button
((90 300) (make-pane 'push-button
:label "press me"
:background +black+
:foreground +cyan+
......@@ -1147,3 +1147,4 @@
......@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xt-graphics.lisp,v 1.73 1993/05/13 16:32:11 colin Exp $
;; $fiHeader: xt-graphics.lisp,v 1.74 1993/05/25 20:42:45 cer Exp $
(in-package :tk-silica)
......@@ -802,10 +802,10 @@
(:explain :calls :types)
(fixnum x1 y1 x2 y2 xmin xmax ymin ymax))
(macrolet ((outcodes (x y)
`(+ (ash (if (minusp (- ymax ,y)) 1 0) 3)
(ash (if (minusp (- ,y ymin)) 1 0) 2)
(ash (if (minusp (- xmax ,x)) 1 0) 1)
(if (minusp (- ,x xmin)) 1 0)))
`(+ (ash (if (< ymax ,y) 1 0) 3)
(ash (if (< ,y ymin) 1 0) 2)
(ash (if (< xmax ,x) 1 0) 1)
(if (< ,x xmin) 1 0)))
(rejectp (oc1 oc2) `(plusp (logand ,oc1 ,oc2)))
(acceptp (oc1 oc2)
`(and (zerop ,oc1) (zerop ,oc2))))
......@@ -817,6 +817,8 @@
#+ignore
(format excl:*initial-terminal-io* "oc1 = ~d, oc2 = ~d~%" outcode1 outcode2)
(if (rejectp outcode1 outcode2)
;; This means that both Ys or both Xs are out of the window
;; which means that there is nothing to draw
(return-from clipper nil))
(if* (acceptp outcode1 outcode2)
then (return)
......@@ -858,7 +860,8 @@
`(if (or (not (valid-point-p ,x1 ,y1))
(not (valid-point-p ,x2 ,y2)))
(multiple-value-setq (,x1 ,y1 ,x2 ,y2)
(clipper ,x1 ,y1 ,x2 ,y2))))
(clipper ,x1 ,y1 ,x2 ,y2))
t))
;; Discarding of other illegal graphics
......@@ -1033,14 +1036,14 @@
(sheet (medium-sheet medium))
(transform (sheet-device-transformation sheet)))
(convert-to-device-coordinates transform x1 y1 x2 y2)
(clip-invalidate-line x1 y1 x2 y2)
(tk::draw-line
drawable
(adjust-ink (decode-ink ink medium)
medium
(the fixnum (min (the fixnum x1) (the fixnum x2)))
(the fixnum (min (the fixnum y1) (the fixnum y2))))
x1 y1 x2 y2)))))
(when (clip-invalidate-line x1 y1 x2 y2)
(tk::draw-line
drawable
(adjust-ink (decode-ink ink medium)
medium
(the fixnum (min (the fixnum x1) (the fixnum x2)))
(the fixnum (min (the fixnum y1) (the fixnum y2))))
x1 y1 x2 y2))))))
(defmethod medium-draw-lines* ((medium xt-medium) position-seq)
......@@ -1062,37 +1065,39 @@
(y2 ,y2))
(convert-to-device-coordinates transform x1 y1)
(convert-to-device-coordinates transform x2 y2)
(clip-invalidate-line x1 y1 x2 y2)
(minf minx x1)
(minf miny y1)
(minf minx x2)
(minf miny y2)
(setf (tk::xsegment-array-x1 points i) x1
(tk::xsegment-array-y1 points i) y1
(tk::xsegment-array-x2 points i) x2
(tk::xsegment-array-y2 points i) y2))))
(if (listp position-seq)
(when (clip-invalidate-line x1 y1 x2 y2)
(minf minx x1)
(minf miny y1)
(minf minx x2)
(minf miny y2)
(setf (tk::xsegment-array-x1 points i) x1
(tk::xsegment-array-y1 points i) y1
(tk::xsegment-array-x2 points i) x2
(tk::xsegment-array-y2 points i) y2)))))
(let ((i 0))
(declare (fixnum i))
(if (listp position-seq)
(do ((ps position-seq))
((null ps))
(when (stuff-line-guts (pop ps) (pop ps) (pop ps) (pop ps))
(incf i)))
(do ((ps position-seq)
(i 0 (1+ i)))
((null ps))
(j 0 (+ j 4)))
((= j len))
(declare (fixnum i))
(stuff-line-guts (pop ps) (pop ps) (pop ps) (pop ps)))
(do ((ps position-seq)
(j 0 (+ j 4))
(i 0 (1+ i)))
((= j len))
(declare (fixnum i j))
(stuff-line-guts (aref ps j) (aref ps (1+ j))
(aref ps (+ 2 j)) (aref ps (+ 3 j)))))
(setq ink
(adjust-ink (decode-ink (medium-ink medium) medium) medium
minx miny))
(x11:xdrawsegments
(tk::object-display drawable)
drawable
ink
points
npoints))))))
(when (stuff-line-guts (aref ps j) (aref ps (1+ j))
(aref ps (+ 2 j)) (aref ps (+ 3 j)))
(incf i))))
(unless (zerop i)
(setq ink
(adjust-ink (decode-ink (medium-ink medium) medium) medium
minx miny))
(x11:xdrawsegments
(tk::object-display drawable)
drawable
ink
points
i))))))))
(defmethod medium-draw-rectangle* ((medium xt-medium) x1 y1 x2 y2 filled)
(let ((drawable (medium-drawable medium)))
......
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