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

Makefile.defs Minor mods and added support for climhpgl.fasl and tests

			Removed xm-menus,graphics, and ol-graphics.lisp
Makefile.generic	added support for climhpgl.fasl and tests
clim/accept-values.lisp	graphic labels in accept-values-command-buttons
clim/frames.lisp	Added frame-current-panes, fixed problem with command disabling.
clim/pixmap-streams.lisp	Changed indentation
climtoys/ccc.lisp	Added com-show-class-generic-functions
demo/bitmap-editor.lisp	Indentation
hpgl/hpgl-port.lisp	Made hpgl-port have palette
hpgl/pkg.lisp		Fixed provide
misc/compile-1.lisp		Compile hpgl now
misc/dev-load-1.lisp		load hpgl now
misc/train.lisp		hpgl training, reporting of test results
postscript/postscript-port.lisp		calls make-palette
sys/sysdcl.lisp		removed ol-graphics etc
test/postscript-tests.lisp output file name depends on type.
test/test-clim.lisp		Added etsts
test/test-driver.lisp		Support for reporting of tests
tk/xlib.lisp		Added composestatus support
tk-silica/ol-gadgets.lisp		Menu bar remembers buttons for disabling
tk-silica/xm-frames.lisp	Menu bar remembers buttons for disabling, accelerators only for pulldown menus
tk-silica/xm-gadgets.lisp	compose-space buttons with pixmap labels
tk-silica/xm-silica.lisp	minor mod
tk-silica/xt-frames.lisp	mapping from command to button to support disabling
tk-silica/xt-graphics.lisp	added make-medium method for xt-port
tk-silica/xt-silica.lisp 	compose-status support
parent f435f558
No related branches found
No related tags found
No related merge requests found
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: pixmap-streams.lisp,v 1.14 92/11/09 19:54:58 cer Exp $ ;; $fiHeader: pixmap-streams.lisp,v 1.15 92/12/03 10:27:24 cer Exp $
(in-package :clim-internals) (in-package :clim-internals)
...@@ -61,13 +61,12 @@ ...@@ -61,13 +61,12 @@
(defun pixmap-from-menu-item (associated-window menu-item printer presentation-type (defun pixmap-from-menu-item (associated-window menu-item printer presentation-type
&optional text-style) &optional text-style)
(with-menu (menu associated-window) (with-menu (menu associated-window)
(setf (stream-text-margin menu) 1000)
(let ((record (with-output-recording-options (menu :draw nil :record t) (let ((record (with-output-recording-options (menu :draw nil :record t)
(with-output-to-output-record (menu) (with-output-to-output-record (menu)
(handler-case (handler-case
(with-text-style (menu text-style) (with-text-style (menu text-style)
(if presentation-type (if presentation-type
(present menu-item presentation-type :stream menu) (present menu-item presentation-type :stream menu)
(funcall printer menu-item menu))) (funcall printer menu-item menu)))
(error () (error ()
(write-string "Error in printer" menu))))))) (write-string "Error in printer" menu)))))))
...@@ -77,6 +76,30 @@ ...@@ -77,6 +76,30 @@
(draw-rectangle* stream 0 0 width height (draw-rectangle* stream 0 0 width height
:ink +background-ink+ :filled t) :ink +background-ink+ :filled t)
(replay-output-record (replay-output-record
record stream +everywhere+ record stream +everywhere+
(- (bounding-rectangle-left record)) (- (bounding-rectangle-left record))
(- (bounding-rectangle-top record)))))))) (- (bounding-rectangle-top record))))))))
;;; This code would be nice to use since it will eliminate the
;;; creation of a whole bunch of pixmaps. However, quite often you get
;;; multiple text output records and presentations. I suppose in
;;; theory this could be handled by making sure that the
;;; text-output-records line up nicely but........ This is tricky and
;;; will be more efficient than creating a pixmap?
#+ignore
(defun find-single-text-output-record (record)
;; If the output history contains just one text output record
;; nested inside presentations and boring types of composite output
;; records then return it
(loop
(let ((class (class-of record)))
(cond ((or (eq class (find-class 'standard-presentation))
(eq class (find-class 'standard-sequence-output-record)))
(if (= (output-record-count record) 1)
(setq record (output-record-element record 0))
(return nil)))
((eq class (find-class 'standard-text-output-record))
(return record))
(t (return nil))))))
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable. ;; applicable.
;; ;;
;; $fiHeader: bitmap-editor.lisp,v 1.12 92/12/16 16:47:20 cer Exp $ ;; $fiHeader: bitmap-editor.lisp,v 1.13 93/01/18 13:55:01 cer Exp $
(in-package :clim-demo) (in-package :clim-demo)
...@@ -63,30 +63,30 @@ ...@@ -63,30 +63,30 @@
(formatting-item-list (stream :n-columns 2 :x-spacing 30) (formatting-item-list (stream :n-columns 2 :x-spacing 30)
(formatting-cell (stream) (formatting-cell (stream)
(setf current-color (setf current-color
(position (position
(accept `((completion ,colors) (accept `((completion ,colors)
:name-key ,#'identity :name-key ,#'identity
:printer ,#'display-color) :printer ,#'display-color)
:view '(radio-box-view :view '(radio-box-view
:orientation :vertical :orientation :vertical
:toggle-button-options (:indicator-type nil)) :toggle-button-options (:indicator-type nil))
:stream stream :stream stream
:default (nth current-color colors) :default (nth current-color colors)
:prompt "Colors") :prompt "Colors")
colors))) colors)))
(formatting-cell (stream) (formatting-cell (stream)
(formatting-item-list (stream :n-columns 1 :y-spacing 10) (formatting-item-list (stream :n-columns 1 :y-spacing 10)
(formatting-cell (stream) (formatting-cell (stream)
(accept-values-command-button (stream) (accept-values-command-button (stream)
"Add Color" "Add color"
(add-new-color frame))) (add-new-color frame)))
(formatting-cell (stream) (formatting-cell (stream)
(accept-values-command-button (stream) (accept-values-command-button (stream)
"Edit Color" "Edit Color"
(replace-current-color frame))) (replace-current-color frame)))
(formatting-cell (stream) (formatting-cell (stream)
(accept-values-command-button (stream) (accept-values-command-button (stream)
"Delete Color" "Delete Color"
(delete-current-color frame))))))))) (delete-current-color frame)))))))))
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
;; $fiHeader$ ;; $fiHeader: pkg.lisp,v 1.1 93/03/04 08:57:32 cer Exp $
"Copyright (c) 1991 by International Lisp Associates. All rights reserved." "Copyright (c) 1991 by International Lisp Associates. All rights reserved."
"Portions copyright (c) 1992 Franz Inc. All rights reserved" "Portions copyright (c) 1992 Franz Inc. All rights reserved"
(in-package :common-lisp-user) (in-package :common-lisp-user)
(provide :hpglps) (provide :climhpgl)
(defpackage :hpgl-clim (defpackage :hpgl-clim
(:export #:with-output-to-hpgl-stream) (:export #:with-output-to-hpgl-stream)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
;; $fiHeader: postscript-port.lisp,v 1.16 93/03/19 09:44:27 cer Exp $ ;; $fiHeader: postscript-port.lisp,v 1.17 93/03/31 10:39:21 cer Exp $
(in-package :postscript-clim) (in-package :postscript-clim)
...@@ -750,7 +750,7 @@ end } def ...@@ -750,7 +750,7 @@ end } def
(defmethod initialize-instance :after ((port postscript-port) &key) (defmethod initialize-instance :after ((port postscript-port) &key)
(with-slots (silica::default-palette) port (with-slots (silica::default-palette) port
(setf silica::default-palette (make-instance 'postscript-palette)))) (setf silica::default-palette (make-palette port))))
(defmethod realize-graft ((port postscript-port) (graft standard-graft)) (defmethod realize-graft ((port postscript-port) (graft standard-graft))
(with-slots (page-width page-height) port (with-slots (page-width page-height) port
......
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: hpgl-clim; Base: 10; Lowercase: Yes -*-
;; $fiHeader: hpgl-tests.lisp,v 1.2 93/03/31 10:39:01 cer Exp $
(in-package :clim-user)
(defmethod invoke-with-output-to-printer-stream ((type (eql :hpgl)) stream continuation)
(hpgl-clim:with-output-to-hpgl-stream (*standard-output* stream)
(funcall continuation)))
(defmethod invoke-with-pipe-to-printer ((type (eql :hpgl)) continuation)
(with-open-stream
(printer-stream
(excl:run-shell-command (format nil "/usr/tech/cer/3rd/hpgl2ps-v2/hpgl2ps | lpr -P~A" *allegro-printer*)
:input :stream :wait
nil))
(funcall continuation printer-stream)))
(defun run-hpgl-tests (&key (output :view))
(run-printer-tests output :hpgl))
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
;; $fiHeader: postscript-tests.lisp,v 1.6 93/03/19 09:46:31 cer Exp $ ;; $fiHeader: postscript-tests.lisp,v 1.7 93/03/31 10:39:42 cer Exp $
(in-package :clim-user) (in-package :clim-user)
...@@ -146,12 +146,12 @@ ...@@ -146,12 +146,12 @@
(defun send-output-to-file (continuation) (defun send-output-to-file (continuation)
(with-open-file (let ((type (frame-printer-type *application-frame*)))
(file-stream "postscript.output" :direction :output :if-exists :supersede) (with-open-file (file-stream (format nil "~A.output" (string-downcase type)) :direction :output :if-exists :supersede)
(invoke-with-output-to-printer-stream (invoke-with-output-to-printer-stream
(frame-printer-type *application-frame*) type
file-stream file-stream
continuation))) continuation))))
(defun send-output-to-printer (continuation) (defun send-output-to-printer (continuation)
(invoke-with-pipe-to-printer (invoke-with-pipe-to-printer
......
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