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

Initial revision

parent 88c6b2a9
No related branches found
No related tags found
No related merge requests found
;; -*- mode: common-lisp; package: user -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(in-package :clim-internals)
"Copyright (c) 1992 Symbolics, Inc. All rights reserved."
(define-application-frame default-application () ()
(:command-definer nil)
(:menu-bar nil)
(:top-level nil))
;; We keep a global binding of *APPLICATION-FRAME* because it can make
;; life easier for people debugging applications
(setq *application-frame* (make-application-frame
'default-application :parent nil))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
(in-package :clim-internals)
;;; $fiHeader$
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved."
;;; Designs meet output records
(defun make-design-from-output-record (record)
(multiple-value-bind (xoff yoff) (compute-output-record-offsets record)
(make-design-from-output-record-1 record xoff yoff)))
(defmethod make-design-from-output-record-1
((record output-record-mixin) x-offset y-offset)
(let ((designs nil))
(flet ((make-design (record)
(multiple-value-bind (xoff yoff) (output-record-position record)
(declare (type coordinate xoff yoff))
(let ((design
(make-design-from-output-record-1
record
(+ x-offset xoff) (+ y-offset yoff))))
(when design (push design designs))))))
(declare (dynamic-extent #'make-design))
(map-over-output-records #'make-design record))
(make-instance 'composite-over :designs (apply #'vector designs))))
(defgeneric draw-design (design stream &rest args)
(declare (arglist design stream &key . #.(all-drawing-options-lambda-list nil))))
;;; Simple composite designs
(defmethod draw-design ((composite composite-over) stream &rest args)
(declare (dynamic-extent args))
(with-slots ((designs clim-utils::designs)) composite
(dovector (design designs :from-end t)
(apply #'draw-design design stream args))))
(defmethod draw-design ((composite composite-in) stream &rest args &key ink &allow-other-keys)
(declare (dynamic-extent args))
(with-slots ((designs clim-utils::designs)) composite
(let ((ink (or ink (aref designs 0))) ;should be COMPOSE-OVER
(design (aref designs 1)))
;; Clips INK to the inside of DESIGN.
(apply #'draw-design design stream :ink ink args))))
(defmethod draw-design ((composite composite-out) stream &rest args &key ink &allow-other-keys)
(declare (dynamic-extent args))
(with-slots ((designs clim-utils::designs)) composite
(let ((ink (or ink (aref designs 0))) ;should be COMPOSE-OVER
(design (aref designs 1)))
;;--- Should clip INK to the outside of DESIGN, but I don't know how
(nyi))))
(defmethod draw-design ((region standard-region-union) stream &rest args)
(declare (dynamic-extent args))
(with-slots ((regions clim-utils::regions)) region
(dolist (region regions)
(apply #'draw-design region stream args))))
(defmethod draw-design ((region standard-region-intersection) stream &rest args)
(declare (dynamic-extent args))
(with-slots ((regions clim-utils::regions)) region
;;--- Should draw just the intersection, but I dunno how to do that in general
(nyi)))
(defmethod draw-design ((region standard-region-difference) stream &rest args)
(declare (dynamic-extent args))
(with-slots ((region1 clim-utils::region1)
(region2 clim-utils::region2)) region
;;--- Should draw just the difference, but I dunno how to do that in general
(nyi)))
;;; Simple geometric designs
(defmethod make-design-from-output-record-1
((point point-output-record) x-offset y-offset)
(with-slots (x y ink) point
(compose-in
ink
(make-point (+ x x-offset) (+ y y-offset)))))
(defmethod draw-design ((point standard-point) stream &rest args &key ink line-style)
(declare (dynamic-extent args)
(ignore ink line-style))
(multiple-value-bind (x y) (point-position point)
(apply #'draw-point* stream x y args)))
(defmethod make-design-from-output-record-1
((line line-output-record) x-offset y-offset)
(with-slots (x1 x2 y1 y2 ink) line
(compose-in
ink
(make-line* (+ x1 x-offset) (+ y1 y-offset)
(+ x2 x-offset) (+ y2 y-offset)))))
(defmethod draw-design ((line standard-line) stream &rest args &key ink line-style)
(declare (dynamic-extent args)
(ignore ink line-style))
(multiple-value-bind (x1 y1) (line-start-point* line)
(multiple-value-bind (x2 y2) (line-end-point* line)
(apply #'draw-line* stream x1 y1 x2 y2 args))))
(defmethod make-design-from-output-record-1
((rectangle rectangle-output-record) x-offset y-offset)
(with-slots (x1 x2 y1 y2 line-style ink) rectangle
(compose-in
ink
(if (null line-style)
(make-rectangle* (+ x1 x-offset) (+ y1 y-offset)
(+ x2 x-offset) (+ y2 y-offset))
(make-polyline* (list (+ x1 x-offset) (+ y1 y-offset)
(+ x2 x-offset) (+ y1 y-offset)
(+ x2 x-offset) (+ y2 y-offset)
(+ x1 x-offset) (+ y2 y-offset))
:closed t)))))
(defmethod draw-design ((rectangle standard-rectangle) stream &rest args &key ink line-style)
(declare (dynamic-extent args)
(ignore ink line-style))
(multiple-value-bind (x1 y1 x2 y2) (rectangle-edges* rectangle)
(apply #'draw-rectangle* stream x1 y1 x2 y2 :filled t args)))
(defmethod make-design-from-output-record-1
((polygon polygon-output-record) x-offset y-offset)
(with-slots (list-of-xs-and-ys closed line-style ink) polygon
(let ((coords (copy-list list-of-xs-and-ys)))
(translate-position-sequence x-offset y-offset coords)
(compose-in
ink
(if (null line-style)
(make-polygon* coords)
(make-polyline* coords :closed closed))))))
(defmethod draw-design ((polygon standard-polygon) stream &rest args &key ink line-style)
(declare (dynamic-extent args)
(ignore ink line-style))
(apply #'draw-polygon* stream (coerce (slot-value polygon 'clim-utils::coords) 'list)
:closed t :filled t args))
(defmethod draw-design ((polyline standard-polyline) stream &rest args &key ink line-style)
(declare (dynamic-extent args)
(ignore ink line-style))
(apply #'draw-polygon* stream (coerce (slot-value polyline 'clim-utils::coords) 'list)
:closed (polyline-closed polyline) :filled nil args))
(defmethod make-design-from-output-record-1
((ellipse ellipse-output-record) x-offset y-offset)
(with-slots (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy
start-angle end-angle line-style ink) ellipse
(compose-in
ink
(if (null line-style)
(make-ellipse* (+ center-x x-offset) (+ center-y y-offset)
radius-1-dx radius-1-dy radius-2-dx radius-2-dy
:start-angle start-angle :end-angle end-angle)
(make-elliptical-arc* (+ center-x x-offset) (+ center-y y-offset)
radius-1-dx radius-1-dy radius-2-dx radius-2-dy
:start-angle start-angle :end-angle end-angle)))))
(defmethod draw-design ((ellipse standard-ellipse) stream &rest args &key ink line-style)
(declare (dynamic-extent args)
(ignore ink line-style))
(multiple-value-bind (center-x center-y)
(ellipse-center-point* ellipse)
(multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
(ellipse-radii ellipse)
(apply #'draw-ellipse* stream center-x center-y
radius-1-dx radius-1-dy radius-2-dx radius-2-dy
:start-angle (ellipse-start-angle ellipse)
:end-angle (ellipse-end-angle ellipse)
:filled t args))))
(defmethod draw-design ((ellipse standard-elliptical-arc) stream &rest args &key ink line-style)
(declare (dynamic-extent args)
(ignore ink line-style))
(multiple-value-bind (center-x center-y)
(ellipse-center-point* ellipse)
(multiple-value-bind (radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
(ellipse-radii ellipse)
(apply #'draw-ellipse* stream center-x center-y
radius-1-dx radius-1-dy radius-2-dx radius-2-dy
:start-angle (ellipse-start-angle ellipse)
:end-angle (ellipse-end-angle ellipse)
:filled nil args))))
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