[med-svn] [uw-prism] 10/13: New upstream version 1.5-2
Andreas Tille
tille at debian.org
Sat Dec 30 12:37:02 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository uw-prism.
commit d162c81fa96427ef647fd2ccbe793c7bd5e82a25
Author: Andreas Tille <tille at debian.org>
Date: Sat Dec 30 13:34:52 2017 +0100
New upstream version 1.5-2
---
config.cl | 65 +
debian/changelog | 5 -
debian/compat | 1 -
debian/control | 25 -
debian/copyright | 94 -
debian/doBuild | 9 -
debian/patches/make-prism.cl.patch | 10 -
debian/patches/series | 1 -
debian/rules | 14 -
debian/source/format | 1 -
debian/upstream/metadata | 12 -
debian/watch | 4 -
defsystem.cl | 5017 ++++++++++++++++++++++++++++++++++++
dicom/src/actions-client.cl | 423 +++
dicom/src/actions-common.cl | 476 ++++
dicom/src/actions-server.cl | 511 ++++
dicom/src/compiler.cl | 243 ++
dicom/src/dicom.cl | 195 ++
dicom/src/dicom.cl~ | 195 ++
dicom/src/dictionary.cl | 2412 +++++++++++++++++
dicom/src/functions.cl | 163 ++
dicom/src/generator-rules.cl | 936 +++++++
dicom/src/generator.cl | 657 +++++
dicom/src/mainloop.cl | 375 +++
dicom/src/object-generator.cl | 199 ++
dicom/src/object-parser.cl | 917 +++++++
dicom/src/parser-rules.cl | 826 ++++++
dicom/src/parser.cl | 339 +++
dicom/src/pds.config.example | 253 ++
dicom/src/prism-data.cl | 382 +++
dicom/src/prism-output.cl | 1285 +++++++++
dicom/src/start-dicom | 27 +
dicom/src/state-rules.cl | 228 ++
dicom/src/utilities.cl | 277 ++
dicom/src/wrapper-client.cl | 145 ++
dicom/src/wrapper-client.cl~ | 143 +
dicom/src/wrapper-server.cl | 456 ++++
make-prism.cl | 90 +
polygons/src/contour-algebra.cl | 2003 ++++++++++++++
polygons/src/convex-hull.cl | 269 ++
polygons/src/math.cl | 156 ++
polygons/src/segments.cl | 147 ++
prism/src/anatomy-tree.cl | 532 ++++
prism/src/attribute-editor.cl | 762 ++++++
prism/src/auto-extend-panels.cl | 271 ++
prism/src/auto-extend-panels.cl~ | 269 ++
prism/src/autocontour.cl | 401 +++
prism/src/autovolume.cl | 339 +++
prism/src/beam-block-graphics.cl | 80 +
prism/src/beam-block-panels.cl | 607 +++++
prism/src/beam-blocks.cl | 121 +
prism/src/beam-dose.cl | 1384 ++++++++++
prism/src/beam-graphics.cl | 480 ++++
prism/src/beam-mediators.cl | 189 ++
prism/src/beam-panels.cl | 731 ++++++
prism/src/beam-transforms.cl | 421 +++
prism/src/beams-eye-views.cl | 206 ++
prism/src/beams.cl | 637 +++++
prism/src/bev-draw-all.cl | 36 +
prism/src/bev-graphics.cl | 342 +++
prism/src/brachy-coord-panels.cl | 977 +++++++
prism/src/brachy-dose-panels.cl | 466 ++++
prism/src/brachy-dose.cl | 209 ++
prism/src/brachy-graphics.cl | 201 ++
prism/src/brachy-mediators.cl | 47 +
prism/src/brachy-panels.cl | 296 +++
prism/src/brachy-specs-panels.cl | 657 +++++
prism/src/brachy-tables.cl | 727 ++++++
prism/src/brachy.cl | 394 +++
prism/src/charts.cl | 1634 ++++++++++++
prism/src/clipper.cl | 900 +++++++
prism/src/coll-panels.cl | 1131 ++++++++
prism/src/collim-info.cl | 269 ++
prism/src/collimators.cl | 673 +++++
prism/src/contours.cl | 75 +
prism/src/cstore-status.cl | 78 +
prism/src/dicom-panel.cl | 1777 +++++++++++++
prism/src/dicom-rtplan.cl | 1177 +++++++++
prism/src/digitizer.cl | 279 ++
prism/src/dmp-panel.cl | 451 ++++
prism/src/dose-grid-graphics.cl | 184 ++
prism/src/dose-grid-mediators.cl | 344 +++
prism/src/dose-grids.cl | 202 ++
prism/src/dose-info.cl | 592 +++++
prism/src/dose-result-mediators.cl | 342 +++
prism/src/dose-results.cl | 261 ++
prism/src/dose-spec-mediators.cl | 190 ++
prism/src/dose-surface-graphics.cl | 350 +++
prism/src/dose-surface-panels.cl | 127 +
prism/src/dose-view-mediators.cl | 52 +
prism/src/dosecomp-decls.cl | 362 +++
prism/src/dosecomp.cl | 146 ++
prism/src/drr.cl | 533 ++++
prism/src/dvh-panel.cl | 635 +++++
prism/src/electron-dose.cl | 1520 +++++++++++
prism/src/file-functions.cl | 438 ++++
prism/src/filmstrip.cl | 618 +++++
prism/src/image-graphics.cl | 248 ++
prism/src/image-manager.cl | 263 ++
prism/src/import-structure-sets.cl | 299 +++
prism/src/imrt-segments.cl | 589 +++++
prism/src/inference.cl | 172 ++
prism/src/isocontour.cl | 422 +++
prism/src/linear-expand.cl | 178 ++
prism/src/locators.cl | 436 ++++
prism/src/margin-rules.cl | 100 +
prism/src/medical-images.cl | 538 ++++
prism/src/misc.cl | 386 +++
prism/src/mlc-collimators.cl | 659 +++++
prism/src/mlc-panels.cl | 644 +++++
prism/src/mlc.cl | 386 +++
prism/src/object-manager.cl | 239 ++
prism/src/output-factors.cl | 404 +++
prism/src/patdb-panels.cl | 496 ++++
prism/src/pathlength.cl | 817 ++++++
prism/src/patient-panels.cl | 664 +++++
prism/src/patients.cl | 466 ++++
prism/src/pixel-graphics.cl | 358 +++
prism/src/plan-panels.cl | 690 +++++
prism/src/planar-editor.cl | 1275 +++++++++
prism/src/plans.cl | 384 +++
prism/src/plots.cl | 1233 +++++++++
prism/src/point-dose-panels.cl | 558 ++++
prism/src/point-graphics.cl | 159 ++
prism/src/point-mediators.cl | 48 +
prism/src/points.cl | 121 +
prism/src/prism-db.cl | 834 ++++++
prism/src/prism-globals.cl | 390 +++
prism/src/prism-objects.cl | 136 +
prism/src/prism.cl | 124 +
prism/src/prism.config.example | 118 +
prism/src/ptvt-expand.cl | 154 ++
prism/src/quadtree.cl | 179 ++
prism/src/replace-coll.cl | 134 +
prism/src/scan.cl | 1088 ++++++++
prism/src/selector-panels.cl | 627 +++++
prism/src/spots.cl | 202 ++
prism/src/table-lookups.cl | 775 ++++++
prism/src/tape-measure.cl | 313 +++
prism/src/target-volume.cl | 194 ++
prism/src/therapy-machines.cl | 819 ++++++
prism/src/tools-panel.cl | 62 +
prism/src/view-graphics.cl | 257 ++
prism/src/view-panels.cl | 706 +++++
prism/src/views.cl | 556 ++++
prism/src/volume-editor.cl | 1120 ++++++++
prism/src/volume-graphics.cl | 211 ++
prism/src/volume-mediators.cl | 48 +
prism/src/volumes.cl | 611 +++++
prism/src/wedge-graphics.cl | 279 ++
prism/src/wedges.cl | 93 +
prism/src/write-neutron.cl | 1257 +++++++++
slik/src/2d-plot.cl | 821 ++++++
slik/src/adj-sliderboxes.cl | 189 ++
slik/src/buttons.cl | 291 +++
slik/src/clx-support.cl | 329 +++
slik/src/collections.cl | 179 ++
slik/src/dialboxes.cl | 159 ++
slik/src/dialogboxes.cl | 419 +++
slik/src/dials.cl | 241 ++
slik/src/event-loop.cl | 323 +++
slik/src/events.cl | 71 +
slik/src/frames.cl | 344 +++
slik/src/images.cl | 242 ++
slik/src/initialize.cl | 386 +++
slik/src/menus.cl | 187 ++
slik/src/pictures.cl | 772 ++++++
slik/src/postscript.cl | 407 +++
slik/src/readouts.cl | 160 ++
slik/src/scroll-frames.cl | 179 ++
slik/src/scrollbars.cl | 177 ++
slik/src/scrolling-lists.cl | 548 ++++
slik/src/sliderboxes.cl | 318 +++
slik/src/sliders.cl | 307 +++
slik/src/slik.cl | 124 +
slik/src/spreadsheets.cl | 289 +++
slik/src/textboxes.cl | 317 +++
slik/src/textlines.cl | 319 +++
systemdefs/dicom-client.system | 50 +
systemdefs/dicom-common.system | 78 +
systemdefs/dicom-server.system | 62 +
systemdefs/polygons.system | 54 +
systemdefs/prism.system | 478 ++++
systemdefs/slik.system | 120 +
184 files changed, 80391 insertions(+), 176 deletions(-)
diff --git a/config.cl b/config.cl
new file mode 100644
index 0000000..c9ceb7c
--- /dev/null
+++ b/config.cl
@@ -0,0 +1,65 @@
+;;;
+;;; config
+;;;
+;;; This file contains some environment setup needed by the SLIK
+;;; toolkit.
+;;;
+;;; The defsystem file is required. It is assumed that all the files
+;;; are in the current working directory when this file is loaded.
+;;;
+;;; 9-Jun-1992 I. Kalet created
+;;; 24-Jun-1992 I. Kalet put defpackage etc. for events and
+;;; collections here.
+;;; 20-Oct-1992 I. Kalet cosmetic fixes - delete making PCL a nickname
+;;; for COMMON-LISP - not needed
+;;; 02-Mar-1993 J. Unger add some cmu read-time conditionals.
+;;; 27-Jul-1993 I. Kalet add some lucid read-time conditionals.
+;;; 7-Jan-1995 I. Kalet move defpackage etc. for events and
+;;; collections into those files so they are standalone, and they
+;;; will then be modules in SLIK rather than systems of their own.
+;;; Also remove support for VAXlisp, Lucid.
+;;; 7-Aug-1995 I. Kalet take out *dont-redefine-require* as it is
+;;; internal to defsystem.
+;;; 10-Aug-2003 I. Kalet add location of central repository and
+;;; location of defsystem.cl - files are no longer all in the user's
+;;; default directory.
+;;; 30-Nov-2003 I. Kalet make default location of defsystem and
+;;; systemdefs be the user's default directory, so that systemdefs can
+;;; be managed by CVS also.
+;;; 21-Jun-2004 I. Kalet move CLX nickname form to SLIK - it is only
+;;; used there and in systems that depend on SLIK.
+;;;
+
+;;;----------------------------------------------------------
+;;; here is the compiler setting for the whole works - edit it for
+;;; different compiler runs. Since this file is loaded but not
+;;; compiled it is ok to have this at top-level.
+
+(proclaim '(optimize (speed 3) (safety 1) (space 0) (debug 0)))
+
+;;;----------------------------------------------------------
+;;; We use Mark Kantrowitz's defsystem facility. Set
+;;; defsystem-specific global variables here to avoid having to
+;;; answer questions about recompilation during a load-system.
+;;;----------------------------------------------------------
+
+;; change if defsystem is in a different place in your environment
+(load "defsystem")
+
+(setq mk::*load-source-if-no-binary* t) ;; for load-system
+(setq mk::*compile-during-load* nil)
+(setq mk::*minimal-load* t) ;; so don't reload if not necessary
+
+;; change if system definitions are in a different place in your environment
+(setq mk::*central-registry* "systemdefs/")
+
+;;; function to collect filenames for systems
+
+(defun files (syslist)
+ (apply #'append
+ (mapcar #'(lambda (system)
+ (mk:files-in-system system :all :binary))
+ syslist)))
+
+;;;----------------------------------------------------------
+;;; End.
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index cec8c60..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,5 +0,0 @@
-uw-prism (1.5-2-1) UNRELEASED; urgency=low
-
- * Initial release (Closes: #nnnn) <nnnn is the bug number of your ITP>
-
- -- Thorsten Alteholz <debian at alteholz.de> Thu, 14 Jul 2011 18:15:53 +0200
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index ec63514..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-9
diff --git a/debian/control b/debian/control
deleted file mode 100644
index 3ee3feb..0000000
--- a/debian/control
+++ /dev/null
@@ -1,25 +0,0 @@
-Source: uw-prism
-Maintainer: Debian Med Packaging Team <debian-med-packaging at lists.alioth.debian.org>
-Uploaders: Thorsten Alteholz <debian at alteholz.de>
-Section: science
-Priority: optional
-Build-Depends: debhelper (>= 9.0.0),
- clisp,
- clisp-module-clx,
- cl-acl-compat
-Standards-Version: 3.9.5
-Vcs-Browser: http://anonscm.debian.org/viewvc/debian-med/trunk/packages/uw-prism/
-Vcs-Svn: svn://anonscm.debian.org/debian-med/trunk/packages/uw-prism/trunk/
-Homepage: https://web.archive.org/web/20150228184429/http://faculty.washington.edu/ikalet/prism/
-
-Package: uw-prism
-Architecture: any
-Depends: ${shlibs:Depends},
- ${misc:Depends},
- clisp,
- clisp-module-clx,
- cl-acl-compat
-Description: software tools for radiation therapy planning
- The Prism project is a long term project to build software tools for
- radiation therapy planning, including artificial intelligence tools as
- well as manual simulation systems.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index 168f61c..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,94 +0,0 @@
-Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Name: prism
-Source: https://web.archive.org/web/20150228184429/http://faculty.washington.edu/ikalet/prism/prism-1.5-2.tgz
-
-Files: *
-Copyright: 1990 - 2011 Ira Kalet <ikalet at u.washington.edu>
-License: LLGPL
- It is licensed under the terms of the Lisp Lesser GNU Public License, known
- as the LLGPL. The LLGPL consists of a preamble (see above URL) and the GNU
- Lesser General Public License, or LGPL. Where these conflict, the preamble
- takes precedence. Prism is referenced in the preamble as the .LIBRARY..
- .
- Preamble to the Gnu Lesser General Public License
- .
- Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704
- .
- The concept of the GNU Lesser General Public License version 2.1 ("LGPL")
- has been adopted to govern the use and distribution of above-mentioned
- application. However, the LGPL uses terminology that is more appropriate
- for a program written in C than one written in Lisp. Nevertheless, the LGPL
- can still be applied to a Lisp program if certain clarifications are made.
- This document details those clarifications. Accordingly, the license for the
- open-source Lisp applications consists of this document plus the LGPL.
- Wherever there is a conflict between this document and the LGPL, this
- document takes precedence over the LGPL.
- .
- A "Library" in Lisp is a collection of Lisp functions, data and foreign
- modules. The form of the Library can be Lisp source code (for processing
- by an interpreter) or object code (usually the result of compilation of
- source code or built with some other mechanisms). Foreign modules are object
- code in a form that can be linked into a Lisp executable. When we speak of
- functions we do so in the most general way to include, in addition, methods
- and unnamed functions. Lisp "data" is also a general term that includes the
- data structures resulting from defining Lisp classes. A Lisp application may
- include the same set of Lisp objects as does a Library, but this does not
- mean that the application is necessarily a "work based on the Library" it
- contains.
- .
- The Library consists of everything in the distribution file set before any
- modifications are made to the files. If any of the functions or classes in
- the Library are redefined in other files, then those redefinitions ARE
- considered a work based on the Library. If additional methods are added to
- generic functions in the Library, those additional methods are NOT
- considered a work based on the Library. If Library classes are subclassed,
- these subclasses are NOT considered a work based on the Library. If the
- Library is modified to explicitly call other functions that are neither part
- of Lisp itself nor an available add-on module to Lisp, then the functions
- called by the modified Library ARE considered a work based on the Library.
- The goal is to ensure that the Library will compile and run without getting
- undefined function errors.
- .
- It is permitted to add proprietary source code to the Library, but it must be
- done in a way such that the Library will still run without that proprietary
- code present. Section 5 of the LGPL distinguishes between the case of a
- library being dynamically linked at runtime and one being statically linked
- at build time. Section 5 of the LGPL states that the former results in an
- executable that is a "work that uses the Library." Section 5 of the LGPL
- states that the latter results in one that is a "derivative of the Library",
- which is therefore covered by the LGPL. Since Lisp only offers one choice,
- which is to link the Library into an executable at build time, we declare
- that, for the purpose applying the LGPL to the Library, an executable that
- results from linking a "work that uses the Library" with the Library is
- considered a "work that uses the Library" and is therefore NOT covered by
- the LGPL.
- .
- Because of this declaration, section 6 of LGPL is not applicable to the
- Library. However, in connection with each distribution of this executable,
- you must also deliver, in accordance with the terms and conditions of the
- LGPL, the source code of Library (or your derivative thereof) that is
- incorporated into this executable.
- .
- On Debian systems, the complete text of the LLGPL can be found
- in "/usr/share/common-licenses/LGPL".
-
-Files: debian/*
-Copyright: 2011 Thorsten Alteholz <debian at alteholz.de>
-License: GPL-3.0+
-
-License: GPL-3.0+
- This program is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
- .
- This package is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- .
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
- .
- On Debian systems, the complete text of the GNU General
- Public License version 3 can be found in "/usr/share/common-licenses/GPL-3".
diff --git a/debian/doBuild b/debian/doBuild
deleted file mode 100755
index d57c8c4..0000000
--- a/debian/doBuild
+++ /dev/null
@@ -1,9 +0,0 @@
-#!/bin/bash
-
-# build all stuff
-
-pwd
-find ./* -print
-
-/usr/bin/clisp -i config.cl -x "(mk:compile-system :prism)" \
- -x '(load "make-prism")'
diff --git a/debian/patches/make-prism.cl.patch b/debian/patches/make-prism.cl.patch
deleted file mode 100644
index 5850153..0000000
--- a/debian/patches/make-prism.cl.patch
+++ /dev/null
@@ -1,10 +0,0 @@
---- prims-1.5.1.org/make-prism.cl 2011-07-14 18:38:40.000000000 +0200
-+++ prims-1.5.1/make-prism.cl 2011-07-14 18:39:10.000000000 +0200
-@@ -14,6 +14,7 @@
-
- (defpackage "DICOM" (:use "COMMON-LISP"))
-
-+(require 'acl-compat)
- ;;;--------------------------------------
-
- #+allegro
diff --git a/debian/patches/series b/debian/patches/series
deleted file mode 100644
index 3ed6e10..0000000
--- a/debian/patches/series
+++ /dev/null
@@ -1 +0,0 @@
-make-prism.cl.patch
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 24c52b7..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,14 +0,0 @@
-#!/usr/bin/make -f
-# Uncomment this to turn on verbose mode.
-#export DH_VERBOSE=1
-
-%:
- dh $@
-
-override_dh_auto_build:
- dh_auto_build
- ./debian/doBuild
-
-get-orig-source:
- mkdir -p ../tarballs
- uscan --verbose --force-download --destdir=../tarballs
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/upstream/metadata b/debian/upstream/metadata
deleted file mode 100644
index aa3bc7e..0000000
--- a/debian/upstream/metadata
+++ /dev/null
@@ -1,12 +0,0 @@
-Reference:
- Author: I J Kalet and J P Jacky and M M Austin-Seymour and S M Hummel and K J Sullivan and J M Unger
- Title: "Prism: a new approach to radiotherapy planning software"
- Journal: Int J Radiat Oncol Biol Phys.
- Year: 1996
- Volume: 36
- Number: 2
- Pages: 451-61
- DOI: 10.1016/S0360-3016(96)00322-7
- PMID: 8892471
- URL: http://www.sciencedirect.com/science/article/pii/S0360301696003227
- eprint: http://download.journals.elsevierhealth.com/pdfs/journals/0360-3016/PIIS0360301696003227.pdf
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index 4ccbbc0..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,4 +0,0 @@
-version=4
-
-http://faculty.washington.edu/ikalet/prism/prism-(\d\.\d-\d).tgz
-
diff --git a/defsystem.cl b/defsystem.cl
new file mode 100644
index 0000000..2b9f7e3
--- /dev/null
+++ b/defsystem.cl
@@ -0,0 +1,5017 @@
+;;; -*- Mode: Lisp; Package: make -*-
+;;; -*- Mode: CLtL; Syntax: Common-Lisp -*-
+
+;;; DEFSYSTEM 3.4 Interim 2.
+
+;;; defsystem.lisp --
+
+;;; ****************************************************************
+;;; MAKE -- A Portable Defsystem Implementation ********************
+;;; ****************************************************************
+
+;;; This is a portable system definition facility for Common Lisp.
+;;; Though home-grown, the syntax was inspired by fond memories of the
+;;; defsystem facility on Symbolics 3600's. The exhaustive lists of
+;;; filename extensions for various lisps and the idea to have one
+;;; "operate-on-system" function instead of separate "compile-system"
+;;; and "load-system" functions were taken from Xerox Corp.'s PCL
+;;; system.
+
+;;; This system improves on both PCL and Symbolics defsystem utilities
+;;; by performing a topological sort of the graph of file-dependency
+;;; constraints. Thus, the components of the system need not be listed
+;;; in any special order, because the defsystem command reorganizes them
+;;; based on their constraints. It includes all the standard bells and
+;;; whistles, such as not recompiling a binary file that is up to date
+;;; (unless the user specifies that all files should be recompiled).
+
+;;; Originally written by Mark Kantrowitz, School of Computer Science,
+;;; Carnegie Mellon University, October 1989.
+
+;;; MK:DEFSYSTEM 3.4 Interim 2
+;;;
+;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved.
+;;; 1999 - 2004 Mark Kantrowitz and Marco Antoniotti. All
+;;; rights reserved.
+
+;;; Use, copying, modification, merging, publishing, distribution
+;;; and/or sale of this software, source and/or binary files and
+;;; associated documentation files (the "Software") and of derivative
+;;; works based upon this Software are permitted, as long as the
+;;; following conditions are met:
+
+;;; o this copyright notice is included intact and is prominently
+;;; visible in the Software
+;;; o if modifications have been made to the source code of the
+;;; this package that have not been adopted for inclusion in the
+;;; official version of the Software as maintained by the Copyright
+;;; holders, then the modified package MUST CLEARLY identify that
+;;; such package is a non-standard and non-official version of
+;;; the Software. Furthermore, it is strongly encouraged that any
+;;; modifications made to the Software be sent via e-mail to the
+;;; MK-DEFSYSTEM maintainers for consideration of inclusion in the
+;;; official MK-DEFSYSTEM package.
+
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NON-INFRINGEMENT.
+;;; IN NO EVENT SHALL M. KANTROWITZ AND M. ANTONIOTTI BE LIABLE FOR ANY
+;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+;;; Except as contained in this notice, the names of M. Kantrowitz and
+;;; M. Antoniotti shall not be used in advertising or otherwise to promote
+;;; the sale, use or other dealings in this Software without prior written
+;;; authorization from M. Kantrowitz and M. Antoniotti.
+
+
+;;; Please send bug reports, comments and suggestions to <marcoxa at cons.org>.
+
+;;; ********************************
+;;; Change Log *********************
+;;; ********************************
+;;;
+;;; Note: Several of the fixes from 30-JAN-91 and 31-JAN-91 were done in
+;;; September and October 1990, but not documented until January 1991.
+;;;
+;;; akd = Abdel Kader Diagne <diagne at dfki.uni-sb.de>
+;;; as = Andreas Stolcke <stolcke at ICSI.Berkeley.EDU>
+;;; bha = Brian Anderson <bha at atc.boeing.com>
+;;; brad = Brad Miller <miller at cs.rochester.edu>
+;;; bw = Robert Wilhelm <wilhelm at rpal.rockwell.com>
+;;; djc = Daniel J. Clancy <clancy at cs.utexas.edu>
+;;; fdmm = Fernando D. Mato Mira <matomira at di.epfl.ch>
+;;; gc = Guillaume Cartier <cartier at math.uqam.ca>
+;;; gi = Gabriel Inaebnit <inaebnit at research.abb.ch>
+;;; gpw = George Williams <george at hsvaic.boeing.com>
+;;; hkt = Rick Taube <hkt at cm-next-8.stanford.edu>
+;;; ik = Ik Su Yoo <ik at ctt.bellcore.com>
+;;; jk = John_Kolojejchick at MORK.CIMDS.RI.CMU.EDU
+;;; kt = Kevin Thompson <kthompso at ptolemy.arc.nasa.gov>
+;;; kc = Kaelin Colclasure <kaelin at bridge.com>
+;;; kmr = Kevin M. Rosenberg <kevin at rosenberg.net>
+;;; lmh = Liam M. Healy <Liam.Healy at nrl.navy.mil>
+;;; mc = Matthew Cornell <cornell at unix1.cs.umass.edu>
+;;; oc = Oliver Christ <oli at adler.ims.uni-stuttgart.de>
+;;; rs = Ralph P. Sobek <ralph at vega.laas.fr>
+;;; rs2 = Richard Segal <segal at cs.washington.edu>
+;;; sb = Sean Boisen <sboisen at bbn.com>
+;;; ss = Steve Strassman <straz at cambridge.apple.com>
+;;; tar = Thomas A. Russ <tar at isi.edu>
+;;; toni = Anton Beschta <toni%l4 at ztivax.siemens.com>
+;;; yc = Yang Chen <yangchen%iris.usc.edu at usc.edu>
+;;;
+;;; Thanks to Steve Strassmann <straz at media-lab.media.mit.edu> and
+;;; Sean Boisen <sboisen at BBN.COM> for detailed bug reports and
+;;; miscellaneous assistance. Thanks also to Gabriel Inaebnit
+;;; <inaebnit at research.abb.ch> for help with VAXLisp bugs.
+;;;
+;;; 05-NOV-90 hkt Changed canonicalize-system-name to make system
+;;; names package independent. Interns them in the
+;;; keyword package. Thus either strings or symbols may
+;;; be used to name systems from the user's point of view.
+;;; 05-NOV-90 hkt Added definition FIND-SYSTEM to allow OOS to
+;;; work on systems whose definition hasn't been loaded yet.
+;;; 05-NOV-90 hkt Added definitions COMPILE-SYSTEM and LOAD-SYSTEM
+;;; as alternates to OOS for naive users.
+;;; 05-NOV-90 hkt Shadowing-import of 'defsystem in Allegro CL 3.1 [NeXT]
+;;; into USER package instead of import.
+;;; 15-NOV-90 mk Changed package name to "MAKE", eliminating "DEFSYSTEM"
+;;; to avoid conflicts with allegro, symbolics packages
+;;; named "DEFSYSTEM".
+;;; 30-JAN-91 mk Modified append-directories to work with the
+;;; logical-pathnames system.
+;;; 30-JAN-91 mk Append-directories now works with Sun CL4.0. Also, fixed
+;;; bug wrt Lucid 4.0's pathnames (which changed from lcl3.0
+;;; -- 4.0 uses a list for the directory slot, whereas
+;;; 3.0 required a string). Possible fix to symbolics bug.
+;;; 30-JAN-91 mk Defined NEW-REQUIRE to make redefinition of REQUIRE
+;;; cleaner. Replaced all calls to REQUIRE in this file with
+;;; calls to NEW-REQUIRE, which should avoid compiler warnings.
+;;; 30-JAN-91 mk In VAXLisp, when we redefine lisp:require, the compiler
+;;; no longer automatically executes require forms when it
+;;; encounters them in a file. The user can always wrap an
+;;; (eval-when (compile load eval) ...) around the require
+;;; form. Alternately, see commented out code near the
+;;; redefinition of lisp:require which redefines it as a
+;;; macro instead.
+;;; 30-JAN-91 mk Added parameter :version to operate-on-system. If it is
+;;; a number, that number is used as part of the binary
+;;; directory name as the place to store and load files.
+;;; If NIL (the default), uses regular binary directory.
+;;; If T, tries to find the most recent version of the
+;;; binary directory.
+;;; 30-JAN-91 mk Added global variable *use-timeouts* (default: t), which
+;;; specifies whether timeouts should be used in
+;;; Y-OR-N-P-WAIT. This is provided for users whose lisps
+;;; don't handle read-char-no-hang properly, so that they
+;;; can set it to NIL to disable the timeouts. Usually the
+;;; reason for this is the lisp is run on top of UNIX,
+;;; which buffers input LINES (and provides input editing).
+;;; To get around this we could always turn CBREAK mode
+;;; on and off, but there's no way to do this in a portable
+;;; manner.
+;;; 30-JAN-91 mk Fixed bug where in :test t mode it was actually providing
+;;; the system, instead of faking it.
+;;; 30-JAN-91 mk Changed storage of system definitions to a hash table.
+;;; Changed canonicalize-system-name to coerce the system
+;;; names to uppercase strings. Since we're no longer using
+;;; get, there's no need to intern the names as symbols,
+;;; and strings don't have packages to cause problems.
+;;; Added UNDEFSYSTEM, DEFINED-SYSTEMS, and DESCRIBE-SYSTEM.
+;;; Added :delete-binaries command.
+;;; 31-JAN-91 mk Franz Allegro CL has a defsystem in the USER package,
+;;; so we need to do a shadowing import to avoid name
+;;; conflicts.
+;;; 31-JAN-91 mk Fixed bug in compile-and-load-operation where it was
+;;; only loading newly compiled files.
+;;; 31-JAN-91 mk Added :load-time slot to components to record the
+;;; file-write-date of the binary/source file that was loaded.
+;;; Now knows "when" (which date version) the file was loaded.
+;;; Added keyword :minimal-load and global *minimal-load*
+;;; to enable defsystem to avoid reloading unmodified files.
+;;; Note that if B depends on A, but A is up to date and
+;;; loaded and the user specified :minimal-load T, then A
+;;; will not be loaded even if B needs to be compiled. So
+;;; if A is an initializations file, say, then the user should
+;;; not specify :minimal-load T.
+;;; 31-JAN-91 mk Added :load-only slot to components. If this slot is
+;;; specified as non-NIL, skips over any attempts to compile
+;;; the files in the component. (Loading the file satisfies
+;;; the need to recompile.)
+;;; 31-JAN-91 mk Eliminated use of set-alist-lookup and alist-lookup,
+;;; replacing it with hash tables. It was too much bother,
+;;; and rather brittle too.
+;;; 31-JAN-91 mk Defined #@ macro character for use with AFS @sys
+;;; feature simulator. #@"directory" is then synonymous
+;;; with (afs-binary-directory "directory").
+;;; 31-JAN-91 mk Added :private-file type of module. It is similar to
+;;; :file, but has an absolute pathname. This allows you
+;;; to specify a different version of a file in a system
+;;; (e.g., if you're working on the file in your home
+;;; directory) without completely rewriting the system
+;;; definition.
+;;; 31-JAN-91 mk Operations on systems, such as :compile and :load,
+;;; now propagate to subsystems the system depends on
+;;; if *operations-propagate-to-subsystems* is T (the default)
+;;; and the systems were defined using either defsystem
+;;; or as a :system component of another system. Thus if
+;;; a system depends on another, it can now recompile the
+;;; other.
+;;; 01-FEB-91 mk Added default definitions of PROVIDE/REQUIRE/*MODULES*
+;;; for lisps that have thrown away these definitions in
+;;; accordance with CLtL2.
+;;; 01-FEB-91 mk Added :compile-only slot to components. Analogous to
+;;; :load-only. If :compile-only is T, will not load the
+;;; file on operation :compile. Either compiles or loads
+;;; the file, but not both. In other words, compiling the
+;;; file satisfies the demand to load it. This is useful
+;;; for PCL defmethod and defclass definitions, which wrap
+;;; an (eval-when (compile load eval) ...) around the body
+;;; of the definition -- we save time by not loading the
+;;; compiled code, since the eval-when forces it to be
+;;; loaded. Note that this may not be entirely safe, since
+;;; CLtL2 has added a :load keyword to compile-file, and
+;;; some lisps may maintain a separate environment for
+;;; the compiler. This feature is for the person who asked
+;;; that a :COMPILE-SATISFIES-LOAD keyword be added to
+;;; modules. It's named :COMPILE-ONLY instead to match
+;;; :LOAD-ONLY.
+;;; 11-FEB-91 mk Now adds :mk-defsystem to features list, to allow
+;;; special cased loading of defsystem if not already
+;;; present.
+;;; 19-FEB-91 duff Added filename extension for hp9000/300's running Lucid.
+;;; 26-FEB-91 mk Distinguish between toplevel systems (defined with
+;;; defsystem) and systems defined as a :system module
+;;; of a defsystem. The former can depend only on systems,
+;;; while the latter can depend on anything at the same
+;;; level.
+;;; 12-MAR-91 mk Added :subsystem component type to be a system with
+;;; pathnames relative to its parent component.
+;;; 12-MAR-91 mk Uncommented :device :absolute for CMU pathnames, so
+;;; that the leading slash is included.
+;;; 12-MAR-91 brad Patches for Allegro 4.0.1 on Sparc.
+;;; 12-MAR-91 mk Changed definition of format-justified-string so that
+;;; it no longer depends on the ~<~> format directives,
+;;; because Allegro 4.0.1 has a bug which doesn't support
+;;; them. Anyway, the new definition is twice as fast
+;;; and conses half as much as FORMAT.
+;;; 12-MAR-91 toni Remove nils from list in expand-component-components.
+;;; 12-MAR-91 bw If the default-package and system have the same name,
+;;; and the package is not loaded, this could lead to
+;;; infinite loops, so we bomb out with an error.
+;;; Fixed bug in default packages.
+;;; 13-MAR-91 mk Added global *providing-blocks-load-propagation* to
+;;; control whether system dependencies are loaded if they
+;;; have already been provided.
+;;; 13-MAR-91 brad In-package is a macro in CLtL2 lisps, so we change
+;;; the package manually in operate-on-component.
+;;; 15-MAR-91 mk Modified *central-registry* to be either a single
+;;; directory pathname, or a list of directory pathnames
+;;; to be checked in order.
+;;; 15-MAR-91 rs Added afs-source-directory to handle versions when
+;;; compiling C code under lisp. Other minor changes to
+;;; translate-version and operate-on-system.
+;;; 21-MAR-91 gi Fixed bug in defined-systems.
+;;; 22-MAR-91 mk Replaced append-directories with new version that works
+;;; by actually appending the directories, after massaging
+;;; them into the proper format. This should work for all
+;;; CLtL2-compliant lisps.
+;;; 09-APR-91 djc Missing package prefix for lp:pathname-host-type.
+;;; Modified component-full-pathname to work for logical
+;;; pathnames.
+;;; 09-APR-91 mk Added *dont-redefine-require* to control whether
+;;; REQUIRE is redefined. Fixed minor bugs in redefinition
+;;; of require.
+;;; 12-APR-91 mk (pathname-host nil) causes an error in MCL 2.0b1
+;;; 12-APR-91 mc Ported to MCL2.0b1.
+;;; 16-APR-91 mk Fixed bug in needs-loading where load-time and
+;;; file-write-date got swapped.
+;;; 16-APR-91 mk If the component is load-only, defsystem shouldn't
+;;; tell you that there is no binary and ask you if you
+;;; want to load the source.
+;;; 17-APR-91 mc Two additional operations for MCL.
+;;; 21-APR-91 mk Added feature requested by ik. *files-missing-is-an-error*
+;;; new global variable which controls whether files (source
+;;; and binary) missing cause a continuable error or just a
+;;; warning.
+;;; 21-APR-91 mk Modified load-file-operation to allow compilation of source
+;;; files during load if the binary files are old or
+;;; non-existent. This adds a :compile-during-load keyword to
+;;; oos, and load-system. Global *compile-during-load* sets
+;;; the default (currently :query).
+;;; 21-APR-91 mk Modified find-system so that there is a preference for
+;;; loading system files from disk, even if the system is
+;;; already defined in the environment.
+;;; 25-APR-91 mk Removed load-time slot from component defstruct and added
+;;; function COMPONENT-LOAD-TIME to store the load times in a
+;;; hash table. This is safer than the old definition because
+;;; it doesn't wipe out load times every time the system is
+;;; redefined.
+;;; 25-APR-91 mk Completely rewrote load-file-operation. Fixed some bugs
+;;; in :compile-during-load and in the behavior of defsystem
+;;; when multiple users are compiling and loading a system
+;;; instead of just a single user.
+;;; 16-MAY-91 mk Modified FIND-SYSTEM to do the right thing if the system
+;;; definition file cannot be found.
+;;; 16-MAY-91 mk Added globals *source-pathname-default* and
+;;; *binary-pathname-default* to contain default values for
+;;; :source-pathname and :binary-pathname. For example, set
+;;; *source-pathname-default* to "" to avoid having to type
+;;; :source-pathname "" all the time.
+;;; 27-MAY-91 mk Fixed bug in new-append-directories where directory
+;;; components of the form "foo4.0" would appear as "foo4",
+;;; since pathname-name truncates the type. Changed
+;;; pathname-name to file-namestring.
+;;; 3-JUN-91 gc Small bug in new-append-directories; replace (when
+;;; abs-name) with (when (not (null-string abs-name)))
+;;; 4-JUN-91 mk Additional small change to new-append-directories for
+;;; getting the device from the relative pname if the abs
+;;; pname is "". This is to fix a small behavior in CMU CL old
+;;; compiler. Also changed (when (not (null-string abs-name)))
+;;; to have an (and abs-name) in there.
+;;; 8-JAN-92 sb Added filename extension for defsystem under Lucid Common
+;;; Lisp/SGO 3.0.1+.
+;;; 8-JAN-92 mk Changed the definition of prompt-string to work around an
+;;; AKCL bug. Essentially, AKCL doesn't default the colinc to
+;;; 1 if the colnum is provided, so we hard code it.
+;;; 8-JAN-92 rs (pathname-directory (pathname "")) returns '(:relative) in
+;;; Lucid, instead of NIL. Changed new-append-directories and
+;;; test-new-append-directories to reflect this.
+;;; 8-JAN-92 mk Fixed problem related to *load-source-if-no-binary*.
+;;; compile-and-load-source-if-no-binary wasn't checking for
+;;; the existence of the binary if this variable was true,
+;;; causing the file to not be compiled.
+;;; 8-JAN-92 mk Fixed problem with null-string being called on a pathname
+;;; by returning NIL if the argument isn't a string.
+;;; 3-NOV-93 mk In Allegro 4.2, pathname device is :unspecific by default.
+;;; 11-NOV-93 fdmm Fixed package definition lock problem when redefining
+;;; REQUIRE on ACL.
+;;; 11-NOV-93 fdmm Added machine and software types for SGI and IRIX. It is
+;;; important to distinguish the OS version and CPU type in
+;;; SGI+ACL, since ACL 4.1 on IRIX 4.x and ACL 4.2 on IRIX 5.x
+;;; have incompatible .fasl files.
+;;; 01-APR-94 fdmm Fixed warning problem when redefining REQUIRE on LispWorks.
+;;; 01-NOV-94 fdmm Replaced (software-type) call in ACL by code extracting
+;;; the interesting parts from (software-version) [deleted
+;;; machine name and id].
+;;; 03-NOV-94 fdmm Added a hook (*compile-file-function*), that is funcalled
+;;; by compile-file-operation, so as to support other languages
+;;; running on top of Common Lisp.
+;;; The default is to compile Common Lisp.
+;;; 03-NOV-94 fdmm Added SCHEME-COMPILE-FILE, so that defsystem can now
+;;; compile Pseudoscheme files.
+;;; 04-NOV-94 fdmm Added the exported generic function SET-LANGUAGE, to
+;;; have a clean, easy to extend interface for telling
+;;; defsystem which language to assume for compilation.
+;;; Currently supported arguments: :common-lisp, :scheme.
+;;; 11-NOV-94 kc Ported to Allegro CL for Windows 2.0 (ACLPC) and CLISP.
+;;; 18-NOV-94 fdmm Changed the entry *filename-extensions* for LispWorks
+;;; to support any platform.
+;;; Added entries for :mcl and :clisp too.
+;;; 16-DEC-94 fdmm Added and entry for CMU CL on SGI to *filename-extensions*.
+;;; 16-DEC-94 fdmm Added OS version identification for CMU CL on SGI.
+;;; 16-DEC-94 fdmm For CMU CL 17 : Bypassed make-pathnames call fix
+;;; in NEW-APPEND-DIRECTORIES.
+;;; 16-DEC-94 fdmm Added HOME-SUBDIRECTORY to fix CMU's ignorance about `~'
+;;; when specifying registries.
+;;; 16-DEC-94 fdmm For CMU CL 17 : Bypassed :device fix in make-pathnames call
+;;; in COMPONENT-FULL-PATHNAME. This fix was also reported
+;;; by kc on 12-NOV-94. CMU CL 17 now supports CLtL2 pathnames.
+;;; 16-DEC-94 fdmm Removed a quote before the call to read in the readmacro
+;;; #@. This fixes a really annoying misfeature (couldn't do
+;;; #@(concatenate 'string "foo/" "bar"), for example).
+;;; 03-JAN-95 fdmm Do not include :pcl in *features* if :clos is there.
+;;; 2-MAR-95 mk Modified fdmm's *central-registry* change to use
+;;; user-homedir-pathname and to be a bit more generic in the
+;;; pathnames.
+;;; 2-MAR-95 mk Modified fdmm's updates to *filename-extensions* to handle
+;;; any CMU CL binary extensions.
+;;; 2-MAR-95 mk Make kc's port to ACLPC a little more generic.
+;;; 2-MAR-95 mk djc reported a bug, in which GET-SYSTEM was not returning
+;;; a system despite the system's just having been loaded.
+;;; The system name specified in the :depends-on was a
+;;; lowercase string. I am assuming that the system name
+;;; in the defsystem form was a symbol (I haven't verified
+;;; that this was the case with djc, but it is the only
+;;; reasonable conclusion). So, CANONICALIZE-SYSTEM-NAME
+;;; was storing the system in the hash table as an
+;;; uppercase string, but attempting to retrieve it as a
+;;; lowercase string. This behavior actually isn't a bug,
+;;; but a user error. It was intended as a feature to
+;;; allow users to use strings for system names when
+;;; they wanted to distinguish between two different systems
+;;; named "foo.system" and "Foo.system". However, this
+;;; user error indicates that this was a bad design decision.
+;;; Accordingly, CANONICALIZE-SYSTEM-NAME now uppercases
+;;; even strings for retrieving systems, and the comparison
+;;; in *modules* is now case-insensitive. The result of
+;;; this change is if the user cannot have distinct
+;;; systems in "Foo.system" and "foo.system" named "Foo" and
+;;; "foo", because they will clobber each other. There is
+;;; still case-sensitivity on the filenames (i.e., if the
+;;; system file is named "Foo.system" and you use "foo" in
+;;; the :depends-on, it won't find it). We didn't take the
+;;; further step of requiring system filenames to be lowercase
+;;; because we actually find this kind of case-sensitivity
+;;; to be useful, when maintaining two different versions
+;;; of the same system.
+;;; 7-MAR-95 mk Added simplistic handling of logical pathnames. Also
+;;; modified new-append-directories so that it'll try to
+;;; split up pathname directories that are strings into a
+;;; list of the directory components. Such directories aren't
+;;; ANSI CL, but some non-conforming implementations do it.
+;;; 7-MAR-95 mk Added :proclamations to defsystem form, which can be used
+;;; to set the compiler optimization level before compilation.
+;;; For example,
+;;; :proclamations '(optimize (safety 3) (speed 3) (space 0))
+;;; 7-MAR-95 mk Defsystem now tells the user when it reloads the system
+;;; definition.
+;;; 7-MAR-95 mk Fixed problem pointed out by yc. If
+;;; *source-pathname-default* is "" and there is no explicit
+;;; :source-pathname specified for a file, the file could
+;;; wind up with an empty file name. In other words, this
+;;; global default shouldn't apply to :file components. Added
+;;; explicit test for null strings, and when present replaced
+;;; them with NIL (for binary as well as source, and also for
+;;; :private-file components).
+;;; 7-MAR-95 tar Fixed defsystem to work on TI Explorers (TI CL).
+;;; 7-MAR-95 jk Added machine-type-translation for Decstation 5000/200
+;;; under Allegro 3.1
+;;; 7-MAR-95 as Fixed bug in AKCL-1-615 in which defsystem added a
+;;; subdirectory "RELATIVE" to all filenames.
+;;; 7-MAR-95 mk Added new test to test-new-append-directories to catch the
+;;; error fixed by as. Essentially, this error occurs when the
+;;; absolute-pathname has no directory (i.e., it has a single
+;;; pathname component as in "foo" and not "foo/bar"). If
+;;; RELATIVE ever shows up in the Result, we now know to
+;;; add an extra conditionalization to prevent abs-keyword
+;;; from being set to :relative.
+;;; 7-MAR-95 ss Miscellaneous fixes for MCL 2.0 final.
+;;; *compile-file-verbose* not in MCL, *version variables
+;;; need to occur before AFS-SOURCE-DIRECTORY definition,
+;;; and certain code needed to be in the CCL: package.
+;;; 8-MAR-95 mk Y-OR-N-P-WAIT uses a busy-waiting. On Lisp systems where
+;;; the time functions cons, such as CMU CL, this can cause a
+;;; lot of ugly garbage collection messages. Modified the
+;;; waiting to include calls to SLEEP, which should reduce
+;;; some of the consing.
+;;; 8-MAR-95 mk Replaced fdmm's SET-LANGUAGE enhancement with a more
+;;; general extension, along the lines suggested by akd.
+;;; Defsystem now allows components to specify a :language
+;;; slot, such as :language :lisp, :language :scheme. This
+;;; slot is inherited (with the default being :lisp), and is
+;;; used to obtain compilation and loading functions for
+;;; components, as well as source and binary extensions. The
+;;; compilation and loading functions can be overridden by
+;;; specifying a :compiler or :loader in the system
+;;; definition. Also added :documentation slot to the system
+;;; definition.
+;;; Where this comes in real handy is if one has a
+;;; compiler-compiler implemented in Lisp, and wants the
+;;; system to use the compiler-compiler to create a parser
+;;; from a grammar and then compile parser. To do this one
+;;; would create a module with components that looked
+;;; something like this:
+;;; ((:module cc :components ("compiler-compiler"))
+;;; (:module gr :compiler 'cc :loader #'ignore
+;;; :source-extension "gra"
+;;; :binary-extension "lisp"
+;;; :depends-on (cc)
+;;; :components ("sample-grammar"))
+;;; (:module parser :depends-on (gr)
+;;; :components ("sample-grammar")))
+;;; Defsystem would then compile and load the compiler, use
+;;; it (the function cc) to compile the grammar into a parser,
+;;; and then compile the parser. The only tricky part is
+;;; cc is defined by the system, and one can't include #'cc
+;;; in the system definition. However, one could include
+;;; a call to mk:define-language in the compiler-compiler file,
+;;; and define :cc as a language. This is the prefered method.
+;;; 8-MAR-95 mk New definition of topological-sort suggested by rs2. This
+;;; version avoids the call to SORT, but in practice isn't
+;;; much faster. However, it avoids the need to maintain a
+;;; TIME slot in the topsort-node structure.
+;;; 8-MAR-95 mk rs2 also pointed out that the calls to MAKE-PATHNAME and
+;;; NAMESTRING in COMPONENT-FULL-PATHNAME are a major reason
+;;; why defsystem is slow. Accordingly, I've changed
+;;; COMPONENT-FULL-PATHNAME to include a call to NAMESTRING
+;;; (and removed all other calls to NAMESTRING), and also made
+;;; a few changes to minimize the number of calls to
+;;; COMPONENT-FULL-PATHNAME, such as memoizing it. See To Do
+;;; below for other related comments.
+;;; 8-MAR-95 mk Added special hack requested by Steve Strassman, which
+;;; allows one to specify absolute pathnames in the shorthand
+;;; for a list of components, and have defsystem recognize
+;;; which are absolute and which are relative.
+;;; I actually think this would be a good idea, but I haven't
+;;; tested it, so it is disabled by default. Search for
+;;; *enable-straz-absolute-string-hack* to enable it.
+;;; 8-MAR-95 kt Fixed problem with EXPORT in AKCL 1.603, in which it wasn't
+;;; properly exporting the value of the global export
+;;; variables.
+;;; 8-MAR-95 mk Added UNMUNGE-LUCID to fix nasty problem with COMPILE-FILE
+;;; in Lucid. Lucid apparently tries to merge the :output-file
+;;; with the source file when the :output-file is a relative
+;;; pathname. Wierd, and definitely non-standard.
+;;; 9-MAR-95 mk Changed ALLEGRO-MAKE-SYSTEM-FASL to also include the files
+;;; in any systems the system depends on, as per a
+;;; request of oc.
+;;; 9-MAR-95 mk Some version of CMU CL couldn't hack a call to
+;;; MAKE-PATHNAME with :host NIL. I'm not sure which version
+;;; it is, but the current version doesn't have this problem.
+;;; If given :host nil, it defaults the host to
+;;; COMMON-LISP::*UNIX-HOST*. So I haven't "fixed" this
+;;; problem.
+;;; 9-MAR-95 mk Integrated top-level commands for Allegro designed by bha
+;;; into the code, with slight modifications.
+;;; 9-MAR-95 mk Instead of having COMPUTE-SYSTEM-PATH check the current
+;;; directory in a hard-coded fashion, include the current
+;;; directory in the *central-registry*, as suggested by
+;;; bha and others.
+;;; 9-MAR-95 bha Support for Logical Pathnames in Allegro.
+;;; 9-MAR-95 mk Added modified version of bha's DEFSYSPATH idea.
+;;; 13-MAR-95 mk Added a macro for the simple serial case, where a system
+;;; (or module) is simple a list of files, each of which
+;;; depends on the previous one. If the value of :components
+;;; is a list beginning with :serial, it expands each
+;;; component and makes it depend on the previous component.
+;;; For example, (:serial "foo" "bar" "baz") would create a
+;;; set of components where "baz" depended on "bar" and "bar"
+;;; on "foo".
+;;; 13-MAR-95 mk *** Now version 3.0. This version is a interim bug-fix and
+;;; update, since I do not have the time right now to complete
+;;; the complete overhaul and redesign.
+;;; Major changes in 3.0 include CMU CL 17, CLISP, ACLPC, TI,
+;;; LispWorks and ACL(SGI) support, bug fixes for ACL 4.1/4.2.
+;;; 14-MAR-95 fdmm Finally added the bit of code to discriminate cleanly
+;;; among different lisps without relying on (software-version)
+;;; idiosyncracies.
+;;; You can now customize COMPILER-TYPE-TRANSLATION so that
+;;; AFS-BINARY-DIRECTORY can return a different value for
+;;; different lisps on the same platform.
+;;; If you use only one compiler, do not care about supporting
+;;; code for multiple versions of it, and want less verbose
+;;; directory names, just set *MULTIPLE-LISP-SUPPORT* to nil.
+;;; 17-MAR-95 lmh Added EVAL-WHEN for one of the MAKE-PACKAGE calls.
+;;; CMU CL's RUN-PROGRAM is in the extensions package.
+;;; ABSOLUTE-FILE-NAMESTRING-P was missing :test keyword
+;;; Rearranged conditionalization in DIRECTORY-TO-LIST to
+;;; suppress compiler warnings in CMU CL.
+;;; 17-MAR-95 mk Added conditionalizations to avoid certain CMU CL compiler
+;;; warnings reported by lmh.
+;;; 19990610 ma Added shadowing of 'HARDCOPY-SYSTEM' for LW Personal Ed.
+
+;;; 19991211 ma NEW VERSION 4.0 started.
+;;; 19991211 ma Merged in changes requested by T. Russ of
+;;; ISI. Please refer to the special "ISI" comments to
+;;; understand these changes
+;;; 20000228 ma The symbols FIND-SYSTEM, LOAD-SYSTEM, DEFSYSTEM,
+;;; COMPILE-SYSTEM and HARDCOPY-SYSTEM are no longer
+;;; imported in the COMMON-LISP-USER package.
+;;; Cfr. the definitions of *EXPORTS* and
+;;; *SPECIAL-EXPORTS*.
+;;; 2000-07-21 rlt Add COMPILER-OPTIONS to defstruct to allow user to
+;;; specify special compiler options for a particular
+;;; component.
+;;; 2002-01-08 kmr Changed allegro symbols to lowercase to support
+;;; case-sensitive images
+
+;;;---------------------------------------------------------------------------
+;;; ISI Comments
+;;;
+;;; 19991211 Marco Antoniotti
+;;; These comments come from the "ISI Branch". I believe I did
+;;; include the :load-always extension correctly. The other commets
+;;; seem superseded by other changes made to the system in the
+;;; following years. Some others are now useless with newer systems
+;;; (e.g. filename truncation for new Windows based CL
+;;; implementations.)
+
+;;; 1-OCT-92 tar Fixed problem with TI Lisp machines and append-directory.
+;;; 1-OCT-92 tar Made major modifications to compile-file-operation and
+;;; load-file-operation to reduce the number of probe-file
+;;; and write-date inquiries. This makes the system run much
+;;; faster through slow network connections.
+;;; 13-OCT-92 tar Added :load-always slot to components. If this slot is
+;;; specified as non-NIL, always loads the component.
+;;; This does not trigger dependent compilation.
+;;; (This can be useful when macro definitions needed
+;;; during compilation are changed by later files. In
+;;; this case, not reloading up-to-date files can
+;;; cause different results.)
+;;; 28-OCT-93 tar Allegro 4.2 causes an error on (pathname-device nil)
+;;; 14-SEP-94 tar Disable importing of symbols into (CL-)USER package
+;;; to minimize conflicts with other defsystem utilities.
+;;; 10-NOV-94 tar Added filename truncation code to support Franz Allegro
+;;; PC with it's 8 character filename limitation.
+;;; 15-MAY-98 tar Changed host attribute for pathnames to support LispWorks
+;;; (Windows) pathnames which reference other Drives. Also
+;;; updated file name convention.
+;;; 9-NOV-98 tar Updated new-append-directories for Lucid 5.0
+;;;
+
+
+;;; ********************************
+;;; Ports **************************
+;;; ********************************
+;;;
+;;; DEFSYSTEM has been tested (successfully) in the following lisps:
+;;; CMU Common Lisp (M2.9 15-Aug-90, Compiler M1.8 15-Aug-90)
+;;; CMU Common Lisp (14-Dec-90 beta, Python Compiler 0.0 PMAX/Mach)
+;;; CMU Common Lisp 17f (Python 1.0)
+;;; Franz Allegro Common Lisp 3.1.12 (ExCL 3/30/90)
+;;; Franz Allegro Common Lisp 4.0/4.1/4.2
+;;; Franz Allegro Common Lisp for Windows (2.0)
+;;; Lucid Common Lisp (Version 2.1 6-DEC-87)
+;;; Lucid Common Lisp (3.0 [SPARC,SUN3])
+;;; Lucid Common Lisp (4.0 [SPARC,SUN3])
+;;; VAXLisp (v2.2) [VAX/VMS]
+;;; VAXLisp (v3.1)
+;;; Harlequin LispWorks
+;;; CLISP (CLISP3 [SPARC])
+;;; Symbolics XL12000 (Genera 8.3)
+;;; Scieneer Common Lisp (SCL) 1.1
+;;; Macintosh Common Lisp
+;;; ECL
+;;;
+;;; DEFSYSTEM needs to be tested in the following lisps:
+;;; OpenMCL
+;;; Symbolics Common Lisp (8.0)
+;;; KCL (June 3, 1987 or later)
+;;; AKCL (1.86, June 30, 1987 or later)
+;;; TI (Release 4.1 or later)
+;;; Ibuki Common Lisp (01/01, October 15, 1987)
+;;; Golden Common Lisp (3.1 IBM-PC)
+;;; HP Common Lisp (same as Lucid?)
+;;; Procyon Common Lisp
+
+;;; ********************************
+;;; To Do **************************
+;;; ********************************
+;;;
+;;; COMPONENT-FULL-PATHNAME is a major source of slowness in the system
+;;; because of all the calls to the expensive operations MAKE-PATHNAME
+;;; and NAMESTRING. To improve performance, DEFSYSTEM should be reworked
+;;; to avoid any need to call MAKE-PATHNAME and NAMESTRING, as the logical
+;;; pathnames package does. Unfortunately, I don't have the time to do this
+;;; right now. Instead, I installed a temporary improvement by memoizing
+;;; COMPONENT-FULL-PATHNAME to cache previous calls to the function on
+;;; a component by component and type by type basis. The cache is
+;;; cleared before each call to OOS, in case filename extensions change.
+;;; But DEFSYSTEM should really be reworked to avoid this problem and
+;;; ensure greater portability and to also handle logical pathnames.
+;;;
+;;; Also, PROBE-FILE and FILE-WRITE-DATE are other sources of slowness.
+;;; Perhaps by also memoizing FILE-WRITE-DATE and reimplementing PROBE-FILE
+;;; in terms of FILE-WRITE-DATE, can achieve a further speed-up. This was
+;;; suggested by Steven Feist (feist at ils.nwu.edu).
+;;;
+;;; True CLtL2 logical pathnames support -- can't do it, because CLtL2
+;;; doesn't have all the necessary primitives, and even in Allegro CL 4.2
+;;; (namestring #l"foo:bar;baz.lisp")
+;;; does not work properly.
+;;;
+;;; Create separate stand-alone documentation for defsystem, and also
+;;; a test suite.
+;;;
+;;; Change SYSTEM to be a class instead of a struct, and make it a little
+;;; more generic, so that it permits alternate system definitions.
+;;; Replace OPERATE-ON-SYSTEM with MAP-SYSTEM (args: function, system-name,
+;;; &rest options)
+;;;
+;;; Add a patch directory mechanism. Perhaps have several directories
+;;; with code in them, and the first one with the specified file wins?
+;;; LOAD-PATCHES function.
+;;;
+;;; Need way to load old binaries even if source is newer.
+;;;
+;;; Allow defpackage forms/package definitions in the defsystem? If
+;;; a package not defined, look for and load a file named package.pkg?
+;;;
+;;; need to port for GNU CL (ala kcl)?
+;;;
+;;; Someone asked whether one can have :file components at top-level. I believe
+;;; this is the case, but should double-check that it is possible (and if
+;;; not, make it so).
+;;;
+;;; A common error/misconception seems to involve assuming that :system
+;;; components should include the name of the system file, and that
+;;; defsystem will automatically load the file containing the system
+;;; definition and propagate operations to it. Perhaps this would be a
+;;; nice feature to add.
+;;;
+;;; If a module is :load-only t, then it should not execute its :finally-do
+;;; and :initially-do clauses during compilation operations, unless the
+;;; module's files happen to be loaded during the operation.
+;;;
+;;; System Class. Customizable delimiters.
+;;;
+;;; Load a system (while not loading anything already loaded)
+;;; and inform the user of out of date fasls with the choice
+;;; to load the old fasl or recompile and then load the new
+;;; fasl?
+;;;
+;;; modify compile-file-operation to handle a query keyword....
+;;;
+;;; Perhaps systems should keep around the file-write-date of the system
+;;; definition file, to prevent excessive reloading of the system definition?
+;;;
+;;; load-file-operation needs to be completely reworked to simplify the
+;;; logic of when files get loaded or not.
+;;;
+;;; Need to revamp output: Nesting and indenting verbose output doesn't
+;;; seem cool, especially when output overflows the 80-column margins.
+;;;
+;;; Document various ways of writing a system. simple (short) form
+;;; (where :components is just a list of filenames) in addition to verbose.
+;;; Put documentation strings in code.
+;;;
+;;; :load-time for modules and systems -- maybe record the time the system
+;;; was loaded/compiled here and print it in describe-system?
+;;;
+;;; Make it easy to define new functions that operate on a system. For
+;;; example, a function that prints out a list of files that have changed,
+;;; hardcopy-system, edit-system, etc.
+;;;
+;;; If a user wants to have identical systems for different lisps, do we
+;;; force the user to use logical pathnames? Or maybe we should write a
+;;; generic-pathnames package that parses any pathname format into a
+;;; uniform underlying format (i.e., pull the relevant code out of
+;;; logical-pathnames.lisp and clean it up a bit).
+;;;
+;;; Verify that Mac pathnames now work with append-directories.
+;;;
+;;; A common human error is to violate the modularization by making a file
+;;; in one module depend on a file in another module, instead of making
+;;; one module depend on the other. This is caught because the dependency
+;;; isn't found. However, is there any way to provide a more informative
+;;; error message? Probably not, especially if the system has multiple
+;;; files of the same name.
+;;;
+;;; For a module none of whose files needed to be compiled, have it print out
+;;; "no files need recompilation".
+;;;
+;;; Write a system date/time to a file? (version information) I.e., if the
+;;; filesystem supports file version numbers, write an auxiliary file to
+;;; the system definition file that specifies versions of the system and
+;;; the version numbers of the associated files.
+;;;
+;;; Add idea of a patch directory.
+;;;
+;;; In verbose printout, have it log a date/time at start and end of
+;;; compilation:
+;;; Compiling system "test" on 31-Jan-91 21:46:47
+;;; by Defsystem version v2.0 01-FEB-91.
+;;;
+;;; Define other :force options:
+;;; :query allows user to specify that a file not normally compiled
+;;; should be. OR
+;;; :confirm allows user to specify that a file normally compiled
+;;; shouldn't be. AND
+;;;
+;;; We currently assume that compilation-load dependencies and if-changed
+;;; dependencies are identical. However, in some cases this might not be
+;;; true. For example, if we change a macro we have to recompile functions
+;;; that depend on it (except in lisps that automatically do this, such
+;;; as the new CMU Common Lisp), but not if we change a function. Splitting
+;;; these apart (with appropriate defaulting) would be nice, but not worth
+;;; doing immediately since it may save only a couple of file recompilations,
+;;; while making defsystem much more complex than it already is.
+;;;
+;;; Current dependencies are limited to siblings. Maybe we should allow
+;;; nephews and uncles? So long as it is still a DAG, we can sort it.
+;;; Answer: No. The current setup enforces a structure on the modularity.
+;;; Otherwise, why should we have modules if we're going to ignore it?
+;;;
+;;; Currently a file is recompiled more or less if the source is newer
+;;; than the binary or if the file depends on a file that has changed
+;;; (i.e., was recompiled in this session of a system operation).
+;;; Neil Goldman <goldman at isi.edu> has pointed out that whether a file
+;;; needs recompilation is really independent of the current session of
+;;; a system operation, and depends only on the file-write-dates of the
+;;; source and binary files for a system. Thus a file should require
+;;; recompilation in the following circumstances:
+;;; 1. If a file's source is newer than its binary, or
+;;; 2. If a file's source is not newer than its binary, but the file
+;;; depends directly or indirectly on a module (or file) that is newer.
+;;; For a regular file use the file-write-date (FWD) of the source or
+;;; binary, whichever is more recent. For a load-only file, use the only
+;;; available FWD. For a module, use the most recent (max) FWD of any of
+;;; its components.
+;;; The impact of this is that instead of using a boolean CHANGED variable
+;;; throughout the code, we need to allow CHANGED to be NIL/T/<FWD> or
+;;; maybe just the FWD timestamp, and to use the value of CHANGED in
+;;; needs-compilation decisions. (Use of NIL/T as values is an optimization.
+;;; The FWD timestamp which indicates the most recent time of any changes
+;;; should be sufficient.) This will affect not just the
+;;; compile-file-operation, but also the load-file-operation because of
+;;; compilation during load. Also, since FWDs will be used more prevalently,
+;;; we probably should couple this change with the inclusion of load-times
+;;; in the component defstruct. This is a tricky and involved change, and
+;;; requires more thought, since there are subtle cases where it might not
+;;; be correct. For now, the change will have to wait until the DEFSYSTEM
+;;; redesign.
+
+;;; ********************************************************************
+;;; How to Use this System *********************************************
+;;; ********************************************************************
+
+;;; To use this system,
+;;; 1. If you want to have a central registry of system definitions,
+;;; modify the value of the variable *central-registry* below.
+;;; 2. Load this file (defsystem.lisp) in either source or compiled form,
+;;; 3. Load the file containing the "defsystem" definition of your system,
+;;; 4. Use the function "operate-on-system" to do things to your system.
+
+;;; For more information, see the documentation and examples in
+;;; lisp-utilities.ps.
+
+;;; ********************************
+;;; Usage Comments *****************
+;;; ********************************
+
+;;; If you use symbols in the system definition file, they get interned in
+;;; the COMMON-LISP-USER package, which can lead to name conflicts when
+;;; the system itself seeks to export the same symbol to the COMMON-LISP-USER
+;;; package. The workaround is to use strings instead of symbols for the
+;;; names of components in the system definition file. In the major overhaul,
+;;; perhaps the user should be precluded from using symbols for such
+;;; identifiers.
+;;;
+;;; If you include a tilde in the :source-pathname in Allegro, as in "~/lisp",
+;;; file name expansion is much slower than if you use the full pathname,
+;;; as in "/user/USERID/lisp".
+;;;
+
+
+;;; ****************************************************************
+;;; Lisp Code ******************************************************
+;;; ****************************************************************
+
+;;; ********************************
+;;; Massage CLtL2 onto *features* **
+;;; ********************************
+;;; Let's be smart about CLtL2 compatible Lisps:
+(eval-when (compile load eval)
+ #+(or (and allegro-version>= (version>= 4 0)) :mcl :sbcl)
+ (pushnew :cltl2 *features*))
+
+;;; ********************************
+;;; Provide/Require/*modules* ******
+;;; ********************************
+
+;;; Since CLtL2 has dropped require and provide from the language, some
+;;; lisps may not have the functions PROVIDE and REQUIRE and the
+;;; global *MODULES*. So if lisp::provide and user::provide are not
+;;; defined, we define our own.
+
+;;; Hmmm. CMU CL old compiler gives bogus warnings here about functions
+;;; and variables not being declared or bound, apparently because it
+;;; sees that (or (fboundp 'lisp::require) (fboundp 'user::require)) returns
+;;; T, so it doesn't really bother when compiling the body of the unless.
+;;; The new compiler does this properly, so I'm not going to bother
+;;; working around this.
+
+;;; Some Lisp implementations return bogus warnings about assuming
+;;; *MODULE-FILES* and *LIBRARY* to be special, and CANONICALIZE-MODULE-NAME
+;;; and MODULE-FILES being undefined. Don't worry about them.
+
+;;; Now that ANSI CL includes PROVIDE and REQUIRE again, is this code
+;;; necessary?
+
+#-(or :CMU
+ :vms
+ :mcl
+ :lispworks
+ :clisp
+ :gcl
+ :sbcl
+ :cormanlisp
+ :scl
+ (and allegro-version>= (version>= 4 1)))
+(eval-when #-(or :lucid)
+ (:compile-toplevel :load-toplevel :execute)
+ #+(or :lucid)
+ (compile load eval)
+
+ (unless (or (fboundp 'lisp::require)
+ (fboundp 'user::require)
+
+ #+(and :excl (and allegro-version>= (version>= 4 0)))
+ (fboundp 'cltl1::require)
+
+ #+:lispworks
+ (fboundp 'system::require))
+
+ #-:lispworks
+ (in-package "LISP")
+ #+:lispworks
+ (in-package "SYSTEM")
+
+ (export '(*modules* provide require))
+
+ ;; Documentation strings taken almost literally from CLtL1.
+
+ (defvar *modules* ()
+ "List of names of the modules that have been loaded into Lisp so far.
+ It is used by PROVIDE and REQUIRE.")
+
+ ;; We provide two different ways to define modules. The default way
+ ;; is to put either a source or binary file with the same name
+ ;; as the module in the library directory. The other way is to define
+ ;; the list of files in the module with defmodule.
+
+ ;; The directory listed in *library* is implementation dependent,
+ ;; and is intended to be used by Lisp manufacturers as a place to
+ ;; store their implementation dependent packages.
+ ;; Lisp users should use systems and *central-registry* to store
+ ;; their packages -- it is intended that *central-registry* is
+ ;; set by the user, while *library* is set by the lisp.
+
+ (defvar *library* nil ; "/usr/local/lisp/Modules/"
+ "Directory within the file system containing files, where the name
+ of a file is the same as the name of the module it contains.")
+
+ (defvar *module-files* (make-hash-table :test #'equal)
+ "Hash table mapping from module names to list of files for the
+ module. REQUIRE loads these files in order.")
+
+ (defun canonicalize-module-name (name)
+ ;; if symbol, string-downcase the printrep to make nicer filenames.
+ (if (stringp name) name (string-downcase (string name))))
+
+ (defmacro defmodule (name &rest files)
+ "Defines a module NAME to load the specified FILES in order."
+ `(setf (gethash (canonicalize-module-name ,name) *module-files*)
+ ',files))
+ (defun module-files (name)
+ (gethash name *module-files*))
+
+ (defun provide (name)
+ "Adds a new module name to the list of modules maintained in the
+ variable *modules*, thereby indicating that the module has been
+ loaded. Name may be a string or symbol -- strings are case-senstive,
+ while symbols are treated like lowercase strings. Returns T if
+ NAME was not already present, NIL otherwise."
+ (let ((module (canonicalize-module-name name)))
+ (unless (find module *modules* :test #'string=)
+ ;; Module not present. Add it and return T to signify that it
+ ;; was added.
+ (push module *modules*)
+ t)))
+
+ (defun require (name &optional pathname)
+ "Tests whether a module is already present. If the module is not
+ present, loads the appropriate file or set of files. The pathname
+ argument, if present, is a single pathname or list of pathnames
+ whose files are to be loaded in order, left to right. If the
+ pathname is nil, the system first checks if a module was defined
+ using defmodule and uses the pathnames so defined. If that fails,
+ it looks in the library directory for a file with name the same
+ as that of the module. Returns T if it loads the module."
+ (let ((module (canonicalize-module-name name)))
+ (unless (find module *modules* :test #'string=)
+ ;; Module is not already present.
+ (when (and pathname (not (listp pathname)))
+ ;; If there's a pathname or pathnames, ensure that it's a list.
+ (setf pathname (list pathname)))
+ (unless pathname
+ ;; If there's no pathname, try for a defmodule definition.
+ (setf pathname (module-files module)))
+ (unless pathname
+ ;; If there's still no pathname, try the library directory.
+ (when *library*
+ (setf pathname (concatenate 'string *library* module))
+ ;; Test if the file exists.
+ ;; We assume that the lisp will default the file type
+ ;; appropriately. If it doesn't, use #+".fasl" or some
+ ;; such in the concatenate form above.
+ (if (probe-file pathname)
+ ;; If it exists, ensure we've got a list
+ (setf pathname (list pathname))
+ ;; If the library file doesn't exist, we don't want
+ ;; a load error.
+ (setf pathname nil))))
+ ;; Now that we've got the list of pathnames, let's load them.
+ (dolist (pname pathname t)
+ (load pname :verbose nil))))))
+ ) ; eval-when
+
+;;; ********************************
+;;; Set up Package *****************
+;;; ********************************
+
+
+;;; Unfortunately, lots of lisps have their own defsystems, some more
+;;; primitive than others, all uncompatible, and all in the DEFSYSTEM
+;;; package. To avoid name conflicts, we've decided to name this the
+;;; MAKE package. A nice side-effect is that the short nickname
+;;; MK is my initials.
+
+#+(or clisp cormanlisp ecl (and gcl defpackage) sbcl)
+(defpackage "MAKE" (:use "COMMON-LISP") (:nicknames "MK"))
+
+#-(or :sbcl :cltl2 :lispworks :ecl :scl)
+(in-package "MAKE" :nicknames '("MK"))
+
+;;; For CLtL2 compatible lisps...
+#+(and :excl :allegro-v4.0 :cltl2)
+(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp)
+ (:import-from cltl1 *modules* provide require))
+
+;;; *** Marco Antoniotti <marcoxa at icsi.berkeley.edu> 19970105
+;;; In Allegro 4.1, 'provide' and 'require' are not external in
+;;; 'CLTL1'. However they are in 'COMMON-LISP'. Hence the change.
+#+(and :excl :allegro-v4.1 :cltl2)
+(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp) )
+
+#+(and :excl :allegro-version>= (version>= 4 2))
+(defpackage "MAKE" (:nicknames "MK" "make" "mk") (:use :common-lisp))
+
+#+:lispworks
+(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
+ (:import-from system *modules* provide require)
+ (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
+ "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))
+
+#+:mcl
+(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
+ (:import-from ccl *modules* provide require))
+
+;;; *** Marco Antoniotti <marcoxa at icsi.berkeley.edu> 19951012
+;;; The code below, is originally executed also for CMUCL. However I
+;;; believe this is wrong, since CMUCL comes with its own defpackage.
+;;; I added the extra :CMU in the 'or'.
+#+(and :cltl2 (not (or :cmu :clisp :sbcl
+ (and :excl (or :allegro-v4.0 :allegro-v4.1))
+ :mcl)))
+(eval-when (compile load eval)
+ (unless (find-package "MAKE")
+ (make-package "MAKE" :nicknames '("MK") :use '("COMMON-LISP"))))
+
+;;; *** Marco Antoniotti <marcoxa at icsi.berkeley.edu> 19951012
+;;; Here I add the proper defpackage for CMU
+#+:CMU
+(defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS")
+ (:nicknames "MK"))
+
+#+:sbcl
+(defpackage "MAKE" (:use "COMMON-LISP")
+ (:nicknames "MK"))
+
+#+:scl
+(defpackage :make (:use :common-lisp)
+ (:nicknames :mk))
+
+#+(or :cltl2 :lispworks :scl)
+(eval-when (compile load eval)
+ (in-package "MAKE"))
+
+#+ecl
+(in-package "MAKE")
+
+;;; *** Marco Antoniotti <marcoxa at icsi.berkeley.edu> 19970105
+;;; 'provide' is not esternal in 'CLTL1' in Allegro v 4.1
+#+(and :excl :allegro-v4.0 :cltl2)
+(cltl1:provide 'make)
+#+(and :excl :allegro-v4.0 :cltl2)
+(provide 'make)
+
+#+:openmcl
+(cl:provide 'make)
+
+#+(and :mcl (not :openmcl))
+(ccl:provide 'make)
+
+#+(and :cltl2 (not (or (and :excl (or :allegro-v4.0 :allegro-v4.1)) :mcl)))
+(provide 'make)
+
+#+:lispworks
+(provide 'make)
+
+#-(or :cltl2 :lispworks)
+(provide 'make)
+
+(pushnew :mk-defsystem *features*)
+
+;;; Some compatibility issues. Mostly for CormanLisp.
+;;; 2002-02-20 Marco Antoniotti
+
+#+cormanlisp
+(defun compile-file-pathname (pathname-designator)
+ (merge-pathnames (make-pathname :type "fasl")
+ (etypecase pathname-designator
+ (pathname pathname-designator)
+ (string (parse-namestring pathname-designator))
+ ;; We need FILE-STREAM here as well.
+ )))
+
+#+cormanlisp
+(defun file-namestring (pathname-designator)
+ (let ((p (etypecase pathname-designator
+ (pathname pathname-designator)
+ (string (parse-namestring pathname-designator))
+ ;; We need FILE-STREAM here as well.
+ )))
+ (namestring (make-pathname :directory ()
+ :name (pathname-name p)
+ :type (pathname-type p)
+ :version (pathname-version p)))))
+
+;;; The external interface consists of *exports* and *other-exports*.
+
+;;; AKCL (at least 1.603) grabs all the (export) forms and puts them up top in
+;;; the compile form, so that you can't use a defvar with a default value and
+;;; then a succeeding export as well.
+
+(eval-when (compile load eval)
+ (defvar *special-exports* nil)
+ (defvar *exports* nil)
+ (defvar *other-exports* nil)
+
+ (export (setq *exports*
+ '(operate-on-system
+ oos
+ afs-binary-directory afs-source-directory
+ files-in-system)))
+ (export (setq *special-exports*
+ '()))
+ (export (setq *other-exports*
+ '(*central-registry*
+ *bin-subdir*
+
+ add-registry-location
+ find-system
+ defsystem compile-system load-system hardcopy-system
+
+ system-definition-pathname
+
+ missing-component
+ missing-component-name
+ missing-component-component
+ missing-module
+ missing-system
+
+ register-foreign-system
+
+ machine-type-translation
+ software-type-translation
+ compiler-type-translation
+ ;; require
+ define-language
+ allegro-make-system-fasl
+ files-which-need-compilation
+ undefsystem
+ defined-systems
+ describe-system clean-system edit-system ;hardcopy-system
+ system-source-size make-system-tag-table
+ *defsystem-version*
+ *compile-during-load*
+ *minimal-load*
+ *dont-redefine-require*
+ *files-missing-is-an-error*
+ *reload-systems-from-disk*
+ *source-pathname-default*
+ *binary-pathname-default*
+ *multiple-lisp-support*
+ ))))
+
+
+;;; We import these symbols into the USER package to make them
+;;; easier to use. Since some lisps have already defined defsystem
+;;; in the user package, we may have to shadowing-import it.
+#|
+#-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
+(eval-when (compile load eval)
+ (import *exports* #-(or :cltl2 :lispworks) "USER"
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
+ (import *special-exports* #-(or :cltl2 :lispworks) "USER"
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
+#+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
+(eval-when (compile load eval)
+ (import *exports* #-(or :cltl2 :lispworks) "USER"
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
+ (shadowing-import *special-exports*
+ #-(or :cltl2 :lispworks) "USER"
+ #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
+|#
+
+#-(or :PCL :CLOS :scl)
+(when (find-package "PCL")
+ (pushnew :pcl *modules*)
+ (pushnew :pcl *features*))
+
+;;; ********************************
+;;; Defsystem Version **************
+;;; ********************************
+(defparameter *defsystem-version* "3.4 Interim 2, 2004-05-31"
+ "Current version number/date for MK:DEFSYSTEM.")
+
+;;; ********************************
+;;; Customizable System Parameters *
+;;; ********************************
+
+(defvar *dont-redefine-require* nil
+ "If T, prevents the redefinition of REQUIRE. This is useful for
+ lisps that treat REQUIRE specially in the compiler.")
+
+(defvar *multiple-lisp-support* t
+ "If T, afs-binary-directory will try to return a name dependent
+ on the particular lisp compiler version being used.")
+
+;;; home-subdirectory --
+;;; HOME-SUBDIRECTORY is used only in *central-registry* below.
+;;; Note that CMU CL 17e does not understand the ~/ shorthand for home
+;;; directories.
+;;;
+;;; Note:
+;;; 20020220 Marco Antoniotti
+;;; The #-cormanlisp version is the original one, which is broken anyway, since
+;;; it is UNIX dependent.
+;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing
+;;; the ANSI USER-HOMEDIR-PATHNAME function.
+#-cormanlisp
+(defun home-subdirectory (directory)
+ (concatenate 'string
+ #+(or :sbcl :cmu :scl)
+ "home:"
+ #-(or :sbcl :cmu :scl)
+ (let ((homedir (user-homedir-pathname)))
+ (or (and homedir (namestring homedir))
+ "~/"))
+ directory))
+
+#+cormanlisp
+(defun home-subdirectory (directory)
+ (declare (type string directory))
+ (concatenate 'string "C:\\" directory))
+
+;;; The following function is available for users to add
+;;; (setq mk:*central-registry* (defsys-env-search-path))
+;;; to Lisp init files in order to use the value of the DEFSYSPATH
+;;; instead of directly coding it in the file.
+#+:allegro
+(defun defsys-env-search-path ()
+ "This function grabs the value of the DEFSYSPATH environment variable
+ and breaks the search path into a list of paths."
+ (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:)
+ :test #'string-equal))
+
+;;; Change this variable to set up the location of a central
+;;; repository for system definitions if you want one.
+;;; This is a defvar to allow users to change the value in their
+;;; lisp init files without worrying about it reverting if they
+;;; reload defsystem for some reason.
+
+;;; Note that if a form is included in the registry list, it will be evaluated
+;;; in COMPUTE-SYSTEM-PATH to return the appropriate directory to check.
+
+(defvar *central-registry*
+ `(;; Current directory
+ "./"
+ #+:LUCID (working-directory)
+ #+ACLPC (current-directory)
+ #+:allegro (excl:current-directory)
+ #+:sbcl (progn *default-pathname-defaults*)
+ #+(or :cmu :scl) (ext:default-directory)
+ ;; *** Marco Antoniotti <marcoxa at icsi.berkeley.edu>
+ ;; Somehow it is better to qualify default-directory in CMU with
+ ;; the appropriate package (i.e. "EXTENSIONS".)
+ ;; Same for Allegro.
+ #+(and :lispworks (not :lispworks4))
+ ,(multiple-value-bind (major minor)
+ #-:lispworks-personal-edition
+ (system::lispworks-version)
+ #+:lispworks-personal-edition
+ (values system::*major-version-number*
+ system::*minor-version-number*)
+ (if (or (> major 3)
+ (and (= major 3) (> minor 2))
+ (and (= major 3) (= minor 2)
+ (equal (lisp-implementation-version) "3.2.1")))
+ `(make-pathname :directory
+ ,(find-symbol "*CURRENT-WORKING-DIRECTORY*"
+ (find-package "SYSTEM")))
+ (find-symbol "*CURRENT-WORKING-DIRECTORY*"
+ (find-package "LW"))))
+ #+:lispworks4
+ (hcl:get-working-directory)
+ ;; Home directory
+ #-sbcl
+ (mk::home-subdirectory "lisp/systems/")
+
+ ;; Global registry
+ "/usr/local/lisp/Registry/")
+ "Central directory of system definitions. May be either a single
+ directory pathname, or a list of directory pathnames to be checked
+ after the local directory.")
+
+
+(defun add-registry-location (pathname)
+ "Adds a path to the central registry."
+ (pushnew pathname *central-registry* :test #'equal))
+
+(defvar *bin-subdir* ".bin/"
+ "The subdirectory of an AFS directory where the binaries are really kept.")
+
+;;; These variables set up defaults for operate-on-system, and are used
+;;; for communication in lieu of parameter passing. Yes, this is bad,
+;;; but it keeps the interface small. Also, in the case of the -if-no-binary
+;;; variables, parameter passing would require multiple value returns
+;;; from some functions. Why make life complicated?
+(defvar *tell-user-when-done* nil
+ "If T, system will print ...DONE at the end of an operation")
+(defvar *oos-verbose* nil
+ "Operate on System Verbose Mode")
+(defvar *oos-test* nil
+ "Operate on System Test Mode")
+(defvar *load-source-if-no-binary* nil
+ "If T, system will try loading the source if the binary is missing")
+(defvar *bother-user-if-no-binary* t
+ "If T, the system will ask the user whether to load the source if
+ the binary is missing")
+(defvar *load-source-instead-of-binary* nil
+ "If T, the system will load the source file instead of the binary.")
+(defvar *compile-during-load* :query
+ "If T, the system will compile source files during load if the
+ binary file is missing. If :query, it will ask the user for
+ permission first.")
+(defvar *minimal-load* nil
+ "If T, the system tries to avoid reloading files that were already loaded
+ and up to date.")
+
+(defvar *files-missing-is-an-error* t
+ "If both the source and binary files are missing, signal a continuable
+ error instead of just a warning.")
+
+(defvar *operations-propagate-to-subsystems* t
+ "If T, operations like :COMPILE and :LOAD propagate to subsystems
+ of a system that are defined either using a component-type of :system
+ or by another defsystem form.")
+
+;;; Particular to CMULisp
+(defvar *compile-error-file-type* "err"
+ "File type of compilation error file in cmulisp")
+(defvar *cmu-errors-to-terminal* t
+ "Argument to :errors-to-terminal in compile-file in cmulisp")
+(defvar *cmu-errors-to-file* t
+ "If T, cmulisp will write an error file during compilation")
+
+;;; ********************************
+;;; Global Variables ***************
+;;; ********************************
+
+;;; Massage people's *features* into better shape.
+(eval-when (compile load eval)
+ (dolist (feature *features*)
+ (when (and (symbolp feature) ; 3600
+ (equal (symbol-name feature) "CMU"))
+ (pushnew :CMU *features*)))
+
+ #+Lucid
+ (when (search "IBM RT PC" (machine-type))
+ (pushnew :ibm-rt-pc *features*))
+ )
+
+;;; *filename-extensions* is a cons of the source and binary extensions.
+(defvar *filename-extensions*
+ (car `(#+(and Symbolics Lispm) ("lisp" . "bin")
+ #+(and dec common vax (not ultrix)) ("LSP" . "FAS")
+ #+(and dec common vax ultrix) ("lsp" . "fas")
+ #+ACLPC ("lsp" . "fsl")
+ #+CLISP ("lsp" . "fas")
+ #+KCL ("lsp" . "o")
+ #+ECL ("lsp" . "so")
+ #+IBCL ("lsp" . "o")
+ #+Xerox ("lisp" . "dfasl")
+ ;; Lucid on Silicon Graphics
+ #+(and Lucid MIPS) ("lisp" . "mbin")
+ ;; the entry for (and lucid hp300) must precede
+ ;; that of (and lucid mc68000) for hp9000/300's running lucid,
+ ;; since *features* on hp9000/300's also include the :mc68000
+ ;; feature.
+ #+(and lucid hp300) ("lisp" . "6bin")
+ #+(and Lucid MC68000) ("lisp" . "lbin")
+ #+(and Lucid Vax) ("lisp" . "vbin")
+ #+(and Lucid Prime) ("lisp" . "pbin")
+ #+(and Lucid SUNRise) ("lisp" . "sbin")
+ #+(and Lucid SPARC) ("lisp" . "sbin")
+ #+(and Lucid :IBM-RT-PC) ("lisp" . "bbin")
+ ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
+ #+(and Lucid PA) ("lisp" . "hbin")
+ #+excl ("cl" . ,(pathname-type (compile-file-pathname "foo.cl")))
+ #+(or :cmu :scl) ("cl" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
+; #+(and :CMU (not (or :sgi :sparc))) ("lisp" . "fasl")
+; #+(and :CMU :sgi) ("lisp" . "sgif")
+; #+(and :CMU :sparc) ("lisp" . "sparcf")
+ #+PRIME ("lisp" . "pbin")
+ #+HP ("l" . "b")
+ #+TI ("lisp" . #.(string (si::local-binary-file-type)))
+ #+:gclisp ("LSP" . "F2S")
+ #+pyramid ("clisp" . "o")
+
+ ;; Harlequin LispWorks
+ #+:lispworks ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
+; #+(and :sun4 :lispworks) ("lisp" . "wfasl")
+; #+(and :mips :lispworks) ("lisp" . "mfasl")
+ #+:mcl ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
+ #+:coral ("lisp" . "fasl")
+
+ ;; Otherwise,
+ ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
+ "Filename extensions for Common Lisp. A cons of the form
+ (Source-Extension . Binary-Extension). If the system is
+ unknown (as in *features* not known), defaults to lisp and fasl.")
+
+(defvar *system-extension*
+ ;; MS-DOS systems can only handle three character extensions.
+ #-ACLPC "system"
+ #+ACLPC "sys"
+ "The filename extension to use with systems.")
+
+;;; The above variables and code should be extended to allow a list of
+;;; valid extensions for each lisp implementation, instead of a single
+;;; extension. When writing a file, the first extension should be used.
+;;; But when searching for a file, every extension in the list should
+;;; be used. For example, CMU Common Lisp recognizes "lisp" "l" "cl" and
+;;; "lsp" (*load-source-types*) as source code extensions, and
+;;; (c:backend-fasl-file-type c:*backend*)
+;;; (c:backend-byte-fasl-file-type c:*backend*)
+;;; and "fasl" as binary (object) file extensions (*load-object-types*).
+
+;;; Note that the above code is used below in the LANGUAGE defstruct.
+
+;;; There is no real support for this variable being nil, so don't change it.
+;;; Note that in any event, the toplevel system (defined with defsystem)
+;;; will have its dependencies delayed. Not having dependencies delayed
+;;; might be useful if we define several systems within one defsystem.
+(defvar *system-dependencies-delayed* t
+ "If T, system dependencies are expanded at run time")
+
+;;; Replace this with consp, dammit!
+(defun non-empty-listp (list)
+ (and list (listp list)))
+
+;;; ********************************
+;;; Component Operation Definition *
+;;; ********************************
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defvar *version-dir* nil
+ "The version subdir. bound in operate-on-system.")
+(defvar *version-replace* nil
+ "The version replace. bound in operate-on-system.")
+(defvar *version* nil
+ "Default version."))
+
+(defvar *component-operations* (make-hash-table :test #'equal)
+ "Hash table of (operation-name function) pairs.")
+(defun component-operation (name &optional operation)
+ (if operation
+ (setf (gethash name *component-operations*) operation)
+ (gethash name *component-operations*)))
+
+;;; ********************************
+;;; AFS @sys immitator *************
+;;; ********************************
+
+;;; mc 11-Apr-91: Bashes MCL's point reader, so commented out.
+#-:mcl
+(eval-when (compile load eval)
+ ;; Define #@"foo" as a shorthand for (afs-binary-directory "foo").
+ ;; For example,
+ ;; <cl> #@"foo"
+ ;; "foo/.bin/rt_mach/"
+ (set-dispatch-macro-character
+ #\# #\@
+ #'(lambda (stream char arg)
+ (declare (ignore char arg))
+ `(afs-binary-directory ,(read stream t nil t)))))
+
+(defvar *find-irix-version-script*
+ "\"1,4 d\\
+s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\
+/./,$ d\\
+\"")
+
+(defun operating-system-version ()
+ #+(and :sgi :excl)
+ (let* ((full-version (software-version))
+ (blank-pos (search " " full-version))
+ (os (subseq full-version 0 blank-pos))
+ (version-rest (subseq full-version
+ (1+ blank-pos)))
+ os-version)
+ (setq blank-pos (search " " version-rest))
+ (setq version-rest (subseq version-rest
+ (1+ blank-pos)))
+ (setq blank-pos (search " " version-rest))
+ (setq os-version (subseq version-rest 0 blank-pos))
+ (setq version-rest (subseq version-rest
+ (1+ blank-pos)))
+ (setq blank-pos (search " " version-rest))
+ (setq version-rest (subseq version-rest
+ (1+ blank-pos)))
+ (concatenate 'string
+ os " " os-version)) ; " " version-rest
+ #+(and :sgi :cmu :sbcl)
+ (concatenate 'string
+ (software-type)
+ (software-version))
+ #+(and :lispworks :irix)
+ (let ((soft-type (software-type)))
+ (if (equalp soft-type "IRIX5")
+ (progn
+ (foreign:call-system
+ (format nil "versions ~A | sed -e ~A > ~A"
+ "eoe1"
+ *find-irix-version-script*
+ "irix-version")
+ "/bin/csh")
+ (with-open-file (s "irix-version")
+ (format nil "IRIX ~S"
+ (read s))))
+ soft-type))
+ #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix))
+ (software-type))
+
+(defun compiler-version ()
+ #+:lispworks (concatenate 'string
+ "lispworks" " " (lisp-implementation-version))
+ #+excl (concatenate 'string
+ "excl" " " excl::*common-lisp-version-number*)
+ #+sbcl (concatenate 'string
+ "sbcl" " " (lisp-implementation-version))
+ #+cmu (concatenate 'string
+ "cmu" " " (lisp-implementation-version))
+ #+scl (concatenate 'string
+ "scl" " " (lisp-implementation-version))
+
+ #+kcl "kcl"
+ #+IBCL "ibcl"
+ #+akcl "akcl"
+ #+gcl "gcl"
+ #+ecl "ecl"
+ #+lucid "lucid"
+ #+ACLPC "aclpc"
+ #+CLISP "clisp"
+ #+Xerox "xerox"
+ #+symbolics "symbolics"
+ #+mcl "mcl"
+ #+coral "coral"
+ #+gclisp "gclisp"
+ )
+
+(defun afs-binary-directory (root-directory)
+ ;; Function for obtaining the directory AFS's @sys feature would have
+ ;; chosen when we're not in AFS. This function is useful as the argument
+ ;; to :binary-pathname in defsystem. For example,
+ ;; :binary-pathname (afs-binary-directory "scanner/")
+ (let ((machine (machine-type-translation
+ #-(and :sgi :allegro-version>= (version>= 4 2))
+ (machine-type)
+ #+(and :sgi :allegro-version>= (version>= 4 2))
+ (machine-version)))
+ (software (software-type-translation
+ #-(and :sgi (or :cmu :sbcl :scl
+ (and :allegro-version>= (version>= 4 2))))
+ (software-type)
+ #+(and :sgi (or :cmu :sbcl :scl
+ (and :allegro-version>= (version>= 4 2))))
+ (operating-system-version)))
+ (lisp (compiler-type-translation (compiler-version))))
+ ;; pmax_mach rt_mach sun3_35 sun3_mach vax_mach
+ (setq root-directory (namestring root-directory))
+ (setq root-directory (ensure-trailing-slash root-directory))
+ (format nil "~A~@[~A~]~@[~A/~]"
+ root-directory
+ *bin-subdir*
+ (if *multiple-lisp-support*
+ (afs-component machine software lisp)
+ (afs-component machine software)))))
+
+(defun afs-source-directory (root-directory &optional version-flag)
+ ;; Function for obtaining the directory AFS's @sys feature would have
+ ;; chosen when we're not in AFS. This function is useful as the argument
+ ;; to :source-pathname in defsystem.
+ (setq root-directory (namestring root-directory))
+ (setq root-directory (ensure-trailing-slash root-directory))
+ (format nil "~A~@[~A/~]"
+ root-directory
+ (and version-flag (translate-version *version*))))
+
+(defun null-string (s)
+ (when (stringp s)
+ (string-equal s "")))
+
+(defun ensure-trailing-slash (dir)
+ (if (and dir
+ (not (null-string dir))
+ (not (char= (char dir
+ (1- (length dir)))
+ #\/))
+ (not (char= (char dir
+ (1- (length dir)))
+ #\\))
+ )
+ (concatenate 'string dir "/")
+ dir))
+
+(defun afs-component (machine software &optional lisp)
+ (format nil "~@[~A~]~@[_~A~]~@[_~A~]"
+ machine
+ (or software "mach")
+ lisp))
+
+(defvar *machine-type-alist* (make-hash-table :test #'equal)
+ "Hash table for retrieving the machine-type")
+(defun machine-type-translation (name &optional operation)
+ (if operation
+ (setf (gethash (string-upcase name) *machine-type-alist*) operation)
+ (gethash (string-upcase name) *machine-type-alist*)))
+
+(machine-type-translation "IBM RT PC" "rt")
+(machine-type-translation "DEC 3100" "pmax")
+(machine-type-translation "DEC VAX-11" "vax")
+(machine-type-translation "DECstation" "pmax")
+(machine-type-translation "Sun3" "sun3")
+(machine-type-translation "Sun-4" "sun4")
+(machine-type-translation "MIPS Risc" "mips")
+(machine-type-translation "SGI" "sgi")
+(machine-type-translation "Silicon Graphics Iris 4D" "sgi")
+(machine-type-translation "Silicon Graphics Iris 4D (R3000)" "sgi")
+(machine-type-translation "Silicon Graphics Iris 4D (R4000)" "sgi")
+(machine-type-translation "Silicon Graphics Iris 4D (R4400)" "sgi")
+(machine-type-translation "IP22" "sgi")
+;;; MIPS R4000 Processor Chip Revision: 3.0
+;;; MIPS R4400 Processor Chip Revision: 5.0
+;;; MIPS R4600 Processor Chip Revision: 1.0
+(machine-type-translation "IP20" "sgi")
+;;; MIPS R4000 Processor Chip Revision: 3.0
+(machine-type-translation "IP17" "sgi")
+;;; MIPS R4000 Processor Chip Revision: 2.2
+(machine-type-translation "IP12" "sgi")
+;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
+(machine-type-translation "IP7" "sgi")
+;;; MIPS R2000A/R3000 Processor Chip Revision: 3.0
+
+(machine-type-translation "x86" "x86")
+;;; ACL
+(machine-type-translation "IBM PC Compatible" "x86")
+;;; LW
+(machine-type-translation "I686" "x86")
+;;; LW
+(machine-type-translation "PC/386" "x86")
+;;; CLisp Win32
+
+#+(and :lucid :sun :mc68000)
+(machine-type-translation "unknown" "sun3")
+
+
+(defvar *software-type-alist* (make-hash-table :test #'equal)
+ "Hash table for retrieving the software-type")
+(defun software-type-translation (name &optional operation)
+ (if operation
+ (setf (gethash (string-upcase name) *software-type-alist*) operation)
+ (gethash (string-upcase name) *software-type-alist*)))
+
+(software-type-translation "BSD UNIX" "mach") ; "unix"
+(software-type-translation "Ultrix" "mach") ; "ultrix"
+(software-type-translation "SunOS" "SunOS")
+(software-type-translation "MACH/4.3BSD" "mach")
+(software-type-translation "IRIX System V" "irix") ; (software-type)
+(software-type-translation "IRIX5" "irix5")
+;;(software-type-translation "IRIX liasg5 5.2 02282016 IP22 mips" "irix5") ; (software-version)
+
+(software-type-translation "IRIX 5.2" "irix5")
+(software-type-translation "IRIX 5.3" "irix5")
+(software-type-translation "IRIX5.2" "irix5")
+(software-type-translation "IRIX5.3" "irix5")
+
+(software-type-translation "Linux" "linux") ; Lispworks for Linux
+(software-type-translation "Linux 2.x, Redhat 6.x and 7.x" "linux") ; ACL
+(software-type-translation "Microsoft Windows 9x/Me and NT/2000/XP" "win32")
+(software-type-translation "Windows NT" "win32") ; LW for Windows
+(software-type-translation "ANSI C program" "ansi-c") ; CLISP
+(software-type-translation "C compiler" "ansi-c") ; CLISP for Win32
+
+(software-type-translation nil "")
+
+#+:lucid
+(software-type-translation "Unix"
+ #+:lcl4.0 "4.0"
+ #+(and :lcl3.0 (not :lcl4.0)) "3.0")
+
+(defvar *compiler-type-alist* (make-hash-table :test #'equal)
+ "Hash table for retrieving the Common Lisp type")
+(defun compiler-type-translation (name &optional operation)
+ (if operation
+ (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
+ (gethash (string-upcase name) *compiler-type-alist*)))
+
+(compiler-type-translation "lispworks 3.2.1" "lispworks")
+(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")
+(compiler-type-translation "lispworks 4.2.0" "lispworks")
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (or (find :case-sensitive common-lisp:*features*)
+ (find :case-insensitive common-lisp:*features*))
+ (if (or (eq excl:*current-case-mode* :case-sensitive-lower)
+ (eq excl:*current-case-mode* :case-sensitive-upper))
+ (push :case-sensitive common-lisp:*features*)
+ (push :case-insensitive common-lisp:*features*))))
+
+
+#+(and allegro case-sensitive ics)
+(compiler-type-translation "excl 6.1" "excl-m")
+#+(and allegro case-sensitive (not ics))
+(compiler-type-translation "excl 6.1" "excl-m8")
+
+#+(and allegro case-insensitive ics)
+(compiler-type-translation "excl 6.1" "excl-a")
+#+(and allegro case-insensitive (not ics))
+(compiler-type-translation "excl 6.1" "excl-a8")
+
+(compiler-type-translation "excl 4.2" "excl")
+(compiler-type-translation "excl 4.1" "excl")
+(compiler-type-translation "cmu 17f" "cmu")
+(compiler-type-translation "cmu 17e" "cmu")
+(compiler-type-translation "cmu 17d" "cmu")
+
+;;; ********************************
+;;; System Names *******************
+;;; ********************************
+
+;;; If you use strings for system names, be sure to use the same case
+;;; as it appears on disk, if the filesystem is case sensitive.
+(defun canonicalize-system-name (name)
+ ;; Originally we were storing systems using GET. This meant that the
+ ;; name of a system had to be a symbol, so we interned the symbols
+ ;; in the keyword package to avoid package dependencies. Now that we're
+ ;; storing the systems in a hash table, we've switched to using strings.
+ ;; Since the hash table is case sensitive, we use uppercase strings.
+ ;; (Names of modules and files may be symbols or strings.)
+ #||(if (keywordp name)
+ name
+ (intern (string-upcase (string name)) "KEYWORD"))||#
+ (if (stringp name) (string-upcase name) (string-upcase (string name))))
+
+(defvar *defined-systems* (make-hash-table :test #'equal)
+ "Hash table containing the definitions of all known systems.")
+
+(defun get-system (name)
+ "Returns the definition of the system named NAME."
+ (gethash (canonicalize-system-name name) *defined-systems*))
+
+(defsetf get-system (name) (value)
+ `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value))
+
+(defun undefsystem (name)
+ "Removes the definition of the system named NAME."
+ (setf (get-system name) nil))
+
+(defun defined-systems ()
+ "Returns a list of defined systems."
+ (let ((result nil))
+ (maphash #'(lambda (key value)
+ (declare (ignore key))
+ (push value result))
+ *defined-systems*)
+ result))
+
+;;; ********************************
+;;; Directory Pathname Hacking *****
+;;; ********************************
+
+;;; Unix example: An absolute directory starts with / while a
+;;; relative directory doesn't. A directory ends with /, while
+;;; a file's pathname doesn't. This is important 'cause
+;;; (pathname-directory "foo/bar") will return "foo" and not "foo/".
+
+;;; I haven't been able to test the fix to the problem with symbolics
+;;; hosts. Essentially, append-directories seems to have been tacking
+;;; the default host onto the front of the pathname (e.g., mk::source-pathname
+;;; gets a "B:" on front) and this overrides the :host specified in the
+;;; component. The value of :host should override that specified in
+;;; the :source-pathname and the default file server. If this doesn't
+;;; fix things, specifying the host in the root pathname "F:>root-dir>"
+;;; may be a good workaround.
+
+;;; Need to verify that merging of pathnames where modules are located
+;;; on different devices (in VMS-based VAXLisp) now works.
+
+;;; Merge-pathnames works for VMS systems. In VMS systems, the directory
+;;; part is enclosed in square brackets, e.g.,
+;;; "[root.child.child_child]" or "[root.][child.][child_child]"
+;;; To concatenate directories merge-pathnames works as follows:
+;;; (merge-pathnames "" "[root]") ==> "[root]"
+;;; (merge-pathnames "[root.]" "[son]file.ext") ==> "[root.son]file.ext"
+;;; (merge-pathnames "[root.]file.ext" "[son]") ==> "[root.son]file.ext"
+;;; (merge-pathnames "[root]file.ext" "[son]") ==> "[root]file.ext"
+;;; Thus the problem with the #-VMS code was that it was merging x y into
+;;; [[x]][y] instead of [x][y] or [x]y.
+
+;;; Miscellaneous notes:
+;;; On GCLisp, the following are equivalent:
+;;; "\\root\\subdir\\BAZ"
+;;; "/root/subdir/BAZ"
+;;; On VAXLisp, the following are equivalent:
+;;; "[root.subdir]BAZ"
+;;; "[root.][subdir]BAZ"
+;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2
+
+(defun new-append-directories (absolute-dir relative-dir)
+ ;; Version of append-directories for CLtL2-compliant lisps. In particular,
+ ;; they must conform to section 23.1.3 "Structured Directories". We are
+ ;; willing to fix minor aberations in this function, but not major ones.
+ ;; Tested in Allegro CL 4.0 (SPARC), Allegro CL 3.1.12 (DEC 3100),
+ ;; CMU CL old and new compilers, Lucid 3.0, Lucid 4.0.
+ (setf absolute-dir (or absolute-dir "")
+ relative-dir (or relative-dir ""))
+ (let* ((abs-dir (pathname absolute-dir))
+ (rel-dir (pathname relative-dir))
+ (host (pathname-host abs-dir))
+ (device (if (null-string absolute-dir) ; fix for CMU CL old compiler
+ (pathname-device rel-dir)
+ (pathname-device abs-dir)))
+ (abs-directory (directory-to-list (pathname-directory abs-dir)))
+ (abs-keyword (when (keywordp (car abs-directory))
+ (pop abs-directory)))
+ ;; Stig (July 2001):
+ ;; Somehow CLISP dies on the next line, but NIL is ok.
+ (abs-name (ignore-errors (file-namestring abs-dir))) ; was pathname-name
+ (rel-directory (directory-to-list (pathname-directory rel-dir)))
+ (rel-keyword (when (keywordp (car rel-directory))
+ (pop rel-directory)))
+ #-(or :MCL :sbcl :clisp) (rel-file (file-namestring rel-dir))
+ ;; Stig (July 2001);
+ ;; These values seems to help clisp as well
+ #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir))
+ #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir))
+ (directory nil))
+
+ ;; TI Common Lisp pathnames can return garbage for file names because
+ ;; of bizarreness in the merging of defaults. The following code makes
+ ;; sure that the name is a valid name by comparing it with the
+ ;; pathname-name. It also strips TI specific extensions and handles
+ ;; the necessary case conversion. TI maps upper back into lower case
+ ;; for unix files!
+ #+TI (if (search (pathname-name abs-dir) abs-name :test #'string-equal)
+ (setf abs-name (string-right-trim "." (string-upcase abs-name)))
+ (setf abs-name nil))
+ #+TI (if (search (pathname-name rel-dir) rel-file :test #'string-equal)
+ (setf rel-file (string-right-trim "." (string-upcase rel-file)))
+ (setf rel-file nil))
+ ;; Allegro v4.0/4.1 parses "/foo" into :directory '(:absolute :root)
+ ;; and filename "foo". The namestring of a pathname with
+ ;; directory '(:absolute :root "foo") ignores everything after the
+ ;; :root.
+ #+(and allegro-version>= (version>= 4 0))
+ (when (eq (car abs-directory) :root) (pop abs-directory))
+ #+(and allegro-version>= (version>= 4 0))
+ (when (eq (car rel-directory) :root) (pop rel-directory))
+
+ (when (and abs-name (not (null-string abs-name))) ; was abs-name
+ (cond ((and (null abs-directory) (null abs-keyword))
+ #-(or :lucid :kcl :akcl TI) (setf abs-keyword :relative)
+ (setf abs-directory (list abs-name)))
+ (t
+ (setf abs-directory (append abs-directory (list abs-name))))))
+ (when (and (null abs-directory)
+ (or (null abs-keyword)
+ ;; In Lucid, an abs-dir of nil gets a keyword of
+ ;; :relative since (pathname-directory (pathname ""))
+ ;; returns (:relative) instead of nil.
+ #+:lucid (eq abs-keyword :relative))
+ rel-keyword)
+ ;; The following feature switches seem necessary in CMUCL
+ ;; Marco Antoniotti 19990707
+ #+(or :sbcl :CMU)
+ (if (typep abs-dir 'logical-pathname)
+ (setf abs-keyword :absolute)
+ (setf abs-keyword rel-keyword))
+ #-(or :sbcl :CMU)
+ (setf abs-keyword rel-keyword))
+ (setf directory (append abs-directory rel-directory))
+ (when abs-keyword (setf directory (cons abs-keyword directory)))
+ (namestring
+ (make-pathname :host host
+ :device device
+ :directory
+ directory
+ :name
+ #-(or :sbcl :MCL :clisp) rel-file
+ #+(or :sbcl :MCL :clisp) rel-name
+
+ #+(or :sbcl :MCL :clisp) :type
+ #+(or :sbcl :MCL :clisp) rel-type
+ ))))
+
+(defun directory-to-list (directory)
+ ;; The directory should be a list, but nonstandard implementations have
+ ;; been known to use a vector or even a string.
+ (cond ((listp directory)
+ directory)
+ ((stringp directory)
+ (cond ((find #\; directory)
+ ;; It's probably a logical pathname, so split at the
+ ;; semicolons:
+ (split-string directory :item #\;))
+ #+MCL
+ ((and (find #\: directory)
+ (not (find #\/ directory)))
+ ;; It's probably a MCL pathname, so split at the colons.
+ (split-string directory :item #\:))
+ (t
+ ;; It's probably a unix pathname, so split at the slash.
+ (split-string directory :item #\/))))
+ (t
+ (coerce directory 'list))))
+
+
+(defparameter *append-dirs-tests*
+ '("~/foo/" "baz/bar.lisp"
+ "~/foo" "baz/bar.lisp"
+ "/foo/bar/" "baz/barf.lisp"
+ "/foo/bar/" "/baz/barf.lisp"
+ "foo/bar/" "baz/barf.lisp"
+ "foo/bar" "baz/barf.lisp"
+ "foo/bar" "/baz/barf.lisp"
+ "foo/bar/" "/baz/barf.lisp"
+ "/foo/bar/" nil
+ "foo/bar/" nil
+ "foo/bar" nil
+ "foo" nil
+ "foo" ""
+ nil "baz/barf.lisp"
+ nil "/baz/barf.lisp"
+ nil nil))
+
+(defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*))
+ (do* ((dir-list test-dirs (cddr dir-list))
+ (abs-dir (car dir-list) (car dir-list))
+ (rel-dir (cadr dir-list) (cadr dir-list)))
+ ((null dir-list) (values))
+ (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S"
+ abs-dir rel-dir (new-append-directories abs-dir rel-dir))))
+
+#||
+<cl> (test-new-append-directories)
+
+ABS: "~/foo/" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp"
+ABS: "~/foo" REL: "baz/bar.lisp" Result: "/usr0/mkant/foo/baz/bar.lisp"
+ABS: "/foo/bar/" REL: "baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp"
+ABS: "/foo/bar/" REL: "/baz/barf.lisp" Result: "/foo/bar/baz/barf.lisp"
+ABS: "foo/bar/" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
+ABS: "foo/bar" REL: "baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
+ABS: "foo/bar" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
+ABS: "foo/bar/" REL: "/baz/barf.lisp" Result: "foo/bar/baz/barf.lisp"
+ABS: "/foo/bar/" REL: NIL Result: "/foo/bar/"
+ABS: "foo/bar/" REL: NIL Result: "foo/bar/"
+ABS: "foo/bar" REL: NIL Result: "foo/bar/"
+ABS: "foo" REL: NIL Result: "foo/"
+ABS: "foo" REL: "" Result: "foo/"
+ABS: NIL REL: "baz/barf.lisp" Result: "baz/barf.lisp"
+ABS: NIL REL: "/baz/barf.lisp" Result: "/baz/barf.lisp"
+ABS: NIL REL: NIL Result: ""
+
+||#
+
+
+(defun append-directories (absolute-directory relative-directory)
+ "There is no CL primitive for tacking a subdirectory onto a directory.
+ We need such a function because defsystem has both absolute and
+ relative pathnames in the modules. This is a somewhat ugly hack which
+ seems to work most of the time. We assume that ABSOLUTE-DIRECTORY
+ is a directory, with no filename stuck on the end. Relative-directory,
+ however, may have a filename stuck on the end."
+ (when (or absolute-directory relative-directory)
+ (cond
+ ;; KMR commented out because: when appending two logical pathnames,
+ ;; using this code translates the first logical pathname then appends
+ ;; the second logical pathname -- an error.
+ #|
+ ;; We need a reliable way to determine if a pathname is logical.
+ ;; Allegro 4.1 does not recognize the syntax of a logical pathname
+ ;; as being logical unless its logical host is already defined.
+
+ #+(or (and allegro-version>= (version>= 4 1))
+ :logical-pathnames-mk)
+ ((and absolute-directory
+ (logical-pathname-p absolute-directory)
+ relative-directory)
+ ;; For use with logical pathnames package.
+ (append-logical-directories-mk absolute-directory relative-directory))
+ |#
+ ((namestring-probably-logical absolute-directory)
+ ;; A simplistic stab at handling logical pathnames
+ (append-logical-pnames absolute-directory relative-directory))
+ (t
+ ;; In VMS, merge-pathnames actually does what we want!!!
+ #+:VMS
+ (namestring (merge-pathnames (or absolute-directory "")
+ (or relative-directory "")))
+ #+:macl1.3.2
+ (namestring (make-pathname :directory absolute-directory
+ :name relative-directory))
+ ;; Cross your fingers and pray.
+ #-(or :VMS :macl1.3.2)
+ (new-append-directories absolute-directory relative-directory)))))
+
+#+:logical-pathnames-mk
+(defun append-logical-directories-mk (absolute-dir relative-dir)
+ (lp:append-logical-directories absolute-dir relative-dir))
+
+
+;;; append-logical-pathnames-mk --
+;;; The following is probably still bogus and it does not solve the
+;;; problem of appending two logical pathnames.
+;;; Anyway, as per suggetsion by KMR, the function is not called
+;;; anymore.
+;;; Hopefully this will not cause problems for ACL.
+
+#+(and (and allegro-version>= (version>= 4 1))
+ (not :logical-pathnames-mk))
+(defun append-logical-directories-mk (absolute-dir relative-dir)
+ ;; We know absolute-dir and relative-dir are non nil. Moreover
+ ;; absolute-dir is a logical pathname.
+ (setq absolute-dir (logical-pathname absolute-dir))
+ (etypecase relative-dir
+ (string (setq relative-dir (parse-namestring relative-dir)))
+ (pathname #| do nothing |#))
+
+ (translate-logical-pathname
+ (merge-pathnames relative-dir absolute-dir)))
+
+#| Old version 2002-03-02
+#+(and (and allegro-version>= (version>= 4 1))
+ (not :logical-pathnames-mk))
+(defun append-logical-directories-mk (absolute-dir relative-dir)
+ ;; We know absolute-dir and relative-dir are non nil. Moreover
+ ;; absolute-dir is a logical pathname.
+ (setq absolute-dir (logical-pathname absolute-dir))
+ (etypecase relative-dir
+ (string (setq relative-dir (parse-namestring relative-dir)))
+ (pathname #| do nothing |#))
+
+ (translate-logical-pathname
+ (make-pathname
+ :host (or (pathname-host absolute-dir)
+ (pathname-host relative-dir))
+ :directory (append (pathname-directory absolute-dir)
+ (cdr (pathname-directory relative-dir)))
+ :name (or (pathname-name absolute-dir)
+ (pathname-name relative-dir))
+ :type (or (pathname-type absolute-dir)
+ (pathname-type relative-dir))
+ :version (or (pathname-version absolute-dir)
+ (pathname-version relative-dir)))))
+
+;; Old version
+#+(and (and allegro-version>= (version>= 4 1))
+ (not :logical-pathnames-mk))
+(defun append-logical-directories-mk (absolute-dir relative-dir)
+ (when (or absolute-dir relative-dir)
+ (setq absolute-dir (logical-pathname (or absolute-dir ""))
+ relative-dir (logical-pathname (or relative-dir "")))
+ (translate-logical-pathname
+ (make-pathname
+ :host (or (pathname-host absolute-dir)
+ (pathname-host relative-dir))
+ :directory (append (pathname-directory absolute-dir)
+ (cdr (pathname-directory relative-dir)))
+ :name (or (pathname-name absolute-dir)
+ (pathname-name relative-dir))
+ :type (or (pathname-type absolute-dir)
+ (pathname-type relative-dir))
+ :version (or (pathname-version absolute-dir)
+ (pathname-version relative-dir))))))
+|#
+
+;;; determines if string or pathname object is logical
+#+:logical-pathnames-mk
+(defun logical-pathname-p (thing)
+ (eq (lp:pathname-host-type thing) :logical))
+
+;;; From Kevin Layer for 4.1final.
+#+(and (and allegro-version>= (version>= 4 1))
+ (not :logical-pathnames-mk))
+(defun logical-pathname-p (thing)
+ (typep (parse-namestring thing) 'logical-pathname))
+
+(defun pathname-logical-p (thing)
+ (typecase thing
+ (logical-pathname t)
+ #+clisp ; CLisp has non conformant Logical Pathnames.
+ (pathname (pathname-logical-p (namestring thing)))
+ (string (and (= 1 (count #\: thing)) ; Shortcut.
+ (ignore-errors (translate-logical-pathname thing))
+ t))
+ (t nil)))
+
+;;; This affects only one thing.
+;;; 19990707 Marco Antoniotti
+;;; old version
+
+(defun namestring-probably-logical (namestring)
+ (and (stringp namestring)
+ ;; unix pathnames don't have embedded semicolons
+ (find #\; namestring)))
+#||
+;;; New version
+(defun namestring-probably-logical (namestring)
+ (and (stringp namestring)
+ (typep (parse-namestring namestring) 'logical-pathname)))
+
+
+;;; New new version
+;;; 20000321 Marco Antoniotti
+(defun namestring-probably-logical (namestring)
+ (pathname-logical-p namestring))
+||#
+
+
+#|| This is incorrect, as it strives to keep strings around, when it
+ shouldn't. MERGE-PATHNAMES already DTRT.
+(defun append-logical-pnames (absolute relative)
+ (declare (type (or null string pathname) absolute relative))
+ (let ((abs (if absolute
+ #-clisp (namestring absolute)
+ #+clisp absolute ;; Stig (July 2001): hack to avoid CLISP from translating the whole string
+ ""))
+ (rel (if relative (namestring relative) ""))
+ )
+ ;; Make sure the absolute directory ends with a semicolon unless
+ ;; the pieces are null strings
+ (unless (or (null-string abs) (null-string rel)
+ (char= (char abs (1- (length abs)))
+ #\;))
+ (setq abs (concatenate 'string abs ";")))
+ ;; Return the concatenate pathnames
+ (concatenate 'string abs rel)))
+||#
+
+
+(defun append-logical-pnames (absolute relative)
+ (declare (type (or null string pathname) absolute relative))
+ (let ((abs (if absolute
+ (pathname absolute)
+ (make-pathname :directory (list :absolute)
+ :name nil
+ :type nil)
+ ))
+ (rel (if relative
+ (pathname relative)
+ (make-pathname :directory (list :relative)
+ :name nil
+ :type nil)
+ ))
+ )
+ ;; The following is messed up because CMUCL and LW use different
+ ;; defaults for host (in particular LW uses NIL). Thus
+ ;; MERGE-PATHNAMES has legitimate different behaviors on both
+ ;; implementations. Of course this is disgusting, but that is the
+ ;; way it is and the rest tries to circumvent this crap.
+ (etypecase abs
+ (logical-pathname
+ (etypecase rel
+ (logical-pathname
+ (namestring (merge-pathnames rel abs)))
+ (pathname
+ ;; The following potentially translates the logical pathname
+ ;; very early, but we cannot avoid it.
+ (namestring (merge-pathnames rel (translate-logical-pathname abs))))
+ ))
+ (pathname
+ (namestring (merge-pathnames rel abs)))
+ )))
+
+#||
+;;; This was a try at appending a subdirectory onto a directory.
+;;; It failed. We're keeping this around to prevent future mistakes
+;;; of a similar sort.
+(defun merge-directories (absolute-directory relative-directory)
+ ;; replace concatenate with something more intelligent
+ ;; i.e., concatenation won't work with some directories.
+ ;; it should also behave well if the parent directory
+ ;; has a filename at the end, or if the relative-directory ain't relative
+ (when absolute-directory
+ (setq absolute-directory (pathname-directory absolute-directory)))
+ (concatenate 'string
+ (or absolute-directory "")
+ (or relative-directory "")))
+||#
+
+#||
+<cl> (defun d (d n) (namestring (make-pathname :directory d :name n)))
+
+D
+<cl> (d "~/foo/" "baz/bar.lisp")
+"/usr0/mkant/foo/baz/bar.lisp"
+
+<cl> (d "~/foo" "baz/bar.lisp")
+"/usr0/mkant/foo/baz/bar.lisp"
+
+<cl> (d "/foo/bar/" "baz/barf.lisp")
+"/foo/bar/baz/barf.lisp"
+
+<cl> (d "foo/bar/" "baz/barf.lisp")
+"foo/bar/baz/barf.lisp"
+
+<cl> (d "foo/bar" "baz/barf.lisp")
+"foo/bar/baz/barf.lisp"
+
+<cl> (d "foo/bar" "/baz/barf.lisp")
+"foo/bar//baz/barf.lisp"
+
+<cl> (d "foo/bar" nil)
+"foo/bar/"
+
+<cl> (d nil "baz/barf.lisp")
+"baz/barf.lisp"
+
+<cl> (d nil nil)
+""
+
+||#
+
+;;; The following is a change proposed by DTC for SCL.
+;;; Maybe it could be used all the time.
+
+#-scl
+(defun new-file-type (pathname type)
+ ;; why not (make-pathname :type type :defaults pathname)?
+ (make-pathname
+ :host (pathname-host pathname)
+ :device (pathname-device pathname)
+ :directory (pathname-directory pathname)
+ :name (pathname-name pathname)
+ :type type
+ :version (pathname-version pathname)))
+
+
+#+scl
+(defun new-file-type (pathname type)
+ ;; why not (make-pathname :type type :defaults pathname)?
+ (make-pathname
+ :host (pathname-host pathname :case :common)
+ :device (pathname-device pathname :case :common)
+ :directory (pathname-directory pathname :case :common)
+ :name (pathname-name pathname :case :common)
+ :type (string-upcase type)
+ :version (pathname-version pathname :case :common)))
+
+
+
+;;; ********************************
+;;; Component Defstruct ************
+;;; ********************************
+(defvar *source-pathname-default* nil
+ "Default value of :source-pathname keyword in DEFSYSTEM. Set this to
+ \"\" to avoid having to type :source-pathname \"\" all the time.")
+
+(defvar *binary-pathname-default* nil
+ "Default value of :binary-pathname keyword in DEFSYSTEM.")
+
+;;; Removed TIME slot, which has been made unnecessary by the new definition
+;;; of topological-sort.
+
+(defstruct (topological-sort-node (:conc-name topsort-))
+ (color :white :type (member :gray :black :white))
+ ;; time
+ )
+
+(defstruct (component (:include topological-sort-node)
+ (:print-function print-component))
+ (type :file ; to pacify the CMUCL compiler (:type is alway supplied)
+ :type (member :defsystem
+ :system
+ :subsystem
+ :module
+ :file
+ :private-file
+ ))
+ (name nil :type (or symbol string))
+ (indent 0 :type (mod 1024)) ; Number of characters of indent in
+ ; verbose output to the user.
+ host ; The pathname host (i.e., "/../a").
+ device ; The pathname device.
+ source-root-dir ; Relative or absolute (starts
+ ; with "/"), directory or file
+ ; (ends with "/").
+ (source-pathname *source-pathname-default*)
+ source-extension ; A string, e.g., "lisp"
+ ; if NIL, inherit
+ (binary-pathname *binary-pathname-default*)
+ binary-root-dir
+ binary-extension ; A string, e.g., "fasl". If
+ ; NIL, uses default for
+ ; machine-type.
+ package ; Package for use-package.
+
+ ;; The following three slots are used to provide for alternate compilation
+ ;; and loading functions for the files contained within a component. If
+ ;; a component has a compiler or a loader specified, those functions are
+ ;; used. Otherwise the functions are derived from the language. If no
+ ;; language is specified, it defaults to Common Lisp (:lisp). Other current
+ ;; possible languages include :scheme (PseudoScheme) and :c, but the user
+ ;; can define additional language mappings. Compilation functions should
+ ;; accept a pathname argument and a :output-file keyword; loading functions
+ ;; just a pathname argument. The default functions are #'compile-file and
+ ;; #'load. Unlike fdmm's SET-LANGUAGE macro, this allows a defsystem to
+ ;; mix languages.
+ (language nil :type (or null symbol))
+ (compiler nil :type (or null symbol function))
+ (loader nil :type (or null symbol function))
+ (compiler-options nil :type list) ; A list of compiler options to
+ ; use for compiling this
+ ; component. These must be
+ ; keyword options supported by
+ ; the compiler.
+
+ (components () :type list) ; A list of components
+ ; comprising this component's
+ ; definition.
+ (depends-on () :type list) ; A list of the components
+ ; this one depends on. may
+ ; refer only to the components
+ ; at the same level as this
+ ; one.
+ proclamations ; Compiler options, such as
+ ; '(optimize (safety 3)).
+ initially-do ; Form to evaluate before the
+ ; operation.
+ finally-do ; Form to evaluate after the operation.
+ compile-form ; For foreign libraries.
+ load-form ; For foreign libraries.
+
+ ;; load-time ; The file-write-date of the
+ ; binary/source file loaded.
+
+ ;; If load-only is T, will not compile the file on operation :compile.
+ ;; In other words, for files which are :load-only T, loading the file
+ ;; satisfies any demand to recompile.
+ load-only ; If T, will not compile this
+ ; file on operation :compile.
+ ;; If compile-only is T, will not load the file on operation :compile.
+ ;; Either compiles or loads the file, but not both. In other words,
+ ;; compiling the file satisfies the demand to load it. This is useful
+ ;; for PCL defmethod and defclass definitions, which wrap a
+ ;; (eval-when (compile load eval) ...) around the body of the definition.
+ ;; This saves time in some lisps.
+ compile-only ; If T, will not load this
+ ; file on operation :compile.
+ #|| ISI Extension ||#
+ load-always ; If T, will force loading
+ ; even if file has not
+ ; changed.
+ ;; PVE: add banner
+ (banner nil :type (or null string))
+
+ (documentation nil :type (or null string)) ; Optional documentation slot
+ )
+
+
+;;; To allow dependencies from "foreign systems" like ASDF or one of
+;;; the proprietary ones like ACL or LW.
+
+(defstruct (foreign-system (:include component (type :system)))
+ kind ; This is a keyword: (member :asdf :pcl :lispworks-common-defsystem ...)
+ object ; The actual foreign system object.
+ )
+
+
+(defun register-foreign-system (name &key representation kind)
+ (declare (type (or symbol string) name))
+ (let ((fs (make-foreign-system :name name
+ :kind kind
+ :object representation)))
+ (setf (get-system name) fs)))
+
+
+
+(define-condition missing-component (simple-condition)
+ ((name :reader missing-component-name
+ :initarg :name)
+ (component :reader missing-component-component
+ :initarg :component)
+ )
+ (:default-initargs :component nil)
+ (:report (lambda (mmc stream)
+ (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
+ (missing-component-name mmc)
+ (missing-component-component mmc))))
+ )
+
+(define-condition missing-module (missing-component)
+ ()
+ (:report (lambda (mmc stream)
+ (format stream "MK:DEFSYSTEM: missing module ~S for ~S."
+ (missing-component-name mmc)
+ (missing-component-component mmc))))
+ )
+
+(define-condition missing-system (missing-module)
+ ()
+ (:report (lambda (msc stream)
+ (format stream "MK:DEFSYSTEM: missing system ~S~@[ for S~]."
+ (missing-component-name msc)
+ (missing-component-component msc))))
+ )
+
+
+
+(defvar *file-load-time-table* (make-hash-table :test #'equal)
+ "Hash table of file-write-dates for the system definitions and
+ files in the system definitions.")
+(defun component-load-time (component)
+ (when component
+ (etypecase component
+ (string (gethash component *file-load-time-table*))
+ (pathname (gethash (namestring component) *file-load-time-table*))
+ (component
+ (ecase (component-type component)
+ (:defsystem
+ (let* ((name (component-name component))
+ (path (when name (compute-system-path name nil))))
+ (declare (type (or string pathname null) path))
+ (when path
+ (gethash (namestring path) *file-load-time-table*))))
+ ((:file :private-file)
+ ;; Use only :source pathname to identify component's
+ ;; load time.
+ (let ((path (component-full-pathname component :source)))
+ (when path
+ (gethash path *file-load-time-table*)))))))))
+
+#-(or :cmu)
+(defsetf component-load-time (component) (value)
+ `(when ,component
+ (etypecase ,component
+ (string (setf (gethash ,component *file-load-time-table*) ,value))
+ (pathname (setf (gethash (namestring (the pathname ,component))
+ *file-load-time-table*)
+ ,value))
+ (component
+ (ecase (component-type ,component)
+ (:defsystem
+ (let* ((name (component-name ,component))
+ (path (when name (compute-system-path name nil))))
+ (declare (type (or string pathname null) path))
+ (when path
+ (setf (gethash (namestring path) *file-load-time-table*)
+ ,value))))
+ ((:file :private-file)
+ ;; Use only :source pathname to identify file.
+ (let ((path (component-full-pathname ,component :source)))
+ (when path
+ (setf (gethash path *file-load-time-table*)
+ ,value)))))))
+ ,value))
+
+#+(or :cmu)
+(defun (setf component-load-time) (value component)
+ (declare
+ (type (or null string pathname component) component)
+ (type (or unsigned-byte null) value))
+ (when component
+ (etypecase component
+ (string (setf (gethash component *file-load-time-table*) value))
+ (pathname (setf (gethash (namestring (the pathname component))
+ *file-load-time-table*)
+ value))
+ (component
+ (ecase (component-type component)
+ (:defsystem
+ (let* ((name (component-name component))
+ (path (when name (compute-system-path name nil))))
+ (declare (type (or string pathname null) path))
+ (when path
+ (setf (gethash (namestring path) *file-load-time-table*)
+ value))))
+ ((:file :private-file)
+ ;; Use only :source pathname to identify file.
+ (let ((path (component-full-pathname component :source)))
+ (when path
+ (setf (gethash path *file-load-time-table*)
+ value)))))))
+ value))
+
+
+;;; compute-system-path --
+
+(defun compute-system-path (module-name definition-pname)
+ (let* ((module-string-name
+ (etypecase module-name
+ (symbol (string-downcase
+ (string module-name)))
+ (string module-name)))
+
+ (file-pathname
+ (make-pathname :name module-string-name
+ :type *system-extension*))
+
+ (lib-file-pathname
+ (make-pathname :directory (list :relative module-string-name)
+ :name module-string-name
+ :type *system-extension*))
+ )
+ (or (when definition-pname ; given pathname for system def
+ (probe-file definition-pname))
+ ;; Then the central registry. Note that we also check the current
+ ;; directory in the registry, but the above check is hard-coded.
+ (cond (*central-registry*
+ (if (listp *central-registry*)
+ (dolist (registry *central-registry*)
+ (let ((file (or (probe-file
+ (append-directories (if (consp registry)
+ (eval registry)
+ registry)
+ file-pathname))
+ (probe-file
+ (append-directories (if (consp registry)
+ (eval registry)
+ registry)
+ lib-file-pathname))
+ ))
+ )
+ (when file (return file))))
+ (or (probe-file (append-directories *central-registry*
+ file-pathname))
+ (probe-file (append-directories *central-registry*
+ lib-file-pathname))
+ ))
+ )
+ (t
+ ;; No central registry. Assume current working directory.
+ ;; Maybe this should be an error?
+ (or (probe-file file-pathname)
+ (probe-file lib-file-pathname)))))
+ ))
+
+
+(defun system-definition-pathname (system-name)
+ (let ((system (ignore-errors (find-system system-name :error))))
+ (if system
+ (let ((system-def-pathname
+ (make-pathname :type "system"
+ :defaults (pathname (component-full-pathname system :source))))
+ )
+ (values system-def-pathname
+ (probe-file system-def-pathname)))
+ (values nil nil))))
+
+
+
+
+#|
+
+(defun compute-system-path (module-name definition-pname)
+ (let* ((filename (format nil "~A.~A"
+ (if (symbolp module-name)
+ (string-downcase (string module-name))
+ module-name)
+ *system-extension*)))
+ (or (when definition-pname ; given pathname for system def
+ (probe-file definition-pname))
+ ;; Then the central registry. Note that we also check the current
+ ;; directory in the registry, but the above check is hard-coded.
+ (cond (*central-registry*
+ (if (listp *central-registry*)
+ (dolist (registry *central-registry*)
+ (let ((file (probe-file
+ (append-directories (if (consp registry)
+ (eval registry)
+ registry)
+ filename))))
+ (when file (return file))))
+ (probe-file (append-directories *central-registry*
+ filename))))
+ (t
+ ;; No central registry. Assume current working directory.
+ ;; Maybe this should be an error?
+ (probe-file filename))))))
+|#
+
+
+(defvar *reload-systems-from-disk* t
+ "If T, always tries to reload newer system definitions from disk.
+ Otherwise first tries to find the system definition in the current
+ environment.")
+
+(defun find-system (system-name &optional (mode :ask) definition-pname)
+ "Returns the system named SYSTEM-NAME.
+If not already loaded, loads it, depending on the value of
+*RELOAD-SYSTEMS-FROM-DISK* and of the value of MODE. MODE can be :ASK,
+:ERROR, :LOAD-OR-NIL, or :LOAD. :ASK is the default.
+This allows OPERATE-ON-SYSTEM to work on non-loaded as well as
+loaded system definitions. DEFINITION-PNAME is the pathname for
+the system definition, if provided."
+ (ecase mode
+ (:ask
+ (or (get-system system-name)
+ (when (y-or-n-p-wait
+ #\y 20
+ "System ~A not loaded. Shall I try loading it? "
+ system-name)
+ (find-system system-name :load definition-pname))))
+ (:error
+ (or (get-system system-name)
+ (error 'missing-system :name system-name)))
+ (:load-or-nil
+ (let ((system (get-system system-name)))
+ (or (unless *reload-systems-from-disk* system)
+ ;; If SYSTEM-NAME is a symbol, it will lowercase the
+ ;; symbol's string.
+ ;; If SYSTEM-NAME is a string, it doesn't change the case of the
+ ;; string. So if case matters in the filename, use strings, not
+ ;; symbols, wherever the system is named.
+ (when (foreign-system-p system)
+ (warn "Foreing system ~S cannot be reloaded by MK:DEFSYSTEM.")
+ (return-from find-system nil))
+ (let ((path (compute-system-path system-name definition-pname)))
+ (when (and path
+ (or (null system)
+ (null (component-load-time path))
+ (< (component-load-time path)
+ (file-write-date path))))
+ (tell-user-generic
+ (format nil "Loading system ~A from file ~A"
+ system-name
+ path))
+ (load path)
+ (setf system (get-system system-name))
+ (when system
+ (setf (component-load-time path)
+ (file-write-date path))))
+ system)
+ system)))
+ (:load
+ (or (unless *reload-systems-from-disk* (get-system system-name))
+ (when (foreign-system-p (get-system system-name))
+ (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM.")
+ (return-from find-system nil))
+ (or (find-system system-name :load-or-nil definition-pname)
+ (error "Can't find system named ~s." system-name))))))
+
+
+(defun print-component (component stream depth)
+ (declare (ignore depth))
+ (format stream "#<~:@(~A~): ~A>"
+ (component-type component)
+ (component-name component)))
+
+
+(defun describe-system (name &optional (stream *standard-output*))
+ "Prints a description of the system to the stream. If NAME is the
+ name of a system, gets it and prints a description of the system.
+ If NAME is a component, prints a description of the component."
+ (let ((system (if (typep name 'component) name (find-system name :load))))
+ (format stream "~&~A ~A: ~
+ ~@[~& Host: ~A~]~
+ ~@[~& Device: ~A~]~
+ ~@[~& Package: ~A~]~
+ ~& Source: ~@[~A~] ~@[~A~] ~@[~A~]~
+ ~& Binary: ~@[~A~] ~@[~A~] ~@[~A~]~
+ ~@[~& Depends On: ~A ~]~& Components: ~{~15T~A~&~}"
+ (component-type system)
+ (component-name system)
+ (component-host system)
+ (component-device system)
+ (component-package system)
+ (component-root-dir system :source)
+ (component-pathname system :source)
+ (component-extension system :source)
+ (component-root-dir system :binary)
+ (component-pathname system :binary)
+ (component-extension system :binary)
+ (component-depends-on system)
+ (component-components system))
+ #||(when recursive
+ (dolist (component (component-components system))
+ (describe-system component stream recursive)))||#
+ system))
+
+(defun canonicalize-component-name (component)
+ ;; Within the component, the name is a string.
+ (if (typep (component-name component) 'string)
+ ;; Unnecessary to change it, so just return it, same case
+ (component-name component)
+ ;; Otherwise, make it a downcase string -- important since file
+ ;; names are often constructed from component names, and unix
+ ;; prefers lowercase as a default.
+ (setf (component-name component)
+ (string-downcase (string (component-name component))))))
+
+(defun component-pathname (component type)
+ (when component
+ (ecase type
+ (:source (component-source-pathname component))
+ (:binary (component-binary-pathname component))
+ (:error (component-error-pathname component)))))
+(defun component-error-pathname (component)
+ (let ((binary (component-pathname component :binary)))
+ (new-file-type binary *compile-error-file-type*)))
+(defsetf component-pathname (component type) (value)
+ `(when ,component
+ (ecase ,type
+ (:source (setf (component-source-pathname ,component) ,value))
+ (:binary (setf (component-binary-pathname ,component) ,value)))))
+
+(defun component-root-dir (component type)
+ (when component
+ (ecase type
+ (:source (component-source-root-dir component))
+ ((:binary :error) (component-binary-root-dir component))
+ )))
+(defsetf component-root-dir (component type) (value)
+ `(when ,component
+ (ecase ,type
+ (:source (setf (component-source-root-dir ,component) ,value))
+ (:binary (setf (component-binary-root-dir ,component) ,value)))))
+
+(defvar *source-pathnames-table* (make-hash-table :test #'equal)
+ "Table which maps from components to full source pathnames.")
+(defvar *binary-pathnames-table* (make-hash-table :test #'equal)
+ "Table which maps from components to full binary pathnames.")
+(defparameter *reset-full-pathname-table* t
+ "If T, clears the full-pathname tables before each call to
+ OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance
+ after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could
+ result in changes to system and language definitions to not take
+ effect, and so should be used with caution.")
+(defun clear-full-pathname-tables ()
+ (clrhash *source-pathnames-table*)
+ (clrhash *binary-pathnames-table*))
+
+(defun component-full-pathname (component type &optional (version *version*))
+ (when component
+ (case type
+ (:source
+ (let ((old (gethash component *source-pathnames-table*)))
+ (or old
+ (let ((new (component-full-pathname-i component type version)))
+ (setf (gethash component *source-pathnames-table*) new)
+ new))))
+ (:binary
+ (let ((old (gethash component *binary-pathnames-table*)))
+ (or old
+ (let ((new (component-full-pathname-i component type version)))
+ (setf (gethash component *binary-pathnames-table*) new)
+ new))))
+ (otherwise
+ (component-full-pathname-i component type version)))))
+
+(defun component-full-pathname-i (component type
+ &optional (version *version*)
+ &aux version-dir version-replace)
+ ;; If the pathname-type is :binary and the root pathname is null,
+ ;; distribute the binaries among the sources (= use :source pathname).
+ ;; This assumes that the component's :source pathname has been set
+ ;; before the :binary one.
+ (if version
+ (multiple-value-setq (version-dir version-replace)
+ (translate-version version))
+ (setq version-dir *version-dir* version-replace *version-replace*))
+ ;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace)
+ (let ((pathname
+ (append-directories
+ (if version-replace
+ version-dir
+ (append-directories (component-root-dir component type)
+ version-dir))
+ (component-pathname component type))))
+
+ ;; When a logical pathname is used, it must first be translated to
+ ;; a physical pathname. This isn't strictly correct. What should happen
+ ;; is we fill in the appropriate slots of the logical pathname, and
+ ;; then return the logical pathname for use by compile-file & friends.
+ ;; But calling translate-logical-pathname to return the actual pathname
+ ;; should do for now.
+
+ ;; (format t "pathname = ~A~%" pathname)
+ ;; (format t "type = ~S~%" (component-extension component type))
+
+ ;; 20000303 Marco Antoniotti
+ ;; Changed the following according to suggestion by Ray Toy. I
+ ;; just collapsed the tests for "logical-pathname-ness" into a
+ ;; single test (heavy, but probably very portable) and added the
+ ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES
+ ;; beacuse of possible null names (e.g. :defsystem components)
+ ;; causing problems with the subsequenct call to NAMESTRING.
+ ;; (format *trace-output* "~&>>>> PATHNAME is ~S~%" pathname)
+ (cond ((pathname-logical-p pathname) ; See definition of test above.
+ (setf pathname
+ (merge-pathnames pathname
+ (make-pathname
+ :name (component-name component)
+ :type (component-extension component
+ type))))
+ ;;(format t "new path = ~A~%" pathname)
+ (namestring (translate-logical-pathname pathname)))
+ (t
+ (namestring
+ (make-pathname :host (when (component-host component)
+ ;; MCL2.0b1 and ACLPC cause an error on
+ ;; (pathname-host nil)
+ (pathname-host (component-host component)
+ #+scl :case #+scl :common
+ ))
+ :directory (pathname-directory pathname
+ #+scl :case #+scl :common
+ )
+ ;; Use :directory instead of :defaults
+ :name (pathname-name pathname
+ #+scl :case #+scl :common
+ )
+ :type #-scl (component-extension component type)
+ #+scl (string-upcase
+ (component-extension component type))
+ :device
+ #+sbcl
+ :unspecific
+ #-(or :sbcl)
+ (let ((dev (component-device component)))
+ (if dev
+ (pathname-device dev
+ #+scl :case #+scl :common
+ )
+ (pathname-device pathname
+ #+scl :case #+scl :common
+ )))
+ ;; :version :newest
+ ))))))
+
+;;; What about CMU17 :device :unspecific in the above?
+
+#-lispworks
+(defun translate-version (version)
+ ;; Value returns the version directory and whether it replaces
+ ;; the entire root (t) or is a subdirectory.
+ ;; Version may be nil to signify no subdirectory,
+ ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
+ ;; specifies a subdirectory of the root, or
+ ;; a string, which replaces the root.
+ (cond ((null version)
+ (values "" nil))
+ ((symbolp version)
+ (values (let ((sversion (string version)))
+ (if (find-if #'lower-case-p sversion)
+ sversion
+ (string-downcase sversion)))
+ nil))
+ ((stringp version)
+ (values version t))
+ (t (error "~&; Illegal version ~S" version))))
+
+
+;;; Looks like LW has a bug in MERGE-PATHNAMES.
+;;;
+;;; (merge-pathnames "" "LP:foo;bar;") ==> "LP:"
+;;;
+;;; Which is incorrect.
+;;; The change here ensures that the result of TRANSLATE-VERSION is appropropriate.
+
+#+lispworks
+(defun translate-version (version)
+ ;; Value returns the version directory and whether it replaces
+ ;; the entire root (t) or is a subdirectory.
+ ;; Version may be nil to signify no subdirectory,
+ ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
+ ;; specifies a subdirectory of the root, or
+ ;; a string, which replaces the root.
+ (cond ((null version)
+ (values (pathname "") nil))
+ ((symbolp version)
+ (values (let ((sversion (string version)))
+ (if (find-if #'lower-case-p sversion)
+ (pathname sversion)
+ (pathname (string-downcase sversion))))
+ nil))
+ ((stringp version)
+ (values (pathname version) t))
+ (t (error "~&; Illegal version ~S" version))))
+
+
+
+
+(defun component-extension (component type &key local)
+ (ecase type
+ (:source (or (component-source-extension component)
+ (unless local
+ (default-source-extension component)) ; system default
+ ;; (and (component-language component))
+ ))
+ (:binary (or (component-binary-extension component)
+ (unless local
+ (default-binary-extension component)) ; system default
+ ;; (and (component-language component))
+ ))
+ (:error *compile-error-file-type*)))
+
+
+(defsetf component-extension (component type) (value)
+ `(ecase ,type
+ (:source (setf (component-source-extension ,component) ,value))
+ (:binary (setf (component-binary-extension ,component) ,value))
+ (:error (setf *compile-error-file-type* ,value))))
+
+;;; ********************************
+;;; System Definition **************
+;;; ********************************
+(defun create-component (type name definition-body &optional parent (indent 0))
+ (let ((component (apply #'make-component
+ :type type
+ :name name
+ :indent indent
+ definition-body)))
+ ;; Set up :load-only attribute
+ (unless (find :load-only definition-body)
+ ;; If the :load-only attribute wasn't specified,
+ ;; inherit it from the parent. If no parent, default it to nil.
+ (setf (component-load-only component)
+ (when parent
+ (component-load-only parent))))
+ ;; Set up :compile-only attribute
+ (unless (find :compile-only definition-body)
+ ;; If the :compile-only attribute wasn't specified,
+ ;; inherit it from the parent. If no parent, default it to nil.
+ (setf (component-compile-only component)
+ (when parent
+ (component-compile-only parent))))
+
+ ;; Set up :compiler-options attribute
+ (unless (find :compiler-options definition-body)
+ ;; If the :compiler-option attribute wasn't specified,
+ ;; inherit it from the parent. If no parent, default it to NIL.
+ (setf (component-compiler-options component)
+ (when parent
+ (component-compiler-options parent))))
+
+ #|| ISI Extension ||#
+ ;; Set up :load-always attribute
+ (unless (find :load-always definition-body)
+ ;; If the :load-always attribute wasn't specified,
+ ;; inherit it from the parent. If no parent, default it to nil.
+ (setf (component-load-always component)
+ (when parent
+ (component-load-always parent))))
+
+ ;; Initializations/after makes
+ (canonicalize-component-name component)
+
+ ;; Inherit package from parent if not specified.
+ (setf (component-package component)
+ (or (component-package component)
+ (when parent (component-package parent))))
+
+ ;; Type specific setup:
+ (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
+ (setf (get-system name) component)
+ #|(unless (component-language component)
+ (setf (component-language component) :lisp))|#)
+
+ ;; Set up the component's pathname
+ (create-component-pathnames component parent)
+
+ ;; If there are any components of the component, expand them too.
+ (expand-component-components component (+ indent 2))
+
+ ;; Make depends-on refer to structs instead of names.
+ (link-component-depends-on (component-components component))
+
+ ;; Design Decision: Topologically sort the dependency graph at
+ ;; time of definition instead of at time of use. Probably saves a
+ ;; little bit of time for the user.
+
+ ;; Topological Sort the components at this level.
+ (setf (component-components component)
+ (topological-sort (component-components component)))
+
+ ;; Return the component.
+ component))
+
+
+;;; defsystem --
+;;; The main macro.
+;;;
+;;; 2002-11-22 Marco Antoniotti
+;;; Added code to achieve a first cut "pathname less" operation,
+;;; following the ideas in ASDF. If the DEFSYSTEM form is loaded from
+;;; a file, then the location of the file (intended as a directory) is
+;;; computed from *LOAD-PATHNAME* and stored as the :SOURCE-PATHNAME
+;;; of the system.
+
+(defmacro defsystem (name &rest definition-body)
+ (unless (find :source-pathname definition-body)
+ (setf definition-body
+ (list* :source-pathname
+ '(when *load-pathname*
+ (make-pathname :name nil
+ :type nil
+ :defaults *load-pathname*))
+ definition-body)))
+ `(create-component :defsystem ',name ',definition-body nil 0))
+
+(defun create-component-pathnames (component parent)
+ ;; Set up language-specific defaults
+
+ (setf (component-language component)
+ (or (component-language component) ; for local defaulting
+ (when parent ; parent's default
+ (component-language parent))))
+
+ (setf (component-compiler component)
+ (or (component-compiler component) ; for local defaulting
+ (when parent ; parent's default
+ (component-compiler parent))))
+ (setf (component-loader component)
+ (or (component-loader component) ; for local defaulting
+ (when parent ; parent's default
+ (component-loader parent))))
+
+ ;; Evaluate the root dir arg
+ (setf (component-root-dir component :source)
+ (eval (component-root-dir component :source)))
+ (setf (component-root-dir component :binary)
+ (eval (component-root-dir component :binary)))
+
+ ;; Evaluate the pathname arg
+ (setf (component-pathname component :source)
+ (eval (component-pathname component :source)))
+ (setf (component-pathname component :binary)
+ (eval (component-pathname component :binary)))
+
+ ;; Pass along the host and devices
+ (setf (component-host component)
+ (or (component-host component)
+ (when parent (component-host parent))))
+ (setf (component-device component)
+ (or (component-device component)
+ (when parent (component-device parent))))
+
+ ;; Set up extension defaults
+ (setf (component-extension component :source)
+ (or (component-extension component :source
+ :local #| (component-language component) |#
+ t
+ ) ; local default
+ (when (component-language component)
+ (default-source-extension component))
+ (when parent ; parent's default
+ (component-extension parent :source))))
+ (setf (component-extension component :binary)
+ (or (component-extension component :binary
+ :local #| (component-language component) |#
+ t
+ ) ; local default
+ (when (component-language component)
+ (default-binary-extension component))
+ (when parent ; parent's default
+ (component-extension parent :binary))))
+
+ ;; Set up pathname defaults -- expand with parent
+ ;; We must set up the source pathname before the binary pathname
+ ;; to allow distribution of binaries among the sources to work.
+ (generate-component-pathname component parent :source)
+ (generate-component-pathname component parent :binary))
+
+
+;; maybe file's inheriting of pathnames should be moved elsewhere?
+(defun generate-component-pathname (component parent pathname-type)
+ ;; Pieces together a pathname for the component based on its component-type.
+ ;; Assumes source defined first.
+ ;; Null binary pathnames inherit from source instead of the component's
+ ;; name. This allows binaries to be distributed among the source if
+ ;; binary pathnames are not specified. Or if the root directory is
+ ;; specified for binaries, but no module directories, it inherits
+ ;; parallel directory structure.
+ (case (component-type component)
+ ((:defsystem :system) ; Absolute Pathname
+ ;; Set the root-dir to be the absolute pathname
+ (setf (component-root-dir component pathname-type)
+ (or (component-pathname component pathname-type)
+ (when (eq pathname-type :binary)
+ ;; When the binary root is nil, use source.
+ (component-root-dir component :source))) )
+ ;; Set the relative pathname to be nil
+ (setf (component-pathname component pathname-type)
+ nil));; should this be "" instead?
+ ;; If the name of the component-pathname is nil, it
+ ;; defaults to the name of the component. Use "" to
+ ;; avoid this defaulting.
+ (:private-file ; Absolute Pathname
+ ;; Root-dir is the directory part of the pathname
+ (setf (component-root-dir component pathname-type)
+ ""
+ #+ignore(or (when (component-pathname component pathname-type)
+ (pathname-directory
+ (component-pathname component pathname-type)))
+ (when (eq pathname-type :binary)
+ ;; When the binary root is nil, use source.
+ (component-root-dir component :source)))
+ )
+ ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
+ ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
+ ;; wind up being "", which is wrong for :file components. So replace
+ ;; them with NIL.
+ (when (null-string (component-pathname component pathname-type))
+ (setf (component-pathname component pathname-type) nil))
+ ;; The relative pathname is the name part
+ (setf (component-pathname component pathname-type)
+ (or (when (and (eq pathname-type :binary)
+ (null (component-pathname component :binary)))
+ ;; When the binary-pathname is nil use source.
+ (component-pathname component :source))
+ (or (when (component-pathname component pathname-type)
+; (pathname-name )
+ (component-pathname component pathname-type))
+ (component-name component)))))
+ ((:module :subsystem) ; Pathname relative to parent.
+ ;; Inherit root-dir from parent
+ (setf (component-root-dir component pathname-type)
+ (component-root-dir parent pathname-type))
+ ;; Tack the relative-dir onto the pathname
+ (setf (component-pathname component pathname-type)
+ (or (when (and (eq pathname-type :binary)
+ (null (component-pathname component :binary)))
+ ;; When the binary-pathname is nil use source.
+ (component-pathname component :source))
+ (append-directories
+ (component-pathname parent pathname-type)
+ (or (component-pathname component pathname-type)
+ (component-name component))))))
+ (:file ; Pathname relative to parent.
+ ;; Inherit root-dir from parent
+ (setf (component-root-dir component pathname-type)
+ (component-root-dir parent pathname-type))
+ ;; If *SOURCE-PATHNAME-DEFAULT* or *BINARY-PATHNAME-DEFAULT* is "",
+ ;; then COMPONENT-SOURCE-PATHNAME or COMPONENT-BINARY-PATHNAME could
+ ;; wind up being "", which is wrong for :file components. So replace
+ ;; them with NIL.
+ (when (null-string (component-pathname component pathname-type))
+ (setf (component-pathname component pathname-type) nil))
+ ;; Tack the relative-dir onto the pathname
+ (setf (component-pathname component pathname-type)
+ (or (append-directories
+ (component-pathname parent pathname-type)
+ (or (component-pathname component pathname-type)
+ (component-name component)
+ (when (eq pathname-type :binary)
+ ;; When the binary-pathname is nil use source.
+ (component-pathname component :source)))))))
+ ))
+
+#|| ;; old version
+(defun expand-component-components (component &optional (indent 0))
+ (let ((definitions (component-components component)))
+ (setf (component-components component)
+ (remove-if #'null
+ (mapcar #'(lambda (definition)
+ (expand-component-definition definition
+ component
+ indent))
+ definitions)))))
+||#
+;; new version
+(defun expand-component-components (component &optional (indent 0))
+ (let ((definitions (component-components component)))
+ (if (eq (car definitions) :serial)
+ (setf (component-components component)
+ (expand-serial-component-chain (cdr definitions)
+ component indent))
+ (setf (component-components component)
+ (expand-component-definitions definitions component indent)))))
+
+(defun expand-component-definitions (definitions parent &optional (indent 0))
+ (let ((components nil))
+ (dolist (definition definitions)
+ (let ((new (expand-component-definition definition parent indent)))
+ (when new (push new components))))
+ (nreverse components)))
+
+(defun expand-serial-component-chain (definitions parent &optional (indent 0))
+ (let ((previous nil)
+ (components nil))
+ (dolist (definition definitions)
+ (let ((new (expand-component-definition definition parent indent)))
+ (when new
+ ;; Make this component depend on the previous one. Since
+ ;; we don't know the form of the definition, we have to
+ ;; expand it first.
+ (when previous (pushnew previous (component-depends-on new)))
+ ;; The dependencies will be linked later, so we use the name
+ ;; instead of the actual component.
+ (setq previous (component-name new))
+ ;; Save the new component.
+ (push new components))))
+ ;; Return the list of expanded components, in appropriate order.
+ (nreverse components)))
+
+
+(defparameter *enable-straz-absolute-string-hack* nil
+ "Special hack requested by Steve Strassman, where the shorthand
+ that specifies a list of components as a list of strings also
+ recognizes absolute pathnames and treats them as files of type
+ :private-file instead of type :file. Defaults to NIL, because I
+ haven't tested this.")
+(defun absolute-file-namestring-p (string)
+ ;; If a FILE namestring starts with a slash, or is a logical pathname
+ ;; as implied by the existence of a colon in the filename, assume it
+ ;; represents an absolute pathname.
+ (or (find #\: string :test #'char=)
+ (and (not (null-string string))
+ (char= (char string 0) #\/))))
+
+(defun expand-component-definition (definition parent &optional (indent 0))
+ ;; Should do some checking for malformed definitions here.
+ (cond ((null definition) nil)
+ ((stringp definition)
+ ;; Strings are assumed to be of type :file
+ (if (and *enable-straz-absolute-string-hack*
+ (absolute-file-namestring-p definition))
+ ;; Special hack for Straz
+ (create-component :private-file definition nil parent indent)
+ ;; Normal behavior
+ (create-component :file definition nil parent indent)))
+ ((and (listp definition)
+ (not (member (car definition)
+ '(:defsystem :system :subsystem
+ :module :file :private-file))))
+ ;; Lists whose first element is not a component type
+ ;; are assumed to be of type :file
+ (create-component :file
+ (car definition)
+ (cdr definition)
+ parent
+ indent))
+ ((listp definition)
+ ;; Otherwise, it is (we hope) a normal form definition
+ (create-component (car definition) ; type
+ (cadr definition) ; name
+ (cddr definition) ; definition body
+ parent ; parent
+ indent) ; indent
+ )))
+
+(defun link-component-depends-on (components)
+ (dolist (component components)
+ (unless (and *system-dependencies-delayed*
+ (eq (component-type component) :defsystem))
+ (setf (component-depends-on component)
+ (mapcar #'(lambda (dependency)
+ (let ((parent (find (string dependency) components
+ :key #'component-name
+ :test #'string-equal)))
+ (cond (parent parent)
+ ;; make it more intelligent about the following
+ (t (warn "Dependency ~S of component ~S not found."
+ dependency component)))))
+
+ (component-depends-on component))))))
+
+;;; ********************************
+;;; Topological Sort the Graph *****
+;;; ********************************
+
+;;; New version of topological sort suggested by rs2. Even though
+;;; this version avoids the call to sort, in practice it isn't faster. It
+;;; does, however, eliminate the need to have a TIME slot in the
+;;; topological-sort-node defstruct.
+(defun topological-sort (list &aux (sorted-list nil))
+ (labels ((dfs-visit (znode)
+ (setf (topsort-color znode) :gray)
+ (unless (and *system-dependencies-delayed*
+ (eq (component-type znode) :system))
+ (dolist (child (component-depends-on znode))
+ (cond ((eq (topsort-color child) :white)
+ (dfs-visit child))
+ ((eq (topsort-color child) :gray)
+ (format t "~&Detected cycle containing ~A" child)))))
+ (setf (topsort-color znode) :black)
+ (push znode sorted-list)))
+ (dolist (znode list)
+ (setf (topsort-color znode) :white))
+ (dolist (znode list)
+ (when (eq (topsort-color znode) :white)
+ (dfs-visit znode)))
+ (nreverse sorted-list)))
+
+#||
+;;; Older version of topological sort.
+(defun topological-sort (list &aux (time 0))
+ ;; The algorithm works by calling depth-first-search to compute the
+ ;; blackening times for each vertex, and then sorts the vertices into
+ ;; reverse order by blackening time.
+ (labels ((dfs-visit (node)
+ (setf (topsort-color node) 'gray)
+ (unless (and *system-dependencies-delayed*
+ (eq (component-type node) :defsystem))
+ (dolist (child (component-depends-on node))
+ (cond ((eq (topsort-color child) 'white)
+ (dfs-visit child))
+ ((eq (topsort-color child) 'gray)
+ (format t "~&Detected cycle containing ~A" child)))))
+ (setf (topsort-color node) 'black)
+ (setf (topsort-time node) time)
+ (incf time)))
+ (dolist (node list)
+ (setf (topsort-color node) 'white))
+ (dolist (node list)
+ (when (eq (topsort-color node) 'white)
+ (dfs-visit node)))
+ (sort list #'< :key #'topsort-time)))
+||#
+
+;;; ********************************
+;;; Output to User *****************
+;;; ********************************
+;;; All output to the user is via the tell-user functions.
+
+(defun split-string (string &key (item #\space) (test #'char=))
+ ;; Splits the string into substrings at spaces.
+ (let ((len (length string))
+ (index 0) result)
+ (dotimes (i len
+ (progn (unless (= index len)
+ (push (subseq string index) result))
+ (reverse result)))
+ (when (funcall test (char string i) item)
+ (unless (= index i);; two spaces in a row
+ (push (subseq string index i) result))
+ (setf index (1+ i))))))
+
+;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it
+;; because of an AKCL bug.
+;; KGK suggests using an 8 instead, but 1 does nicely.
+(defun prompt-string (component)
+ (format nil "; ~:[~;TEST:~]~V,1 at T "
+ *oos-test*
+ (component-indent component)))
+
+#||
+(defun format-justified-string (prompt contents)
+ (format t (concatenate 'string
+ "~%"
+ prompt
+ "-~{~<~%" prompt " ~1,80:; ~A~>~^~}")
+ (split-string contents))
+ (finish-output *standard-output*))
+||#
+
+(defun format-justified-string (prompt contents &optional (width 80)
+ (stream *standard-output*))
+ (let ((prompt-length (+ 2 (length prompt))))
+ (cond ((< (+ prompt-length (length contents)) width)
+ (format stream "~%~A- ~A" prompt contents))
+ (t
+ (format stream "~%~A-" prompt)
+ (do* ((cursor prompt-length)
+ (contents (split-string contents) (cdr contents))
+ (content (car contents) (car contents))
+ (content-length (1+ (length content)) (1+ (length content))))
+ ((null contents))
+ (cond ((< (+ cursor content-length) width)
+ (incf cursor content-length)
+ (format stream " ~A" content))
+ (t
+ (setf cursor (+ prompt-length content-length))
+ (format stream "~%~A ~A" prompt content)))))))
+ (finish-output stream))
+
+(defun tell-user (what component &optional type no-dots force)
+ (when (or *oos-verbose* force)
+ (format-justified-string (prompt-string component)
+ (format nil "~A ~(~A~) ~@[\"~A\"~] ~:[~;...~]"
+ ;; To have better messages, wrap the following around the
+ ;; case statement:
+ ;;(if (find (component-type component)
+ ;; '(:defsystem :system :subsystem :module))
+ ;; "Checking"
+ ;; (case ...))
+ ;; This gets around the problem of DEFSYSTEM reporting
+ ;; that it's loading a module, when it eventually never
+ ;; loads any of the files of the module.
+ (case what
+ ((compile :compile)
+ (if (component-load-only component)
+ ;; If it is :load-only t, we're loading.
+ "Loading"
+ ;; Otherwise we're compiling.
+ "Compiling"))
+ ((load :load) "Loading")
+ (otherwise what))
+ (component-type component)
+ (or (when type
+ (component-full-pathname component type))
+ (component-name component))
+ (and *tell-user-when-done*
+ (not no-dots))))))
+
+(defun tell-user-done (component &optional force no-dots)
+ ;; test is no longer really used, but we're leaving it in.
+ (when (and *tell-user-when-done*
+ (or *oos-verbose* force))
+ (format t "~&~A~:[~;...~] Done."
+ (prompt-string component) (not no-dots))
+ (finish-output *standard-output*)))
+
+(defmacro with-tell-user ((what component &optional type no-dots force) &body body)
+ `(progn
+ (tell-user ,what ,component ,type ,no-dots ,force)
+ , at body
+ (tell-user-done ,component ,force ,no-dots)))
+
+(defun tell-user-no-files (component &optional force)
+ (when (or *oos-verbose* force)
+ (format-justified-string (prompt-string component)
+ (format nil "Source file ~A ~
+ ~:[and binary file ~A ~;~]not found, not loading."
+ (component-full-pathname component :source)
+ (or *load-source-if-no-binary* *load-source-instead-of-binary*)
+ (component-full-pathname component :binary)))))
+
+(defun tell-user-require-system (name parent)
+ (when *oos-verbose*
+ (format t "~&; ~:[~;TEST:~] - System ~A requires ~S"
+ *oos-test* (component-name parent) name)
+ (finish-output *standard-output*)))
+
+(defun tell-user-generic (string)
+ (when *oos-verbose*
+ (format t "~&; ~:[~;TEST:~] - ~A"
+ *oos-test* string)
+ (finish-output *standard-output*)))
+
+;;; ********************************
+;;; Y-OR-N-P-WAIT ******************
+;;; ********************************
+;;; Y-OR-N-P-WAIT is like Y-OR-N-P, but will timeout after a specified
+;;; number of seconds. I should really replace this with a call to
+;;; the Y-OR-N-P-WAIT defined in the query.cl package and include that
+;;; instead.
+
+(defparameter *use-timeouts* t
+ "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves
+ like Y-OR-N-P. This is provided for users whose lisps don't handle
+ read-char-no-hang properly.")
+
+(defparameter *clear-input-before-query* t
+ "If T, y-or-n-p-wait will clear the input before printing the prompt
+ and asking the user for input.")
+
+;;; The higher *sleep-amount* is, the less consing, but the lower the
+;;; responsiveness.
+(defparameter *sleep-amount* #-CMU 0.1 #+CMU 1.0
+ "Amount of time to sleep between checking query-io. In multiprocessing
+ Lisps, this allows other processes to continue while we busy-wait. If
+ 0, skips call to SLEEP.")
+
+(defun internal-real-time-in-seconds ()
+ (get-universal-time))
+
+(defun read-char-wait (&optional (timeout 20) input-stream
+ (eof-error-p t) eof-value
+ &aux peek)
+ (do ((start (internal-real-time-in-seconds)))
+ ((or (setq peek (listen input-stream))
+ (< (+ start timeout) (internal-real-time-in-seconds)))
+ (when peek
+ ;; was read-char-no-hang
+ (read-char input-stream eof-error-p eof-value)))
+ (unless (zerop *sleep-amount*)
+ (sleep *sleep-amount*))))
+
+;;; Lots of lisps, especially those that run on top of UNIX, do not get
+;;; their input one character at a time, but a whole line at a time because
+;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait
+;;; to not always work as expected.
+;;;
+;;; I wish lisp did all its own buffering (turning off UNIX input line
+;;; buffering by putting the UNIX into CBREAK mode). Of course, this means
+;;; that we lose input editing, but why can't the lisp implement this?
+
+(defun y-or-n-p-wait (&optional (default #\y) (timeout 20)
+ format-string &rest args)
+ "Y-OR-N-P-WAIT prints the message, if any, and reads characters from
+ *QUERY-IO* until the user enters y, Y or space as an affirmative, or either
+ n or N as a negative answer, or the timeout occurs. It asks again if
+ you enter any other characters."
+ (when *clear-input-before-query* (clear-input *query-io*))
+ (when format-string
+ (fresh-line *query-io*)
+ (apply #'format *query-io* format-string args)
+ ;; FINISH-OUTPUT needed for CMU and other places which don't handle
+ ;; output streams nicely. This prevents it from continuing and
+ ;; reading the query until the prompt has been printed.
+ (finish-output *query-io*))
+ (loop
+ (let* ((read-char (if *use-timeouts*
+ (read-char-wait timeout *query-io* nil nil)
+ (read-char *query-io*)))
+ (char (or read-char default)))
+ ;; We need to ignore #\newline because otherwise the bugs in
+ ;; clear-input will cause y-or-n-p-wait to print the "Type ..."
+ ;; message every time... *sigh*
+ ;; Anyway, we might want to use this to ignore whitespace once
+ ;; clear-input is fixed.
+ (unless (find char '(#\tab #\newline #\return))
+ (when (null read-char)
+ (format *query-io* "~@[~A~]" default)
+ (finish-output *query-io*))
+ (cond ((null char) (return t))
+ ((find char '(#\y #\Y #\space) :test #'char=) (return t))
+ ((find char '(#\n #\N) :test #'char=) (return nil))
+ (t
+ (when *clear-input-before-query* (clear-input *query-io*))
+ (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ")
+ (when format-string
+ (fresh-line *query-io*)
+ (apply #'format *query-io* format-string args))
+ (finish-output *query-io*)))))))
+
+#||
+(y-or-n-p-wait #\y 20 "What? ")
+(progn (format t "~&hi") (finish-output)
+ (y-or-n-p-wait #\y 10 "1? ")
+ (y-or-n-p-wait #\n 10 "2? "))
+||#
+;;; ********************************
+;;; Operate on System **************
+;;; ********************************
+;;; Operate-on-system
+;;; Operation is :compile, 'compile, :load or 'load
+;;; Force is :all or :new-source or :new-source-and-dependents or a list of
+;;; specific modules.
+;;; :all (or T) forces a recompilation of every file in the system
+;;; :new-source-and-dependents compiles only those files whose
+;;; sources have changed or who depend on recompiled files.
+;;; :new-source compiles only those files whose sources have changed
+;;; A list of modules means that only those modules and their
+;;; dependents are recompiled.
+;;; Test is T to print out what it would do without actually doing it.
+;;; Note: it automatically sets verbose to T if test is T.
+;;; Verbose is T to print out what it is doing (compiling, loading of
+;;; modules and files) as it does it.
+;;; Dribble should be the pathname of the dribble file if you want to
+;;; dribble the compilation.
+;;; Load-source-instead-of-binary is T to load .lisp instead of binary files.
+;;; Version may be nil to signify no subdirectory,
+;;; a symbol, such as alpha, beta, omega, :alpha, mark, which
+;;; specifies a subdirectory of the root, or
+;;; a string, which replaces the root.
+
+(defun operate-on-system (name operation
+ &key
+ force
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
+ (load-source-instead-of-binary
+ *load-source-instead-of-binary*)
+ (load-source-if-no-binary
+ *load-source-if-no-binary*)
+ (bother-user-if-no-binary
+ *bother-user-if-no-binary*)
+ (compile-during-load *compile-during-load*)
+ dribble
+ (minimal-load *minimal-load*)
+ (override-compilation-unit t)
+ )
+ (declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit))
+ (unwind-protect
+ ;; Protect the undribble.
+ (#+(or :cltl2 :ansi-cl) with-compilation-unit
+ #+(or :cltl2 :ansi-cl) (:override override-compilation-unit)
+ #-(or :cltl2 :ansi-cl) progn
+ (when *reset-full-pathname-table* (clear-full-pathname-tables))
+ (when dribble (dribble dribble))
+ (when test (setq verbose t))
+ (when (null force) ; defaults
+ (case operation
+ ((load :load) (setq force :all))
+ ((compile :compile) (setq force :new-source-and-dependents))
+ (t (setq force :all))))
+ ;; Some CL implementations have a variable called *compile-verbose*
+ ;; or *compile-file-verbose*.
+ (multiple-value-bind (*version-dir* *version-replace*)
+ (translate-version version)
+ ;; CL implementations may uniformly default this to nil
+ (let ((*load-verbose* #-common-lisp-controller t
+ #+common-lisp-controller nil) ; nil
+ #-(or MCL CMU CLISP ECL :sbcl lispworks scl)
+ (*compile-file-verbose* t) ; nil
+ #+common-lisp-controller
+ (*compile-print* nil)
+ #+(and common-lisp-controller cmu)
+ (ext:*compile-progress* nil)
+ #+(and common-lisp-controller cmu)
+ (ext:*require-verbose* nil)
+ #+(and common-lisp-controller cmu)
+ (ext:*gc-verbose* nil)
+
+ (*compile-verbose* #-common-lisp-controller t
+ #+common-lisp-controller nil) ; nil
+ (*version* version)
+ (*oos-verbose* verbose)
+ (*oos-test* test)
+ (*load-source-if-no-binary* load-source-if-no-binary)
+ (*compile-during-load* compile-during-load)
+ (*bother-user-if-no-binary* bother-user-if-no-binary)
+ (*load-source-instead-of-binary* load-source-instead-of-binary)
+ (*minimal-load* minimal-load)
+ (system (if (and (component-p name)
+ (member (component-type name) '(:system :defsystem :subsystem)))
+ name
+ (find-system name :load))))
+ #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl)
+ (declare (special *compile-verbose* #-MCL *compile-file-verbose*)
+ #-openmcl (ignore *compile-verbose*
+ #-MCL *compile-file-verbose*)
+ #-openmcl (optimize (inhibit-warnings 3)))
+ (unless (component-operation operation)
+ (error "Operation ~A undefined." operation))
+ (operate-on-component system operation force))))
+ (when dribble (dribble))))
+
+
+(defun compile-system (name &key force
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
+ (load-source-instead-of-binary
+ *load-source-instead-of-binary*)
+ (load-source-if-no-binary
+ *load-source-if-no-binary*)
+ (bother-user-if-no-binary
+ *bother-user-if-no-binary*)
+ (compile-during-load *compile-during-load*)
+ dribble
+ (minimal-load *minimal-load*))
+ ;; For users who are confused by OOS.
+ (operate-on-system
+ name :compile
+ :force force
+ :version version
+ :test test
+ :verbose verbose
+ :load-source-instead-of-binary load-source-instead-of-binary
+ :load-source-if-no-binary load-source-if-no-binary
+ :bother-user-if-no-binary bother-user-if-no-binary
+ :compile-during-load compile-during-load
+ :dribble dribble
+ :minimal-load minimal-load))
+
+(defun load-system (name &key force
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
+ (load-source-instead-of-binary
+ *load-source-instead-of-binary*)
+ (load-source-if-no-binary *load-source-if-no-binary*)
+ (bother-user-if-no-binary *bother-user-if-no-binary*)
+ (compile-during-load *compile-during-load*)
+ dribble
+ (minimal-load *minimal-load*))
+ ;; For users who are confused by OOS.
+ (operate-on-system
+ name :load
+ :force force
+ :version version
+ :test test
+ :verbose verbose
+ :load-source-instead-of-binary load-source-instead-of-binary
+ :load-source-if-no-binary load-source-if-no-binary
+ :bother-user-if-no-binary bother-user-if-no-binary
+ :compile-during-load compile-during-load
+ :dribble dribble
+ :minimal-load minimal-load))
+
+(defun clean-system (name &key (force :all)
+ (version *version*)
+ (test *oos-test*) (verbose *oos-verbose*)
+ dribble)
+ "Deletes all the binaries in the system."
+ ;; For users who are confused by OOS.
+ (operate-on-system
+ name :delete-binaries
+ :force force
+ :version version
+ :test test
+ :verbose verbose
+ :dribble dribble))
+
+(defun edit-system
+ (name &key force
+ (version *version*)
+ (test *oos-test*)
+ (verbose *oos-verbose*)
+ dribble)
+
+ (operate-on-system
+ name :edit
+ :force force
+ :version version
+ :test test
+ :verbose verbose
+ :dribble dribble))
+
+(defun hardcopy-system
+ (name &key force
+ (version *version*)
+ (test *oos-test*)
+ (verbose *oos-verbose*)
+ dribble)
+
+ (operate-on-system
+ name :hardcopy
+ :force force
+ :version version
+ :test test
+ :verbose verbose
+ :dribble dribble))
+
+(defun operate-on-component (component operation force &aux changed)
+ ;; Returns T if something changed and had to be compiled.
+ (let ((type (component-type component))
+ (old-package (package-name *package*)))
+
+ (unwind-protect
+ ;; Protect old-package.
+ (progn
+ ;; Use the correct package.
+ (when (component-package component)
+ (tell-user-generic (format nil "Using package ~A"
+ (component-package component)))
+ (unless *oos-test*
+ (unless (find-package (component-package component))
+ ;; If the package name is the same as the name of the system,
+ ;; and the package is not defined, this would lead to an
+ ;; infinite loop, so bomb out with an error.
+ (when (string-equal (string (component-package component))
+ (component-name component))
+ (format t "~%Component ~A not loaded:~%"
+ (component-name component))
+ (error " Package ~A is not defined"
+ (component-package component)))
+ ;; If package not found, try using REQUIRE to load it.
+ (new-require (component-package component)))
+ ;; This was USE-PACKAGE, but should be IN-PACKAGE.
+ ;; Actually, CLtL2 lisps define in-package as a macro,
+ ;; so we'll set the package manually.
+ ;; (in-package (component-package component))
+ (let ((package (find-package (component-package component))))
+ (when package
+ (setf *package* package)))))
+ #+mk-original
+ (when (eq type :defsystem) ; maybe :system too?
+ (operate-on-system-dependencies component operation force))
+ (when (or (eq type :defsystem) (eq type :system))
+ (operate-on-system-dependencies component operation force))
+
+ ;; Do any compiler proclamations
+ (when (component-proclamations component)
+ (tell-user-generic (format nil "Doing proclamations for ~A"
+ (component-name component)))
+ (or *oos-test*
+ (proclaim (component-proclamations component))))
+
+ ;; Do any initial actions
+ (when (component-initially-do component)
+ (tell-user-generic (format nil "Doing initializations for ~A"
+ (component-name component)))
+ (or *oos-test*
+ (eval (component-initially-do component))))
+
+ ;; If operation is :compile and load-only is T, this would change
+ ;; the operation to load. Only, this would mean that a module would
+ ;; be considered to have changed if it was :load-only and had to be
+ ;; loaded, and then dependents would be recompiled -- this doesn't
+ ;; seem right. So instead, we propagate the :load-only attribute
+ ;; to the components, and modify compile-file-operation so that
+ ;; it won't compile the files (and modify tell-user to say "Loading"
+ ;; instead of "Compiling" for load-only modules).
+ #||
+ (when (and (find operation '(:compile compile))
+ (component-load-only component))
+ (setf operation :load))
+ ||#
+
+ ;; Do operation and set changed flag if necessary.
+ (setq changed
+ (case type
+ ((:file :private-file)
+ (funcall (component-operation operation) component force))
+ ((:module :system :subsystem :defsystem)
+ (operate-on-components component operation force changed))))
+
+ ;; Do any final actions
+ (when (component-finally-do component)
+ (tell-user-generic (format nil "Doing finalizations for ~A"
+ (component-name component)))
+ (or *oos-test*
+ (eval (component-finally-do component))))
+
+ ;; add the banner if needed
+ #+(or cmu scl)
+ (when (component-banner component)
+ (unless (stringp (component-banner component))
+ (error "The banner should be a string, it is: ~S"
+ (component-banner component)))
+ (setf (getf ext:*herald-items*
+ (intern (string-upcase (component-name component))
+ (find-package :keyword)))
+ (list
+ (component-banner component)))))
+
+ ;; Reset the package. (Cleanup form of unwind-protect.)
+ ;;(in-package old-package)
+ (setf *package* (find-package old-package)))
+
+ ;; Provide the loaded system
+ (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
+ (tell-user-generic (format nil "Providing system ~A~%"
+ (component-name component)))
+ (or *oos-test*
+ (provide (canonicalize-system-name (component-name component))))))
+
+ ;; Return non-NIL if something changed in this component and hence had
+ ;; to be recompiled. This is only used as a boolean.
+ changed)
+
+(defvar *force* nil)
+(defvar *providing-blocks-load-propagation* t
+ "If T, if a system dependency exists on *modules*, it is not loaded.")
+
+(defun operate-on-system-dependencies (component operation &optional force)
+ (when *system-dependencies-delayed*
+ (let ((*force* force))
+ (dolist (system (component-depends-on component))
+ ;; For each system that this system depends on, if it is a
+ ;; defined system (either via defsystem or component type :system),
+ ;; and propagation is turned on, propagates the operation to the
+ ;; subsystem. Otherwise runs require (my version) on that system
+ ;; to load it (needed since we may be depending on a lisp
+ ;; dependent package).
+ ;; Explores the system tree in a DFS manner.
+ (cond ((and *operations-propagate-to-subsystems*
+ (not (listp system))
+ ;; The subsystem is a defined system.
+ (find-system system :load-or-nil))
+ ;; Call OOS on it. Since *system-dependencies-delayed* is
+ ;; T, the :depends-on slot is filled with the names of
+ ;; systems, not defstructs.
+ ;; Aside from system, operation, force, for everything else
+ ;; we rely on the globals.
+ (unless (and *providing-blocks-load-propagation*
+ ;; If *providing-blocks-load-propagation* is T,
+ ;; the system dependency must not exist in the
+ ;; *modules* for it to be loaded. Note that
+ ;; the dependencies are implicitly systems.
+ (find operation '(load :load))
+ ;; (or (eq force :all) (eq force t))
+ (find (canonicalize-system-name system)
+ *modules* :test #'string-equal))
+
+ (operate-on-system system operation :force force)))
+
+ ((listp system)
+ ;; If the SYSTEM is a list then its contents are as follows.
+ ;;
+ ;; (<name> <definition-pathname> <action> <version>)
+ ;;
+ (tell-user-require-system
+ (cond ((and (null (first system)) (null (second system)))
+ (third system))
+ (t system))
+ component)
+ (or *oos-test* (new-require (first system)
+ nil
+ (eval (second system))
+ (third system)
+ (or (fourth system)
+ *version*))))
+ (t
+ (tell-user-require-system system component)
+ (or *oos-test* (new-require system))))))))
+
+;;; Modules can depend only on siblings. If a module should depend
+;;; on an uncle, then the parent module should depend on that uncle
+;;; instead. Likewise a module should depend on a sibling, not a niece
+;;; or nephew. Modules also cannot depend on cousins. Modules cannot
+;;; depend on parents, since that is circular.
+
+(defun module-depends-on-changed (module changed)
+ (dolist (dependent (component-depends-on module))
+ (when (member dependent changed)
+ (return t))))
+
+(defun operate-on-components (component operation force changed)
+ (with-tell-user (operation component)
+ (if (component-components component)
+ (dolist (module (component-components component))
+ (when (operate-on-component module operation
+ (cond ((and (module-depends-on-changed module changed)
+ #||(some #'(lambda (dependent)
+ (member dependent changed))
+ (component-depends-on module))||#
+ (or (non-empty-listp force)
+ (eq force :new-source-and-dependents)))
+ ;; The component depends on a changed file
+ ;; and force agrees.
+ (if (eq force :new-source-and-dependents)
+ :new-source-all
+ :all))
+ ((and (non-empty-listp force)
+ (member (component-name module) force
+ :test #'string-equal :key #'string))
+ ;; Force is a list of modules
+ ;; and the component is one of them.
+ :all)
+ (t force)))
+ (push module changed)))
+ (case operation
+ ((compile :compile)
+ (eval (component-compile-form component)))
+ ((load :load)
+ (eval (component-load-form component))))))
+ ;; This is only used as a boolean.
+ changed)
+
+;;; ********************************
+;;; New Require ********************
+;;; ********************************
+
+;;; This needs cleaning. Obviously the code is a left over from the
+;;; time people did not know how to use packages in a proper way or
+;;; CLs were shaky in their implementation.
+
+;;; First of all we need this. (Commented out for the time being)
+;;; (shadow '(cl:require))
+
+
+(defvar *old-require* nil)
+
+;;; All calls to require in this file have been replaced with calls
+;;; to new-require to avoid compiler warnings and make this less of
+;;; a tangled mess.
+
+(defun new-require (module-name
+ &optional
+ pathname
+ definition-pname
+ default-action
+ (version *version*))
+ ;; If the pathname is present, this behaves like the old require.
+ (unless (and module-name
+ (find (string module-name)
+ *modules* :test #'string=))
+ (handler-case
+ (cond (pathname
+ (funcall *old-require* module-name pathname))
+ ;; If the system is defined, load it.
+ ((find-system module-name :load-or-nil definition-pname)
+ (operate-on-system
+ module-name :load
+ :force *force*
+ :version version
+ :test *oos-test*
+ :verbose *oos-verbose*
+ :load-source-if-no-binary *load-source-if-no-binary*
+ :bother-user-if-no-binary *bother-user-if-no-binary*
+ :compile-during-load *compile-during-load*
+ :load-source-instead-of-binary *load-source-instead-of-binary*
+ :minimal-load *minimal-load*))
+ ;; If there's a default action, do it. This could be a progn which
+ ;; loads a file that does everything.
+ ((and default-action
+ (eval default-action)))
+ ;; If no system definition file, try regular require.
+ ;; had last arg PATHNAME, but this wasn't really necessary.
+ ((funcall *old-require* module-name))
+ ;; If no default action, print a warning or error message.
+ (t
+ #||
+ (format t "~&Warning: System ~A doesn't seem to be defined..."
+ module-name)
+ ||#
+ (error 'missing-system :name module-name)))
+ (missing-module (mmc) (signal mmc)) ; Resignal.
+ (error (e)
+ (declare (ignore e))
+ ;; Signal a (maybe wrong) MISSING-SYSTEM.
+ (error 'missing-system :name module-name)))
+ ))
+
+
+;;; Note that in some lisps, when the compiler sees a REQUIRE form at
+;;; top level it immediately executes it. This is as if an
+;;; (eval-when (compile load eval) ...) were wrapped around the REQUIRE
+;;; form. I don't see any easy way to do this without making REQUIRE
+;;; a macro.
+;;;
+;;; For example, in VAXLisp, if a (require 'streams) form is at the top of
+;;; a file in the system, compiling the system doesn't wind up loading the
+;;; streams module. If the (require 'streams) form is included within an
+;;; (eval-when (compile load eval) ...) then everything is OK.
+;;;
+;;; So perhaps we should replace the redefinition of lisp:require
+;;; with the following macro definition:
+#||
+(unless *old-require*
+ (setf *old-require*
+ (symbol-function #-(or :lispworks
+ :sbcl
+ (and :excl :allegro-v4.0)) 'lisp:require
+ #+:sbcl 'cl:require
+ #+:lispworks 'system:::require
+ #+(and :excl :allegro-v4.0) 'cltl1:require))
+
+ (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil))
+ ;; Note that lots of lisps barf if we redefine a function from
+ ;; the LISP package. So what we do is define a macro with an
+ ;; unused name, and use (setf macro-function) to redefine
+ ;; lisp:require without compiler warnings. If the lisp doesn't
+ ;; do the right thing, try just replacing require-as-macro
+ ;; with lisp:require.
+ (defmacro require-as-macro (module-name
+ &optional pathname definition-pname
+ default-action (version '*version*))
+ `(eval-when (compile load eval)
+ (new-require ,module-name ,pathname ,definition-pname
+ ,default-action ,version)))
+ (setf (macro-function #-(and :excl :sbcl :allegro-v4.0) 'lisp:require
+ #+:sbcl 'cl:require
+ #+(and :excl :allegro-v4.0) 'cltl1:require)
+ (macro-function 'require-as-macro))))
+||#
+;;; This will almost certainly fix the problem, but will cause problems
+;;; if anybody does a funcall on #'require.
+
+;;; Redefine old require to call the new require.
+(eval-when #-(or :lucid) (:load-toplevel :execute)
+ #+(or :lucid) (load eval)
+(unless *old-require*
+ (setf *old-require*
+ (symbol-function
+ #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
+ #+(and :excl :allegro-v4.0) 'cltl1:require
+ #+:sbcl 'cl:require
+ #+:lispworks3.1 'common-lisp::require
+ #+(and :lispworks (not :lispworks3.1)) 'system::require
+ #+:openmcl 'cl:require
+ #+(and :mcl (not :openmcl)) 'ccl:require
+ ))
+
+ (unless *dont-redefine-require*
+ (let (#+(or :mcl (and :CCL (not :lispworks)))
+ (ccl:*warn-if-redefine-kernel* nil))
+ #-(or (and allegro-version>= (version>= 4 1)) :lispworks)
+ (setf (symbol-function
+ #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
+ #+(and :excl :allegro-v4.0) 'cltl1:require
+ #+:lispworks3.1 'common-lisp::require
+ #+:sbcl 'cl:require
+ #+(and :lispworks (not :lispworks3.1)) 'system::require
+ #+:openmcl 'cl:require
+ #+(and :mcl (not :openmcl)) 'ccl:require
+ )
+ (symbol-function 'new-require))
+ #+:lispworks
+ (let ((warn-packs system::*packages-for-warn-on-redefinition*))
+ (declare (special system::*packages-for-warn-on-redefinition*))
+ (setq system::*packages-for-warn-on-redefinition* nil)
+ (setf (symbol-function
+ #+:lispworks3.1 'common-lisp::require
+ #-:lispworks3.1 'system::require
+ )
+ (symbol-function 'new-require))
+ (setq system::*packages-for-warn-on-redefinition* warn-packs))
+ #+(and allegro-version>= (version>= 4 1))
+ (excl:without-package-locks
+ (setf (symbol-function 'lisp:require)
+ (symbol-function 'new-require))))))
+)
+
+;;; ********************************
+;;; Language-Dependent Characteristics
+;;; ********************************
+;;; This section is used for defining language-specific behavior of
+;;; defsystem. If the user changes a language definition, it should
+;;; take effect immediately -- they shouldn't have to reload the
+;;; system definition file for the changes to take effect.
+
+(defvar *language-table* (make-hash-table :test #'equal)
+ "Hash table that maps from languages to language structures.")
+(defun find-language (name)
+ (gethash name *language-table*))
+
+(defstruct (language (:print-function print-language))
+ name ; The name of the language (a keyword)
+ compiler ; The function used to compile files in the language
+ loader ; The function used to load files in the language
+ source-extension ; Filename extensions for source files
+ binary-extension ; Filename extensions for binary files
+)
+
+(defun print-language (language stream depth)
+ (declare (ignore depth))
+ (format stream "#<~:@(~A~): ~A ~A>"
+ (language-name language)
+ (language-source-extension language)
+ (language-binary-extension language)))
+
+(defun compile-function (component)
+ (or (component-compiler component)
+ (let ((language (find-language (or (component-language component)
+ :lisp))))
+ (when language (language-compiler language)))
+ #'compile-file))
+
+(defun load-function (component)
+ (or (component-loader component)
+ (let ((language (find-language (or (component-language component)
+ :lisp))))
+ (when language (language-loader language)))
+ #'load))
+
+(defun default-source-extension (component)
+ (let ((language (find-language (or (component-language component)
+ :lisp))))
+ (or (when language (language-source-extension language))
+ (car *filename-extensions*))))
+
+(defun default-binary-extension (component)
+ (let ((language (find-language (or (component-language component)
+ :lisp))))
+ (or (when language (language-binary-extension language))
+ (cdr *filename-extensions*))))
+
+(defmacro define-language (name &key compiler loader
+ source-extension binary-extension)
+ (let ((language (gensym "LANGUAGE")))
+ `(let ((,language (make-language :name ,name
+ :compiler ,compiler
+ :loader ,loader
+ :source-extension ,source-extension
+ :binary-extension ,binary-extension)))
+ (setf (gethash ,name *language-table*) ,language)
+ ,name)))
+
+#||
+;;; Test System for verifying multi-language capabilities.
+(defsystem foo
+ :language :lisp
+ :components ((:module c :language :c :components ("foo" "bar"))
+ (:module lisp :components ("baz" "barf"))))
+
+||#
+
+;;; *** Lisp Language Definition
+(define-language :lisp
+ :compiler #'compile-file
+ :loader #'load
+ :source-extension (car *filename-extensions*)
+ :binary-extension (cdr *filename-extensions*))
+
+;;; *** PseudoScheme Language Definition
+(defun scheme-compile-file (filename &rest args)
+ (let ((scheme-package (find-package '#:scheme)))
+ (apply (symbol-function (find-symbol (symbol-name 'compile-file)
+ scheme-package))
+ filename
+ (funcall (symbol-function
+ (find-symbol (symbol-name '#:interaction-environment)
+ scheme-package)))
+ args)))
+
+(define-language :scheme
+ :compiler #'scheme-compile-file
+ :loader #'load
+ :source-extension "scm"
+ :binary-extension "bin")
+
+;;; *** C Language Definition
+
+;;; This is very basic. Somebody else who needs it can add in support
+;;; for header files, libraries, different C compilers, etc. For example,
+;;; we might add a COMPILER-OPTIONS slot to the component defstruct.
+
+(defparameter *c-compiler* "gcc")
+#-(or symbolics (and :lispworks :harlequin-pc-lisp ))
+
+(defun run-unix-program (program arguments)
+ ;; arguments should be a list of strings, where each element is a
+ ;; command-line option to send to the program.
+ #+:lucid (run-program program :arguments arguments)
+ #+:allegro (excl:run-shell-command
+ (format nil "~A~@[ ~{~A~^ ~}~]"
+ program arguments))
+ #+(or :kcl :ecl) (system (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
+ #+(or :cmu :scl) (extensions:run-program program arguments)
+ #+:openmcl (ccl:run-program program arguments)
+ #+:sbcl (sb-ext:run-program program arguments)
+ #+:lispworks (foreign:call-system-showing-output
+ (format nil "~A~@[ ~{~A~^ ~}~]" program arguments))
+ #+clisp (#+lisp=cl ext:run-program #-lisp=cl lisp:run-program
+ program :arguments arguments)
+ )
+
+#+(or symbolics (and :lispworks :harlequin-pc-lisp))
+(defun run-unix-program (program arguments)
+ (declare (ignore program arguments))
+ (error "MK::RUN-UNIX-PROGRAM: this does not seem to be a UN*X system.")
+ )
+
+#||
+(defun c-compile-file (filename &rest args &key output-file error-file)
+ ;; gcc -c foo.c -o foo.o
+ (declare (ignore args))
+ (run-unix-program *c-compiler*
+ (format nil "-c ~A~@[ -o ~A~]"
+ filename
+ output-file)))
+||#
+
+#||
+(defun c-compile-file (filename &rest args &key output-file error-file)
+ ;; gcc -c foo.c -o foo.o
+ (declare (ignore args error-file))
+ (run-unix-program *c-compiler*
+ `("-c" ,filename ,@(if output-file `("-o" ,output-file)))))
+||#
+
+
+;;; The following code was inserted to improve C compiler support (at
+;;; least under Linux/GCC).
+;;; Thanks to Espen S Johnsen.
+;;;
+;;; 20001118 Marco Antoniotti.
+
+(defun default-output-pathname (path1 path2 type)
+ (if (eq path1 t)
+ (translate-logical-pathname
+ (merge-pathnames (make-pathname :type type) (pathname path2)))
+ (translate-logical-pathname (pathname path1))))
+
+
+(defun run-compiler (program
+ arguments
+ output-file
+ error-file
+ error-output
+ verbose)
+ #-(or cmu scl) (declare (ignore error-file error-output))
+
+ (flet ((make-useable-stream (&rest streams)
+ (apply #'make-broadcast-stream (delete nil streams)))
+ )
+ (let (#+(or cmu scl) (error-file error-file)
+ #+(or cmu scl) (error-file-stream nil)
+ (verbose-stream nil)
+ (old-timestamp (file-write-date output-file))
+ (fatal-error nil)
+ (output-file-written nil)
+ )
+ (unwind-protect
+ (progn
+ #+(or cmu scl)
+ (setf error-file
+ (when error-file
+ (default-output-pathname error-file
+ output-file
+ *compile-error-file-type*))
+
+ error-file-stream
+ (and error-file
+ (open error-file
+ :direction :output
+ :if-exists :supersede)))
+
+ (setf verbose-stream
+ (make-useable-stream
+ #+cmu error-file-stream
+ (and verbose *trace-output*)))
+
+ (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%"
+ program
+ arguments)
+
+ (setf fatal-error
+ #-(or cmu scl)
+ (and (run-unix-program program arguments) nil) ; Incomplete.
+ #+(or cmu scl)
+ (let* ((error-output
+ (make-useable-stream error-file-stream
+ (if (eq error-output t)
+ *error-output*
+ error-output)))
+ (process
+ (ext:run-program program arguments
+ :error error-output)))
+ (not (zerop (ext:process-exit-code process)))))
+
+ (setf output-file-written
+ (and (probe-file output-file)
+ (not (eql old-timestamp
+ (file-write-date output-file)))))
+
+
+ (when output-file-written
+ (format verbose-stream "~A written~%" output-file))
+ (format verbose-stream "Running of ~A finished~%"
+ program)
+ (values (and output-file-written output-file)
+ fatal-error
+ fatal-error))
+
+ #+(or cmu scl)
+ (when error-file
+ (close error-file-stream)
+ (unless (or fatal-error (not output-file-written))
+ (delete-file error-file)))
+
+ (values (and output-file-written output-file)
+ fatal-error
+ fatal-error)))))
+
+
+;;; C Language definitions.
+
+(defun c-compile-file (filename &rest args
+ &key
+ (output-file t)
+ (error-file t)
+ (error-output t)
+ (verbose *compile-verbose*)
+ debug
+ link
+ optimize
+ cflags
+ definitions
+ include-paths
+ library-paths
+ libraries
+ (error t))
+ (declare (ignore args))
+
+ (flet ((map-options (flag options &optional (func #'identity))
+ (mapcar #'(lambda (option)
+ (format nil "~A~A" flag (funcall func option)))
+ options))
+ )
+ (let* ((output-file (default-output-pathname output-file filename "o"))
+ (arguments
+ `(,@(when (not link) '("-c"))
+ ,@(when debug '("-g"))
+ ,@(when optimize (list (format nil "-O~D" optimize)))
+ , at cflags
+ ,@(map-options
+ "-D" definitions
+ #'(lambda (definition)
+ (if (atom definition)
+ definition
+ (apply #'format nil "~A=~A" definition))))
+ ,@(map-options "-I" include-paths #'truename)
+ ,(namestring (truename filename))
+ "-o"
+ ,(namestring (translate-logical-pathname output-file))
+ ,@(map-options "-L" library-paths #'truename)
+ ,@(map-options "-l" libraries))))
+
+ (multiple-value-bind (output-file warnings fatal-errors)
+ (run-compiler *c-compiler*
+ arguments
+ output-file
+ error-file
+ error-output
+ verbose)
+ (if (and error (or (not output-file) fatal-errors))
+ (error "Compilation failed")
+ (values output-file warnings fatal-errors))))))
+
+
+(define-language :c
+ :compiler #'c-compile-file
+ :loader #+:lucid #'load-foreign-files
+ #+:allegro #'load
+ #+(or :cmu :scl) #'alien:load-foreign
+ #+:sbcl #'sb-alien:load-foreign
+ #+(and :lispworks :unix (not :linux)) #'link-load:read-foreign-modules
+ #+(and :lispworks (or (not :unix) :linux)) #'fli:register-module
+ #+(or :ecl :gcl :kcl) #'load ; should be enough.
+ #-(or :lucid
+ :allegro
+ :cmu
+ :sbcl
+ :scl
+ :lispworks
+ :ecl :gcl :kcl)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (cerror "Continue returning NIL."
+ "Loader not defined for C foreign libraries in ~A ~A."
+ (lisp-implementation-type)
+ (lisp-implementation-version)))
+ :source-extension "c"
+ :binary-extension "o")
+
+
+;;; Fortran Language definitions.
+;;; From Matlisp.
+
+(export '(*fortran-compiler* *fortran-options*))
+
+(defparameter *fortran-compiler* "g77")
+(defparameter *fortran-options* '("-O"))
+
+(defun fortran-compile-file (filename &rest args
+ &key output-file error-file
+ &allow-other-keys)
+ (declare (ignore error-file args))
+ (let ((arg-list
+ (append *fortran-options*
+ `("-c" ,filename ,@(if output-file `("-o" ,output-file))))))
+ (run-unix-program *fortran-compiler* arg-list)))
+
+
+(mk:define-language :fortran
+ :compiler #'fortran-compile-file
+ :loader #'identity
+ :source-extension "f"
+ :binary-extension "o")
+
+
+;;; AR support.
+;; How to create a library (archive) of object files
+
+(export '(*ar-program* build-lib))
+
+(defparameter *ar-program* "ar")
+
+(defun build-lib (libname directory)
+ (let ((args (list "rv" (truename libname))))
+ (format t ";;; Building archive ~A~%" libname)
+ (run-unix-program *ar-program*
+ (append args
+ (mapcar #'truename (directory directory))))))
+
+
+;;; ********************************
+;;; Component Operations ***********
+;;; ********************************
+;;; Define :compile/compile and :load/load operations
+(eval-when (load eval)
+(component-operation :compile 'compile-and-load-operation)
+(component-operation 'compile 'compile-and-load-operation)
+(component-operation :load 'load-file-operation)
+(component-operation 'load 'load-file-operation)
+)
+
+(defun compile-and-load-operation (component force)
+ ;; FORCE was CHANGED. this caused defsystem during compilation to only
+ ;; load files that it immediately compiled.
+ (let ((changed (compile-file-operation component force)))
+ ;; Return T if the file had to be recompiled and reloaded.
+ (if (and changed (component-compile-only component))
+ ;; For files which are :compile-only T, compiling the file
+ ;; satisfies the need to load.
+ changed
+ ;; If the file wasn't compiled, or :compile-only is nil,
+ ;; check to see if it needs to be loaded.
+ (and (load-file-operation component force) ; FORCE was CHANGED ???
+ changed))))
+
+(defun unmunge-lucid (namestring)
+ ;; Lucid's implementation of COMPILE-FILE is non-standard, in that
+ ;; when the :output-file is a relative pathname, it tries to munge
+ ;; it with the directory of the source file. For example,
+ ;; (compile-file "src/globals.lisp" :output-file "bin/globals.sbin")
+ ;; tries to stick the file in "./src/bin/globals.sbin" instead of
+ ;; "./bin/globals.sbin" like any normal lisp. This hack seems to fix the
+ ;; problem. I wouldn't have expected this problem to occur with any
+ ;; use of defsystem, but some defsystem users are depending on
+ ;; using relative pathnames (at least three folks reported the problem).
+ (cond ((null-string namestring) namestring)
+ ((char= (char namestring 0) #\/)
+ ;; It's an absolute namestring
+ namestring)
+ (t
+ ;; Ugly, but seems to fix the problem.
+ (concatenate 'string "./" namestring))))
+
+(defun compile-file-operation (component force)
+ ;; Returns T if the file had to be compiled.
+ (let ((must-compile
+ ;; For files which are :load-only T, loading the file
+ ;; satisfies the demand to recompile.
+ (and (null (component-load-only component)) ; not load-only
+ (or (find force '(:all :new-source-all t) :test #'eq)
+ (and (find force '(:new-source :new-source-and-dependents)
+ :test #'eq)
+ (needs-compilation component nil)))))
+ (source-pname (component-full-pathname component :source)))
+
+ (cond ((and must-compile (probe-file source-pname))
+ (with-tell-user ("Compiling source" component :source)
+ (let ((output-file
+ #+:lucid
+ (unmunge-lucid (component-full-pathname component
+ :binary))
+ #-:lucid
+ (component-full-pathname component :binary)))
+
+ ;; make certain the directory we need to write to
+ ;; exists [pvaneynd at debian.org 20001114]
+ ;; Added PATHNAME-HOST following suggestion by John
+ ;; DeSoi [marcoxa at sourceforge.net 20020529]
+
+ (ensure-directories-exist
+ (make-pathname
+ :host (pathname-host output-file)
+ :directory (pathname-directory output-file)))
+
+ (or *oos-test*
+ (apply (compile-function component)
+ source-pname
+ :output-file
+ output-file
+ #+(or :cmu :scl) :error-file
+ #+(or :cmu :scl) (and *cmu-errors-to-file*
+ (component-full-pathname component
+ :error))
+ #+CMU
+ :error-output
+ #+CMU
+ *cmu-errors-to-terminal*
+ (component-compiler-options component)
+ ))))
+ must-compile)
+ (must-compile
+ (tell-user "Source file not found. Not compiling"
+ component :source :no-dots :force)
+ nil)
+ (t nil))))
+
+
+(defun needs-compilation (component force)
+ ;; If there is no binary, or it is older than the source
+ ;; file, then the component needs to be compiled.
+ ;; Otherwise we only need to recompile if it depends on a file that changed.
+ (declare (ignore force))
+ (let ((source-pname (component-full-pathname component :source))
+ (binary-pname (component-full-pathname component :binary)))
+ (and
+ ;; source must exist
+ (probe-file source-pname)
+ (or
+ ;; We force recompilation.
+ #|(find force '(:all :new-source-all) :test #'eq)|#
+ ;; no binary
+ (null (probe-file binary-pname))
+ ;; old binary
+ (< (file-write-date binary-pname)
+ (file-write-date source-pname))))))
+
+
+(defun needs-loading (component &optional (check-source t) (check-binary t))
+ ;; Compares the component's load-time against the file-write-date of
+ ;; the files on disk.
+ (let ((load-time (component-load-time component))
+ (source-pname (component-full-pathname component :source))
+ (binary-pname (component-full-pathname component :binary)))
+ (or
+ #|| ISI Extension ||#
+ (component-load-always component)
+
+ ;; File never loaded.
+ (null load-time)
+ ;; Binary is newer.
+ (when (and check-binary
+ (probe-file binary-pname))
+ (< load-time
+ (file-write-date binary-pname)))
+ ;; Source is newer.
+ (when (and check-source
+ (probe-file source-pname))
+ (< load-time
+ (file-write-date source-pname))))))
+
+;;; Need to completely rework this function...
+(defun load-file-operation (component force)
+ ;; Returns T if the file had to be loaded
+ (let* ((binary-pname (component-full-pathname component :binary))
+ (source-pname (component-full-pathname component :source))
+ (binary-exists (probe-file binary-pname))
+ (source-exists (probe-file source-pname))
+ (source-needs-loading (needs-loading component t nil))
+ (binary-needs-loading (needs-loading component nil t))
+ ;; needs-compilation has an implicit source-exists in it.
+ (needs-compilation (if (component-load-only component)
+ source-needs-loading
+ (needs-compilation component force)))
+ (check-for-new-source
+ ;; If force is :new-source*, we're checking for files
+ ;; whose source is newer than the compiled versions.
+ (find force '(:new-source :new-source-and-dependents :new-source-all)
+ :test #'eq))
+ (load-binary (or (find force '(:all :new-source-all t) :test #'eq)
+ binary-needs-loading))
+ (load-source
+ (or *load-source-instead-of-binary*
+ (and load-binary (component-load-only component))
+ (and check-for-new-source needs-compilation)))
+ (compile-and-load
+ (and needs-compilation
+ (or load-binary check-for-new-source)
+ (compile-and-load-source-if-no-binary component)))
+ )
+ ;; When we're trying to minimize the files loaded to only those
+ ;; that need be, restrict the values of load-source and load-binary
+ ;; so that we only load the component if the files are newer than
+ ;; the load-time.
+ (when (and *minimal-load*
+ (not (find force '(:all :new-source-all)
+ :test #'eq)))
+ (when load-source (setf load-source source-needs-loading))
+ (when load-binary (setf load-binary binary-needs-loading)))
+
+ (when (or load-source load-binary compile-and-load)
+ (cond (compile-and-load
+ ;; If we're loading the binary and it is old or nonexistent,
+ ;; and the user says yes, compile and load the source.
+ (compile-file-operation component t)
+ (with-tell-user ("Loading binary" component :binary)
+ (or *oos-test*
+ (progn
+ (funcall (load-function component) binary-pname)
+ (setf (component-load-time component)
+ (file-write-date binary-pname)))))
+ t)
+ ((and source-exists
+ (or (and load-source ; implicit needs-comp...
+ (or *load-source-instead-of-binary*
+ (component-load-only component)
+ (not *compile-during-load*)))
+ (and load-binary
+ (not binary-exists)
+ (load-source-if-no-binary component))))
+ ;; Load the source if the source exists and:
+ ;; o we're loading binary and it doesn't exist
+ ;; o we're forcing it
+ ;; o we're loading new source and user wasn't asked to compile
+ (with-tell-user ("Loading source" component :source)
+ (or *oos-test*
+ (progn
+ (funcall (load-function component) source-pname)
+ (setf (component-load-time component)
+ (file-write-date source-pname)))))
+ t)
+ ((and binary-exists load-binary)
+ (with-tell-user ("Loading binary" component :binary)
+ (or *oos-test*
+ (progn
+ (funcall (load-function component) binary-pname)
+ (setf (component-load-time component)
+ (file-write-date binary-pname)))))
+ t)
+ ((and (not binary-exists) (not source-exists))
+ (tell-user-no-files component :force)
+ (when *files-missing-is-an-error*
+ (cerror "Continue, ignoring missing files."
+ "~&Source file ~S ~:[and binary file ~S ~;~]do not exist."
+ source-pname
+ (or *load-source-if-no-binary*
+ *load-source-instead-of-binary*)
+ binary-pname))
+ nil)
+ (t
+ nil)))))
+
+(eval-when (load eval)
+(component-operation :clean 'delete-binaries-operation)
+(component-operation 'clean 'delete-binaries-operation)
+(component-operation :delete-binaries 'delete-binaries-operation)
+(component-operation 'delete-binaries 'delete-binaries-operation)
+)
+(defun delete-binaries-operation (component force)
+ (when (or (eq force :all)
+ (eq force t)
+ (and (find force '(:new-source :new-source-and-dependents
+ :new-source-all)
+ :test #'eq)
+ (needs-compilation component nil)))
+ (let ((binary-pname (component-full-pathname component :binary)))
+ (when (probe-file binary-pname)
+ (with-tell-user ("Deleting binary" component :binary)
+ (or *oos-test*
+ (delete-file binary-pname)))))))
+
+
+;; when the operation = :compile, we can assume the binary exists in test mode.
+;; ((and *oos-test*
+;; (eq operation :compile)
+;; (probe-file (component-full-pathname component :source)))
+;; (with-tell-user ("Loading binary" component :binary)))
+
+(defun binary-exists (component)
+ (probe-file (component-full-pathname component :binary)))
+
+;;; or old-binary
+(defun compile-and-load-source-if-no-binary (component)
+ (when (not (or *load-source-instead-of-binary*
+ (and *load-source-if-no-binary*
+ (not (binary-exists component)))))
+ (cond ((component-load-only component)
+ #||
+ (let ((prompt (prompt-string component)))
+ (format t "~A- File ~A is load-only, ~
+ ~&~A not compiling."
+ prompt
+ (component-full-pathname component :source)
+ prompt))
+ ||#
+ nil)
+ ((eq *compile-during-load* :query)
+ (let* ((prompt (prompt-string component))
+ (compile-source
+ (y-or-n-p-wait
+ #\y 30
+ "~A- Binary file ~A is old or does not exist. ~
+ ~&~A Compile (and load) source file ~A instead? "
+ prompt
+ (component-full-pathname component :binary)
+ prompt
+ (component-full-pathname component :source))))
+ (unless (y-or-n-p-wait
+ #\y 30
+ "~A- Should I bother you if this happens again? "
+ prompt)
+ (setq *compile-during-load*
+ (y-or-n-p-wait
+ #\y 30
+ "~A- Should I compile while loading the system? "
+ prompt))) ; was compile-source, then t
+ compile-source))
+ (*compile-during-load*)
+ (t nil))))
+
+(defun load-source-if-no-binary (component)
+ (and (not *load-source-instead-of-binary*)
+ (or (and *load-source-if-no-binary*
+ (not (binary-exists component)))
+ (component-load-only component)
+ (when *bother-user-if-no-binary*
+ (let* ((prompt (prompt-string component))
+ (load-source
+ (y-or-n-p-wait #\y 30
+ "~A- Binary file ~A does not exist. ~
+ ~&~A Load source file ~A instead? "
+ prompt
+ (component-full-pathname component :binary)
+ prompt
+ (component-full-pathname component :source))))
+ (setq *bother-user-if-no-binary*
+ (y-or-n-p-wait #\n 30
+ "~A- Should I bother you if this happens again? "
+ prompt ))
+ (unless *bother-user-if-no-binary*
+ (setq *load-source-if-no-binary* load-source))
+ load-source)))))
+
+;;; ********************************
+;;; Allegro Toplevel Commands ******
+;;; ********************************
+;;; Creates toplevel command aliases for Allegro CL.
+#+:allegro
+(top-level:alias ("compile-system" 8)
+ (system &key force (minimal-load mk:*minimal-load*)
+ test verbose version)
+ "Compile the specified system"
+
+ (mk:compile-system system :force force
+ :minimal-load minimal-load
+ :test test :verbose verbose
+ :version version))
+
+#+:allegro
+(top-level:alias ("load-system" 5)
+ (system &key force (minimal-load mk:*minimal-load*)
+ (compile-during-load mk:*compile-during-load*)
+ test verbose version)
+ "Compile the specified system"
+
+ (mk:load-system system :force force
+ :minimal-load minimal-load
+ :compile-during-load compile-during-load
+ :test test :verbose verbose
+ :version version))
+
+#+:allegro
+(top-level:alias ("show-system" 5) (system)
+ "Show information about the specified system."
+
+ (mk:describe-system system))
+
+#+:allegro
+(top-level:alias ("describe-system" 9) (system)
+ "Show information about the specified system."
+
+ (mk:describe-system system))
+
+#+:allegro
+(top-level:alias ("system-source-size" 9) (system)
+ "Show size information about source files in the specified system."
+
+ (mk:system-source-size system))
+
+#+:allegro
+(top-level:alias ("clean-system" 6)
+ (system &key force test verbose version)
+ "Delete binaries in the specified system."
+
+ (mk:clean-system system :force force
+ :test test :verbose verbose
+ :version version))
+
+#+:allegro
+(top-level:alias ("edit-system" 7)
+ (system &key force test verbose version)
+ "Load system source files into Emacs."
+
+ (mk:edit-system system :force force
+ :test test :verbose verbose
+ :version version))
+
+#+:allegro
+(top-level:alias ("hardcopy-system" 9)
+ (system &key force test verbose version)
+ "Hardcopy files in the specified system."
+
+ (mk:hardcopy-system system :force force
+ :test test :verbose verbose
+ :version version))
+
+#+:allegro
+(top-level:alias ("make-system-tag-table" 13) (system)
+ "Make an Emacs TAGS file for source files in specified system."
+
+ (mk:make-system-tag-table system))
+
+
+;;; ********************************
+;;; Allegro Make System Fasl *******
+;;; ********************************
+#+:excl
+(defun allegro-make-system-fasl (system destination
+ &optional (include-dependents t))
+ (excl:shell
+ (format nil "rm -f ~A; cat~{ ~A~} > ~A"
+ destination
+ (if include-dependents
+ (files-in-system-and-dependents system :all :binary)
+ (files-in-system system :all :binary))
+ destination)))
+
+(defun files-which-need-compilation (system)
+ (mapcar #'(lambda (comp) (component-full-pathname comp :source))
+ (remove nil
+ (file-components-in-component
+ (find-system system :load) :new-source))))
+
+(defun files-in-system-and-dependents (name &optional (force :all)
+ (type :source) version)
+ ;; Returns a list of the pathnames in system and dependents in load order.
+ (let ((system (find-system name :load)))
+ (multiple-value-bind (*version-dir* *version-replace*)
+ (translate-version version)
+ (let ((*version* version))
+ (let ((result (file-pathnames-in-component system type force)))
+ (dolist (dependent (reverse (component-depends-on system)))
+ (setq result
+ (append (files-in-system-and-dependents dependent
+ force type version)
+ result)))
+ result)))))
+
+(defun files-in-system (name &optional (force :all) (type :source) version)
+ ;; Returns a list of the pathnames in system in load order.
+ (let ((system (if (and (component-p name)
+ (member (component-type name) '(:defsystem :system :subsystem)))
+ name
+ (find-system name :load))))
+ (multiple-value-bind (*version-dir* *version-replace*)
+ (translate-version version)
+ (let ((*version* version))
+ (file-pathnames-in-component system type force)))))
+
+(defun file-pathnames-in-component (component type &optional (force :all))
+ (mapcar #'(lambda (comp) (component-full-pathname comp type))
+ (file-components-in-component component force)))
+
+(defun file-components-in-component (component &optional (force :all)
+ &aux result changed)
+ (case (component-type component)
+ ((:file :private-file)
+ (when (setq changed
+ (or (find force '(:all t) :test #'eq)
+ (and (not (non-empty-listp force))
+ (needs-compilation component nil))))
+ (setq result
+ (list component))))
+ ((:module :system :subsystem :defsystem)
+ (dolist (module (component-components component))
+ (multiple-value-bind (r c)
+ (file-components-in-component
+ module
+ (cond ((and (some #'(lambda (dependent)
+ (member dependent changed))
+ (component-depends-on module))
+ (or (non-empty-listp force)
+ (eq force :new-source-and-dependents)))
+ ;; The component depends on a changed file and force agrees.
+ :all)
+ ((and (non-empty-listp force)
+ (member (component-name module) force
+ :test #'string-equal :key #'string))
+ ;; Force is a list of modules and the component is
+ ;; one of them.
+ :all)
+ (t force)))
+ (when c
+ (push module changed)
+ (setq result (append result r)))))))
+ (values result changed))
+
+(setf (symbol-function 'oos) (symbol-function 'operate-on-system))
+
+;;; ********************************
+;;; Additional Component Operations
+;;; ********************************
+
+;;; *** Edit Operation ***
+
+;;; Should this conditionalization be (or :mcl (and :CCL (not :lispworks)))?
+#|
+#+:ccl
+(defun edit-operation (component force)
+ "Always returns nil, i.e. component not changed."
+ (declare (ignore force))
+ ;;
+ (let* ((full-pathname (make::component-full-pathname component :source))
+ (already-editing\? #+:mcl (dolist (w (CCL:windows :class
+ 'fred-window))
+ (when (equal (CCL:window-filename w)
+ full-pathname)
+ (return w)))
+ #-:mcl nil))
+ (if already-editing\?
+ #+:mcl (CCL:window-select already-editing\?) #-:mcl nil
+ (ed full-pathname)))
+ nil)
+
+#+:allegro
+(defun edit-operation (component force)
+ "Edit a component - always returns nil, i.e. component not changed."
+ (declare (ignore force))
+ (let ((full-pathname (component-full-pathname component :source)))
+ (ed full-pathname))
+ nil)
+
+#+(or :ccl :allegro)
+(make::component-operation :edit 'edit-operation)
+#+(or :ccl :allegro)
+(make::component-operation 'edit 'edit-operation)
+|#
+
+;;; *** Hardcopy System ***
+(defparameter *print-command* "enscript -2Gr" ; "lpr"
+ "Command to use for printing files on UNIX systems.")
+#+:allegro
+(defun hardcopy-operation (component force)
+ "Hardcopy a component - always returns nil, i.e. component not changed."
+ (declare (ignore force))
+ (let ((full-pathname (component-full-pathname component :source)))
+ (excl:run-shell-command (format nil "~A ~A"
+ *print-command* full-pathname)))
+ nil)
+
+#+:allegro
+(make::component-operation :hardcopy 'hardcopy-operation)
+#+:allegro
+(make::component-operation 'hardcopy 'hardcopy-operation)
+
+
+;;; *** System Source Size ***
+
+(defun system-source-size (system-name &optional (force :all))
+ "Prints a short report and returns the size in bytes of the source files in
+ <system-name>."
+ (let* ((file-list (files-in-system system-name force :source))
+ (total-size (file-list-size file-list)))
+ (format t "~&~a/~a (~:d file~:p) totals ~:d byte~:p (~:d kB)"
+ system-name force (length file-list)
+ total-size (round total-size 1024))
+ total-size))
+
+(defun file-list-size (file-list)
+ "Returns the size in bytes of the files in <file-list>."
+ ;;
+ (let ((total-size 0))
+ (dolist (file file-list)
+ (with-open-file (stream file)
+ (incf total-size (file-length stream))))
+ total-size))
+
+;;; *** System Tag Table ***
+
+#+:allegro
+(defun make-system-tag-table (system-name)
+ "Makes an Emacs tag table using the GNU etags program."
+ (let ((files-in-system (files-in-system system-name :all :source)))
+
+ (format t "~&Making tag table...")
+ (excl:run-shell-command (format nil "etags ~{~a ~}" files-in-system))
+ (format t "done.~%")))
+
+
+;;; end of file -- defsystem.lisp --
diff --git a/dicom/src/actions-client.cl b/dicom/src/actions-client.cl
new file mode 100644
index 0000000..9d41ce2
--- /dev/null
+++ b/dicom/src/actions-client.cl
@@ -0,0 +1,423 @@
+;;;
+;;; actions-client
+;;;
+;;; DICOM Upper-Layer Protocol Action functions for Client only.
+;;; Contains functions used in Client only.
+;;;
+;;; 26-Dec-2000 BobGian wrap IGNORE-ERRORS around error-prone fcns.
+;;; Include error-recovery options in case those fcns barf.
+;;; Change a few local variable names for consistency.
+;;; 26-Dec-2000 BobGian replace used-once locals in OPEN-CONNECTION.
+;;; 11-Apr-2001 BobGian remove name-server lookup and printing of hostname
+;;; in OPEN-CONNECTION. IP addr has same information and is much faster.
+;;; 11-Apr-2001 BobGian add more explicit error reporting to OPEN-CONNECTION.
+;;; 10-Sep-2001 BobGian remove IGNORE-ERRORS - errors at this level
+;;; should be debugged rather than ignored or just logged.
+;;; 23-Jan-2002 BobGian install REPORT-ERROR specialized to Client mode.
+;;; Install stubs: PARSE-OBJECT and WRITE-DICOM-OUTPUT [used by Server only].
+;;; 13-Mar-2002 BobGian REPORT-ERROR dumps environment and TCP-BUFFER
+;;; if args supplied. Start/End indices saved in global vars.
+;;; 16-Apr-2002 BobGian extend REPORT-ERROR to print output PDU currently
+;;; under construction as list structure before being written to TCP-buffer.
+;;; 16-Apr-2002 BobGian MISHAP called in WRITE-DICOM-OUTPUT [stub] prints
+;;; list-structure representation of its input if called accidently.
+;;; 19-Apr-2002 BobGian second arg to REPORT-ERROR can be used to print
+;;; arbitrary list structure or to dump TCP-Buffer.
+;;; 23-Apr-2002 BobGian add *MAX-DATAFIELD-LEN* to REPORT-ERROR.
+;;; Also AE-03 caches max PDU size for all subsequent PDU sends.
+;;; 06-May-2002 BobGian optional add error message arg to REPORT-ERROR
+;;; and MISHAP. Sometimes message in embedded call to ERROR gets lost.
+;;; 10-May-2002 BobGian AE-03 checks *MAX-DATAFIELD-LEN* for maximum value
+;;; and for being EVEN when association is accepted.
+;;; 06-Aug-2002 BobGian *PRINT-PRETTY* -> T in REPORT-ERROR.
+;;; Jul/Aug 2002 BobGian labels in REPORT-ERROR used to identify variables
+;;; improved (made more consistent with var name and function).
+;;; 17-Sep-2002 BobGian:
+;;; REPORT-ERROR accepts 3rd arg DICOM-ALIST to print conditionally.
+;;; 24-Sep-2002 BobGian:
+;;; Remove 3rd arg (DICOM-ALIST) to REPORT-ERROR and MISHAP. Same
+;;; functionality now obtained via special variable set when data available.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 08-May-2003 BobGian - REPORT-ERROR no longer binds *PRINT-PRETTY*.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 03-Nov-2003 BobGian - Add *STANDARD-OUTPUT* arg to DUMP-DICOM-DATA.
+;;; 21-Dec-2003 BobGian: Add arg to dummy PARSE-OBJECT for ignorable slots.
+;;; 02-Mar-2004 BobGian: Fix to output formatting in REPORT-ERROR.
+;;; 08-Nov-2004 BobGian remove stubs: PARSE-OBJECT and WRITE-DICOM-OUTPUT
+;;; [used by Server only].
+;;; 18-Apr-2005 I. Kalet add SSL support per Tung Le in open-connection.
+;;; 24-Jun-2009 I. kalet spell out socket: for acl-socket symbols
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+;;; All Action functions must return either an updated environment [CONSP]
+;;; resulting from parsing a command or NIL. Don't accidently let some
+;;; random trailing value get returned.
+
+;;;=============================================================
+;;; Association Establishment Actions.
+
+(defun ae-01 (env tcp-buffer tcp-strm)
+
+ "Issue CONNECT request to TCP"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore tcp-buffer tcp-strm))
+
+ ;; Must push Remote-Hostname and Remote-Port onto environment
+ ;; [hostname and port number of server our client is calling]
+ ;; at global level before invoking this action function.
+ (open-connection (item-lookup 'Remote-Hostname env t) ;Global Env
+ (item-lookup 'Remote-Port env t)) ;Global Env
+
+ (setq *event* 'event-02) ;Signal EVENT-02: Open Successful
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ae-02 (env tcp-buffer tcp-strm)
+
+ "Send A-Associate-RQ PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (send-pdu :A-Associate-RQ env tcp-buffer tcp-strm)
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ae-03 (env tcp-buffer tcp-strm)
+
+ "Issue A-Associate confirmation accepted message"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore tcp-buffer tcp-strm))
+
+ ;; Server either accepted client's proposed max PDU size or proposed its own.
+ ;; Set variable to cache it for all remaining PDUs during this association.
+ (let ((limit (item-lookup 'Max-DataField-Len env nil
+ :Max-DataField-Len-Item
+ :User-Information-Item
+ :A-Associate-AC)))
+ (cond ((typep limit 'fixnum)
+ ;; Spec requires all P-Data-TF PDUs, and therefore all PDVs,
+ ;; to be of even length.
+ (unless (evenp (the fixnum limit))
+ (mishap env nil "AE-03 [1] Odd datafield length: ~S" limit))
+ (setq *max-datafield-len* (min (the fixnum limit) #.PDU-Bufsize)))
+ (t (setq *max-datafield-len* #.PDU-Bufsize))))
+
+ (when (>= (the fixnum *log-level*) 1)
+ (format t "~%AE-03: Server accepted A-Associate-RQ.~%")
+ (format t "~&Max PDU size negotiated: ~D~%" *max-datafield-len*))
+
+ (setq *event* 'event-09) ;Signal EVENT-09: Ready to send P-Data-TF PDU
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ae-04 (env tcp-buffer tcp-strm)
+
+ "Issue A-Associate REJECTED message, close connection, leave DUL main loop"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore tcp-buffer))
+
+ (let ((result (item-lookup 'RJ-Result env t :A-Associate-RJ))
+ (source (item-lookup 'RJ-Source env t :A-Associate-RJ))
+ (diagno (item-lookup 'RJ-Diagnostic env t :A-Associate-RJ))
+ (errorstring "Unknown - DUL error"))
+
+ (declare (type simple-base-string errorstring)
+ (type fixnum result source diagno))
+
+ (format
+ t "~%~A~%"
+ (setq *status-message*
+ (concatenate
+ 'string
+ (format nil
+ "Server rejected A-Associate-RQ.~%Result: ~A~%"
+ (cond ((= result 1) "Rejection-Permanent")
+ ((= result 2) "Rejection-Transient")
+ (t errorstring)))
+ (cond
+ ((= source 1)
+ (format nil "Source: UL Service-User~%Diagnostic: ~A"
+ (cond ((= diagno 1) "No Reason Given")
+ ((= diagno 2)
+ "Application Context Name Not Supported")
+ ((= diagno 3) "Calling AE Title Not Recognized")
+ ((= diagno 7) "Called AE Title Not Recognized")
+ (t errorstring))))
+ ((= source 2)
+ (format nil
+ "Source: UL Service-Provider [ACSE]~%Diagnostic: ~A"
+ (cond ((= diagno 1) "No Reason Given")
+ ((= diagno 2) "Protocol Version Not Supported")
+ (t errorstring))))
+ ((= source 3)
+ (format nil "Source: UL Service-Provider~%Diagnostic: ~A"
+ (cond ((= diagno 1) "Temporary Congestion")
+ ((= diagno 2) "Local Limit Exceeded")
+ (t errorstring))))
+ (t (format nil "Source: ~A" errorstring)))))))
+
+ (close-connection tcp-strm)
+
+ nil)
+
+;;;=============================================================
+;;; Data-Transfer Actions.
+;;; This function is invoked by desire to send a P-Data-TF PDU containing
+;;; a Command or Data-Set, as indicated by Event-09 being signalled.
+;;; Currently, it sends only the :C-Echo-RQ or :C-Store-RTPlan-RQ requests.
+
+(defun dt-01 (env tcp-buffer tcp-strm)
+
+ "Send P-Data-TF PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ ;; Note that message sending is accomplished by giving SEND-PDU a complete
+ ;; PDU to send, in which are embedded operators to construct the message,
+ ;; rather than by sending a :P-Data-TF with an embedded PDV-Message variable
+ ;; bound in the sending environment. SEND-PDU handles fragmentation, if
+ ;; needed. NB: Fragmentation only works correctly if a PDU which might
+ ;; require it contains ONLY a single PDV.
+
+ (let ((cmd (item-lookup 'Command env t))) ;Global Env
+
+ (cond ((eq cmd :C-Echo-RQ)
+ (send-pdu :C-Echo-RQ env tcp-buffer tcp-strm))
+
+ ((eq cmd :C-Store-RTPlan-RQ)
+ ;; The command fits in a single PDU.
+ (send-pdu :C-Store-RTPlan-Command env tcp-buffer tcp-strm)
+ ;; The data portion is rule-defined to be a single PDV, but likely
+ ;; it will be fragmented into multiple single-PDV PDUs by SEND-PDU.
+ (send-pdu :C-Store-RTPlan-Data env tcp-buffer tcp-strm))
+
+ (t (mishap env tcp-buffer "DT-01 [1] Bogus COMMAND: ~S" cmd))))
+
+ nil)
+
+;;;=============================================================
+;;; Association Release Actions.
+
+(defun ar-01 (env tcp-buffer tcp-strm)
+
+ "Send A-Release-RQ PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (send-pdu :A-Release-RQ env tcp-buffer tcp-strm)
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ar-03 (env tcp-buffer tcp-strm)
+
+ "Issue A-Release confirmation message, close connection, leave DUL main loop"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%AR-03: A-Release confirmation.~%"))
+
+ (close-connection tcp-strm)
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ar-06 (env tcp-buffer tcp-strm)
+
+ "Issue P-Data message -- handle P-Data PDU arriving out of order"
+
+ ;; This action is to handle P-Data-TF PDUs that arrive out of order,
+ ;; when the client has initiated a release but the server has not processed
+ ;; the PDU and is still sending Data-Set PDUs. Client must handle data and
+ ;; continue waiting for the A-Release-RSP PDU [loop to STATE-07].
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer tcp-strm))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%AR-06: P-Data.~%"))
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ar-09 (env tcp-buffer tcp-strm)
+
+ "Send A-Release-RSP PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (send-pdu :A-Release-RSP env tcp-buffer tcp-strm)
+
+ nil)
+
+;;;=============================================================
+;;; Client TCP stream operations.
+
+(defun open-connection (hostname port)
+
+ (declare (type simple-base-string hostname)
+ (type fixnum port))
+
+ (multiple-value-bind (val report)
+ (ignore-errors
+ (let* ((tcp-strm
+ (socket:make-socket
+ :address-family :Internet :type :Stream :format :Binary
+ :connect :Active :remote-host hostname :remote-port port))
+ (remote-IP-addr (socket:remote-host tcp-strm))
+ (remote-IP-string
+ (or (ignore-errors (socket:ipaddr-to-dotted remote-IP-addr))
+ (format nil "~D" remote-IP-addr)))
+ (local-IP-addr (socket:local-host tcp-strm))
+ (local-IP-string
+ (or (ignore-errors (socket:ipaddr-to-dotted local-IP-addr))
+ (format nil "~D" local-IP-addr))))
+
+ (declare (type simple-base-string remote-IP-string local-IP-string))
+
+ (setq *remote-IP-string* remote-IP-string)
+ (when (>= (the fixnum *log-level*) 1)
+ (format t
+ #.(concatenate
+ 'string
+ "~%OPEN-CONNECTION: Opening connection.~%"
+ " FROM IP address: ~A, Port ~D~%"
+ " TO IP address: ~A, Port ~D~%")
+ local-IP-string
+ (socket:local-port tcp-strm)
+ remote-IP-string
+ (socket:remote-port tcp-strm)))
+
+ (setq *connection-strm* (if *use-ssl*
+ (socket:make-ssl-client-stream tcp-strm)
+ tcp-strm))))
+
+ (declare (ignore val))
+
+ (when (typep report 'condition)
+ (format t "~%~A~%"
+ (setq *status-message* "Error opening TCP connection:"))
+ (throw :Abandon-Client nil))))
+
+;;;-------------------------------------------------------------
+
+(defun close-connection (tcp-strm)
+
+ (when (>= (the fixnum *log-level*) 1)
+ (format t "~%CLOSE-CONNECTION: Closing connection.~%Stream: ~S~%"
+ tcp-strm))
+
+ (unless (streamp tcp-strm)
+ ;; This detects a fault in control structure -- attempt to call
+ ;; CLOSE-CONNECTION when *CONNECTION-STRM* is already NIL.
+ (mishap nil nil "CLOSE-CONNECTION [1] Stream already closed:~%~S"
+ tcp-strm))
+
+ (unless (close tcp-strm)
+ ;; If stream was open, CLOSE closes it and returns T.
+ ;; If it was already open, CLOSE returns NIL.
+ ;; This detects attempt to close an already closed connection
+ ;; when *CONNECTION-STRM* is non-NIL.
+ (mishap nil nil "CLOSE-CONNECTION [2] Stream already closed:~%~S"
+ tcp-strm))
+
+ (setq *connection-strm* nil))
+
+;;;=============================================================
+;;; This version of REPORT-ERROR is specialized to Client functionality.
+;;; It reports only global vars used by Client.
+
+(defun report-error (env data &optional msg &rest format-args)
+
+ ;; Reports useful information [previously cached as values of global vars]
+ ;; to logging stream in case of run-time errors.
+
+ (declare (type list env format-args)
+ (type (or null simple-base-string) msg)
+ (type
+ (or null list (simple-array (unsigned-byte 8) (#.TCP-Bufsize)))
+ data))
+
+ (format t "~%REPORT-ERROR:~%")
+ (when (typep msg 'simple-base-string)
+ (apply #'cl:format t msg format-args))
+
+ ;; Date, Time:
+ (format t "~&~% Date/Time:~44T~A~%~%" (date/time))
+
+ ;; Identification of communication entities:
+ (format t "~& Remote IP Address:~44T~S~%" *remote-IP-string*)
+ (format t "~& Calling AE Name:~44T~S~%" *calling-AE-name*)
+ (format t "~& Called AE Name:~44T~S~%" *called-AE-name*)
+ (format t "~& Max PDU Size:~44T~S~%~%"*max-datafield-len*)
+
+ ;; Operation being performed:
+ (format t "~& SOP Class Name:~44T~S~%~%" *SOP-class-name*)
+
+ ;; State of PDU/Object parsers and protocol controller:
+ (format t "~& State:~44T~S (~A)~%" *state* (get *state* 'documentation))
+ (format t "~& Event:~44T~S (~A)~%" *event* (get *event* 'documentation))
+ (format t "~& Arguments:~44T~S~%~%" *args*)
+
+ ;; Status reports:
+ (format t "~& Status Message:~44T~S~%"
+ (or *status-message* "Unknown error"))
+ (format t "~& Status Code:~44T~S~%" *status-code*)
+
+ ;; State of current Environment:
+ (when (consp env)
+ (print-environment env))
+
+ (cond ((consp data)
+ ;; State of current list-structure object being constructed:
+ ;; PDU datalist is constructed backwards [items CONSed to front].
+ (format t "~% Output PDU or raw data:~% ~S~%" data))
+
+ ;; Contents of current TCP buffer:
+ ((arrayp data)
+ ;; This will dump any shifted bytes from prior PARSE-OBJECT call.
+ ;; New PDU will start at HEAD, which may be non-zero.
+ (dump-bytestream "TCP buffer" data 0 *PDU-tail*)))
+
+ ;; Used only in Server, or in Client performing Server functionality.
+ (when (consp *dicom-alist*)
+ (dump-dicom-data *dicom-alist* *standard-output*)))
+
+;;;=============================================================
+;;; Stubs. For now, these functions are used only by Server, but calls
+;;; to them appear [in non-invoked conditional branches] in Common code.
+
+(defun parse-object (env tcp-buffer head tail last-frag? continuation
+ ignorable-groups-list)
+ (declare (ignore tcp-buffer head tail last-frag? continuation
+ ignorable-groups-list))
+ (mishap env nil "PARSE-OBJECT called in Client."))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/actions-common.cl b/dicom/src/actions-common.cl
new file mode 100644
index 0000000..4dd6965
--- /dev/null
+++ b/dicom/src/actions-common.cl
@@ -0,0 +1,476 @@
+;;;
+;;; actions-common
+;;;
+;;; DICOM Upper-Layer Protocol Action functions common to Client and Server.
+;;; Contains functions common to Client and Server.
+;;;
+;;; 09-May-2001 BobGian DT-02 handles data file writeout [object output
+;;; in general] after object parse, rather than embedding writeout
+;;; functionality inside PARSE-OBJECT.
+;;; 07-Mar-2002 BobGian fix DT-02 to pop PDV items off environment stack
+;;; after data is processed, preventing unbounded stack growth.
+;;; 15-Mar-2002 BobGian checkpoint environment just before decoding and
+;;; executing command, and restore it when done with command.
+;;; 15-Apr-2002 BobGian DT-02 passes all continuations to PARSE-OBJECT,
+;;; without discriminating on type. Assumed to be C-STORE, any subtype.
+;;; Fix bug in discrimination of Storage-Services provided by Server.
+;;; 24-Apr-2002 BobGian *STATUS-MESSAGE* set to "Success" only upon
+;;; successful completion, not as initialization.
+;;; 24-Apr-2002 BobGian triggering EVENT-15 sets *STATUS-MESSAGE* rather
+;;; than action function invoked - finer discrimination this way.
+;;; 26-Apr-2002 BobGian *STATUS-MESSAGE* set by any abort action function,
+;;; unless set previously by some error-detecting event.
+;;; 06-May-2002 BobGian add error message arg to REPORT-ERROR calls.
+;;; 26-Jun-2002 BobGian REPORT-ERROR called on errors regardless of log level.
+;;; Jul/Aug 2002 BobGian DT-02 does dispatch on SOP Class in C-Store-RQ to
+;;; invoke WRITE-DICOM-OUTPUT for :Image or :Structure-Set data,
+;;; rather than just for :Image data. Invokes DUMP-DICOM-DATA for all
+;;; non-implemented SOP Classes.
+;;; 21-Aug-2002 BobGian DUMP-DICOM-DATA invoked at log level 1 for all C-Store
+;;; operations, at log level 0 for all non-implemented SOP Classes.
+;;; 24-Sep-2002 BobGian set special var *DICOM-ALIST* to hold parsed data
+;;; once available - provides access to all error-reporting functions.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 03-Nov-2003 BobGian - Add *STANDARD-OUTPUT* arg to DUMP-DICOM-DATA.
+;;; 21-Dec-2003 BobGian: Add arg to PARSE-OBJECT for ignorable slots.
+;;; 15-Mar-2005 BobGian: Move WRITE-DICOM-OUTPUT dicom -> prism package.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+;;; All Action functions must return either an updated environment [CONSP]
+;;; resulting from parsing a command or NIL. Don't accidently let some
+;;; random trailing value get returned.
+
+;;;=============================================================
+;;; Data-Transfer Actions.
+;;; This function is invoked by the receipt of a P-Data-TF PDU containing
+;;; a DICOM message [Command or Data-Set]. For server, message can be a
+;;; C-Echo-RQ command, C-Store-RQ command, or C-Store dataset.
+;;; For client, message can be a response [C-Store-RSP or C-Echo-RSP] from
+;;; server to client's sending an RTPlan or an Echo-Verification request.
+;;;
+;;; This action function receives the current environment and extends it
+;;; internally [by parsing messages and datasets]. This extended environment
+;;; must be passed back to the caller so that other action functions can see
+;;; the new information. This is the only action function that can return
+;;; a non-NIL new environment.
+
+(defun dt-02 (env tcp-buffer tcp-strm &aux new-env tmp)
+
+ "Issue P-Data, decode message, take action"
+
+ (declare (type list env new-env *checkpointed-environment*)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ ;; Pop latest PDV item(s) off environment stack - data already processed,
+ ;; so we don't need to accumulate multiple PDV frames in environment.
+ (do ((ptr env (cdr ptr)))
+ ((not (eq (caar ptr) :P-Data-TF))
+ (setq new-env ptr)))
+
+ ;; If environment has not been checkpointed [ie, after association has been
+ ;; established and before evaluating a command or data-transfer message]
+ ;; checkpoint environment for restoration upon completion of command.
+ (let ((checkpointed-env *checkpointed-environment*))
+ (unless (consp checkpointed-env)
+ (setq *checkpointed-environment* new-env)))
+
+ ;; Give SET-LOOKUP the ENV before PDV is popped off!
+ (dolist (pdv (set-lookup env :PDV-Item :P-Data-TF))
+
+ (let ((id (item-lookup 'PC-ID pdv t))
+ (mch (item-lookup 'PDV-MCH pdv t))
+ (msg (item-lookup 'PDV-Message pdv t))
+ (cmd-tag))
+
+ (declare (type list msg)
+ (type symbol cmd-tag)
+ (type fixnum id mch))
+
+ ;; MSG value: ( :Message <Start-Idx> <End-Idx> )
+ ;; Both indices must be within current PDV.
+ ;; Message Control Header (MCH) [1 byte]:
+ ;; #b******XY [* is don't-care bit, X and Y are 2 lowest-order bits]
+ ;; Bit X = 0 -> Message is NOT LAST fragment.
+ ;; Bit X = 1 -> Message is LAST fragment.
+ ;; Bit Y = 0 -> Message is Data-Set.
+ ;; Bit Y = 1 -> Message is a Command.
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%DT-02: P-Data received: ~A, ~A fragment.~%"
+ (if (= (logand #x01 mch) #x01) "Command" "Data-Set")
+ (if (= (logand #x02 mch) #x02) "Last" "Internal")))
+
+ (cond
+ ((= (logand #x01 mch) #x01) ;Message is a Command
+ (multiple-value-setq (cmd-tag new-env)
+ (parse-message new-env ;Environment, PDV popped
+ tcp-buffer ;Source-Array -- TCP buffer
+ (second msg) ;Start-Idx of PDV
+ (third msg))) ;End-Idx of PDV
+
+ ;; Put PC-ID for this particular PDV-Item into environment as
+ ;; a "global" value so that generator can retrieve it later
+ ;; for constructing response to the command.
+ (push `(PC-ID . ,id) new-env)
+
+ (cond
+ ((eq cmd-tag :C-Echo-RQ)
+ (cond
+ ((string= (setq tmp (item-lookup 'Echo-SOP-Class-UID-Str
+ new-env t :C-Echo-RQ))
+ *Echo-Verification-Service*)
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%DT-02: C-Echo-Cmd received.~%"))
+ ;; Sending complete PDU containing C-Echo-RSP message.
+ (send-pdu :C-Echo-RSP new-env tcp-buffer tcp-strm 'PC-ID id)
+ (format t "~%Echo Verification test succeeded.~%"))
+
+ (t (setq *event* 'event-15)
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 6: Invalid PDU Parameter Value
+ (setq *args* `(PC-ID ,id Abort-Source 2 Abort-Diagnostic 6))
+ (format t "~%DT-02 [1] ~A~%"
+ (setq *status-message*
+ (format nil "Bad SOP-Class-UID: ~S" tmp)))
+ (report-error new-env tcp-buffer *status-message*))))
+
+ ((eq cmd-tag :C-Echo-RSP)
+ (format t "~%Echo Verification test succeeded.~%")
+ (format t "~%Echo Message ID: ~S"
+ (item-lookup 'Echo-Msg-ID new-env t :C-Echo-RSP))
+ (format t "~%Echo SOP Class UID: ~S"
+ (item-lookup 'Echo-SOP-Class-UID-Str
+ new-env t :C-Echo-RSP))
+ (format t "~%Echo Verification status: ~S~%"
+ (setq *status-code*
+ (item-lookup 'Echo-Msg-Status
+ new-env t :C-Echo-RSP)))
+ (when (= (the fixnum *status-code*) 0)
+ (setq *status-message* "Success"))
+ (setq *event* 'event-11))
+
+ ((eq cmd-tag :C-Store-RQ)
+ (let ((storage-service
+ (item-lookup 'Store-SOP-Class-UID-Str
+ new-env t :C-Store-RQ)))
+ (declare (type simple-base-string storage-service))
+ (cond
+ ((not (member storage-service *Object-Storage-Services*
+ :test #'string=))
+ (setq *event* 'event-15)
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 6: Invalid PDU Parameter Value
+ (setq *args* `(PC-ID ,id Abort-Source 2 Abort-Diagnostic 6))
+ (format t "~%DT-02 [2] ~A~%"
+ (setq *status-message*
+ (format nil "Bad SOP-Class-UID: ~S"
+ storage-service)))
+ (report-error new-env tcp-buffer *status-message*))
+
+ ((= (the fixnum
+ (item-lookup 'DataSet-Type new-env t :C-Store-RQ))
+ #x0101)
+ (setq *event* 'event-15)
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 6: Invalid PDU Parameter Value
+ (setq *args* `(PC-ID ,id Abort-Source 2 Abort-Diagnostic 6))
+ (format t "~%DT-02 [3] ~A~%"
+ (setq *status-message*
+ "Bad DataSet-Type: #x0101 (no dataset)"))
+ (report-error new-env tcp-buffer *status-message*)))))
+
+ ((eq cmd-tag :C-Store-RSP)
+ (format t "~%Store Message ID: ~S"
+ (item-lookup 'Store-Msg-ID new-env t :C-Store-RSP))
+ (format t "~%Store SOP Class UID: ~S"
+ (item-lookup 'Store-SOP-Class-UID-Str
+ new-env t :C-Store-RSP))
+ (format t "~%Store SOP Instance UID: ~S"
+ (item-lookup 'Store-SOP-Instance-UID-Str
+ new-env t :C-Store-RSP))
+ (format t "~%C-Store (RTPlan) status: ~S~%"
+ (setq *status-code*
+ (item-lookup 'Store-Msg-Status
+ new-env t :C-Store-RSP)))
+ (when (= (the fixnum *status-code*) 0)
+ (setq *status-message* "Success"))
+ (setq *event* 'event-11))
+
+ (t (setq *event* 'event-15)
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 1: Unrecognized PDU
+ (setq *args* `(PC-ID ,id Abort-Source 2 Abort-Diagnostic 1))
+ (format t "~%DT-02 [4] ~A~%"
+ (setq *status-message*
+ (format nil "Unrecognized command: ~S" cmd-tag)))
+ (when (>= (the fixnum *log-level*) 2)
+ ;; PARSE-MESSAGE already reported the failed parse and dumped
+ ;; the message in hex, but at this logging level the entire
+ ;; PDU will get dumped.
+ (report-error new-env tcp-buffer *status-message*)))))
+
+ ;; Message is a DataSet -- only C-Store datasets handled so far.
+ (t (let ((dicom-alist
+ (parse-object new-env ;Environment, PDV popped
+ tcp-buffer ;TCP buffer
+ (second msg) ;Start-Idx of PDV
+ (third msg) ;End-Idx of PDV
+ (= (logand #x02 mch) #x02) ;Last fragment?
+ *parser-state* ;Continuation
+ *ignorable-groups-list*)) ;Ignorable slots
+ (so *standard-output*))
+ (declare (type list dicom-alist))
+ (when (consp dicom-alist)
+ (setq *dicom-alist* dicom-alist) ;Error-reporting handle.
+ (let ((storage-service
+ (item-lookup 'Store-SOP-Class-UID-Str
+ new-env t :C-Store-RQ)))
+ (declare (type simple-base-string storage-service))
+ (cond
+ ;; All server-implemented Image Storage Class SOPs here.
+ ((member storage-service *Image-Storage-Services*
+ :test #'string=)
+ (when (>= (the fixnum *log-level*) 1)
+ (dump-dicom-data dicom-alist so))
+ (pr::write-dicom-output :Image dicom-alist))
+ ;; Handler for Structure-Sets.
+ ((string= storage-service *Structure-Set-Storage-Service*)
+ (when (>= (the fixnum *log-level*) 1)
+ (dump-dicom-data dicom-alist so))
+ (pr::write-dicom-output :Structure-Set dicom-alist))
+ ;; Handler for RT-Plans. Debugging dumper.
+ ((string= storage-service *RTPlan-Storage-Service*)
+ (dump-dicom-data dicom-alist so))
+ ;; Below is default debug dumper for all unimplemented SOPs.
+ (t (dump-dicom-data dicom-alist so))))
+ (send-pdu :C-Store-RSP new-env tcp-buffer tcp-strm)
+ ;; Completion of command [don't reset environment until done,
+ ;; as indicated by non-null DICOM-ALIST - on pre-completion
+ ;; calls PARSE-OBJECT sets continuation and returns NIL] -
+ ;; restore checkpointed environment and mark environment-saving
+ ;; variable as ready for next save.
+ (setq new-env *checkpointed-environment*)
+ (setq *checkpointed-environment* nil)))))))
+
+ ;; Be sure to return the [possibly] updated environment.
+ new-env)
+
+;;;=============================================================
+;;; Association Release Actions.
+
+(defun ar-02 (env tcp-buffer tcp-strm)
+
+ "Issue A-Release message"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer tcp-strm))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%AR-02: Initiating A-Release.~%"))
+
+ (setq *event* 'event-14) ;Signal EVENT-14: A-Release Response
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ar-08 (env tcp-buffer tcp-strm)
+
+ "Issue A-Release message [release collision]"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer tcp-strm))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%AR-08: A-Release by Association ~A.~%"
+ (cond ((eq *mode* :Client) "initiator")
+ (t "acceptor"))))
+
+ ;; Client signals EVENT-14 to initiate A-Release.
+ (when (eq *mode* :Client)
+ (setq *event* 'event-14))
+
+ nil)
+
+;;;=============================================================
+;;; Association Abort Actions.
+;;; Invoke this function, by signaling EVENT-15, for any detected
+;;; inconsistency that requires an abort. If possible, explain reason by
+;;; conveying Abort-Source and Abort-Diagnostic via *ARGS*.
+;;; If not possible, reason defaults to "UL Service-User-initiated"
+;;; and "Unexpected PDU".
+
+(defun aa-01 (env tcp-buffer tcp-strm)
+
+ "Error detected -- send A-Abort PDU (Service-User-Initiated)"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%" (setq *status-message* "Received Unexpected PDU.")))
+
+ (cond ((consp *args*)
+ (apply #'send-pdu :A-Abort env tcp-buffer tcp-strm *args*)
+ (setq *args* nil))
+
+ ;; Abort-Source = 0: UL Service-User-initiated
+ ;; Abort-Diagnostic = 2: Unexpected PDU
+ (t (send-pdu :A-Abort env tcp-buffer tcp-strm
+ 'Abort-Source 0 'Abort-Diagnostic 2)
+ nil)))
+
+;;;-------------------------------------------------------------
+
+(defun aa-02 (env tcp-buffer tcp-strm)
+
+ "ARTIM timeout"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%" (setq *status-message* "ARTIM Timeout.")))
+
+ (when (eq *mode* :Client)
+ ;; Connection should always be open in states where this function
+ ;; is called, so OK for CLOSE-CONNECTION to error out if not.
+ (close-connection tcp-strm))
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; A-Abort PDU received.
+
+(defun aa-03 (env tcp-buffer tcp-strm)
+
+ "Issue A-Abort/A-P-Abort message, close connection, leave DUL main loop"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%" (setq *status-message* "Received A-Abort PDU.")))
+
+ (when (eq *mode* :Client)
+ (close-connection tcp-strm))
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; Connection-Closed detected.
+
+(defun aa-04 (env tcp-buffer tcp-strm)
+
+ "Issue A-P-Abort message, close connection, leave DUL main loop"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer))
+
+ (when (and (eq *mode* :Client)
+ (streamp tcp-strm))
+ (close-connection tcp-strm))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%"
+ (setq *status-message* "Connection-Closed Abort detected.")))
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; PDU received while waiting for connection to close.
+
+(defun aa-06 (env tcp-buffer tcp-strm)
+
+ "Ignore invalid/unhandleable PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer tcp-strm))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%" (setq *status-message* "Received invalid PDU.")))
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; A-Associate-RQ PDU received while waiting for connection to close.
+
+(defun aa-07A (env tcp-buffer tcp-strm)
+
+ "Unexpected PDU received -- Send A-Abort PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%"
+ (setq *status-message*
+ "Rcvd A-Associate-RQ PDU waiting for connection to close.")))
+
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 2: Unexpected PDU
+ (send-pdu :A-Abort env tcp-buffer tcp-strm
+ 'Abort-Source 2 'Abort-Diagnostic 2)
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; Unrecognized/Invalid PDU received while waiting for connection to close.
+
+(defun aa-07B (env tcp-buffer tcp-strm)
+
+ "Unrecognized PDU received -- Send A-Abort PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%"
+ (setq *status-message*
+ "Rcvd Unrecognized PDU waiting for connection to close.")))
+
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 1: Unrecognized PDU
+ (send-pdu :A-Abort env tcp-buffer tcp-strm
+ 'Abort-Source 2 'Abort-Diagnostic 1)
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; Like AA-01 [abort reasons defaulted to "Unexpected PDU" unless conveyed
+;;; via *ARGS*] except that it prints message too [if logging].
+
+(defun aa-08 (env tcp-buffer tcp-strm &aux (args *args*))
+
+ "Send A-Abort PDU and issue A-P-Abort message"
+
+ (declare (type list env args)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (unless (typep *status-message* 'simple-base-string)
+ (format t "~%~A~%"
+ (setq *status-message*
+ (format nil "Sending Abort - reasons: ~S" args))))
+
+ (cond ((consp args)
+ (apply #'send-pdu :A-Abort env tcp-buffer tcp-strm args)
+ (setq *args* nil))
+
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 2: Unexpected PDU
+ (t (send-pdu :A-Abort env tcp-buffer tcp-strm
+ 'Abort-Source 2 'Abort-Diagnostic 2)
+ nil)))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/actions-server.cl b/dicom/src/actions-server.cl
new file mode 100644
index 0000000..21c9be5
--- /dev/null
+++ b/dicom/src/actions-server.cl
@@ -0,0 +1,511 @@
+;;;
+;;; actions-server
+;;;
+;;; DICOM Upper-Layer Protocol Action functions for Server only.
+;;; Contains functions used in Server only.
+;;;
+;;; 21-Dec-2000 BobGian wrap IGNORE-ERRORS around error-prone fcns.
+;;; Include error-recovery options in case those fcns barf.
+;;; Change a few local variable names for consistency.
+;;; 11-Apr-2001 BobGian change format of *REMOTE-ENTITIES* by eliminating
+;;; hostname - dispatch is done only on IP Address and AE Title.
+;;; 13-Apr-2001 BobGian fix bug in AE Title test for association acceptance.
+;;; 05-Oct-2001 BobGian add extra arg to items in *REMOTE-ENTITIES* list -
+;;; client name for printing in log file.
+;;; 06-Oct-2001 BobGian simplify test for matching IP and AET in Association
+;;; acceptance test. Only one AE-Title allowed per IP [ie, per SCU].
+;;; 23-Jan-2002 BobGian install REPORT-ERROR specialized to Server mode.
+;;; Install stubs: GENERATE-OBJECT and CLOSE-CONNECTION [used by Client only].
+;;; 13-Mar-2002 BobGian REPORT-ERROR dumps environment and TCP-BUFFER
+;;; if args supplied. Start/End indices saved in global vars.
+;;; 16-Apr-2002 BobGian extend REPORT-ERROR to print list-structure under
+;;; construction. This functionality is needed by Client to report PDU
+;;; generation process - added for compatibility to Server.
+;;; 16-Apr-2002 BobGian MISHAP called in GENERATE-OBJECT [stub] prints
+;;; list-structure representation of its input if called accidently.
+;;; 19-Apr-2002 BobGian second arg to REPORT-ERROR can be used to print
+;;; arbitrary list structure or to dump TCP-Buffer.
+;;; 23-Apr-2002 BobGian add *MAX-DATAFIELD-LEN* to REPORT-ERROR.
+;;; Also AE-07 caches max PDU size for all subsequent PDU sends.
+;;; 06-May-2002 BobGian optional add error message arg to REPORT-ERROR
+;;; and MISHAP. Sometimes message in embedded call to ERROR gets lost.
+;;; 06-May-2002 BobGian add error message arg to REPORT-ERROR calls.
+;;; 10-May-2002 BobGian AE-07 checks *MAX-DATAFIELD-LEN* for maximum value
+;;; and for being EVEN when accepting association.
+;;; 30-Jul-2002 BobGian EN-SOP-Class-UID-Str (optional item, not used)
+;;; removed from SOP-class-name disambiguation in AE-06.
+;;; 06-Aug-2002 BobGian *PRINT-PRETTY* -> T in REPORT-ERROR.
+;;; Jul/Aug 2002 BobGian AE-06 does SOP Class lookup (if present in Assoc-RQ)
+;;; via Role-SOP-Class-UID String - no longer uses External-Negotiation
+;;; SOP-Class-UID (Ext Neg documented as "not supported").
+;;; Labels in REPORT-ERROR used to identify variables improved
+;;; (made more consistent with variable name and function).
+;;; 17-Aug-2002 BobGian AE-06 logs (at level 0) AE-Titles and IP-Addresses of
+;;; client and server on Association acceptance (already did on rejection).
+;;; 30-Aug-2002 BobGian current Image-Set record written by REPORT-ERROR.
+;;; 31-Aug-2002 BobGian count of images stored written by REPORT-ERROR.
+;;; 17-Sep-2002 BobGian REPORT-ERROR conditionally dumps Dicom-Alist (3rd arg).
+;;; 24-Sep-2002 BobGian:
+;;; Remove 3rd arg (DICOM-ALIST) to REPORT-ERROR and MISHAP. Same
+;;; functionality now obtained via special variable set when data available.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 08-May-2003 BobGian - REPORT-ERROR no longer binds *PRINT-PRETTY*.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 03-Nov-2003 BobGian - Add *STANDARD-OUTPUT* arg to DUMP-DICOM-DATA.
+;;; 02-Mar-2004 BobGian: Fix to output formatting in REPORT-ERROR.
+;;; 27-Apr-2004 BobGian: REPORT-ERROR modified - *STORED-IMAGE-COUNT* ->
+;;; *STORED-IMAGE-COUNT-PER-SET* [per-image-set count]
+;;; *STORED-IMAGE-COUNT-CUMULATIVE* [cumulative count over association].
+;;; 24-Jun-2009 I. Kalet replace so: with socket: for symbols in
+;;; acl-socket package
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+;;; All Action functions must return either an updated environment [CONSP]
+;;; resulting from parsing a command or NIL. Don't accidently let some
+;;; random trailing value get returned.
+
+;;;=============================================================
+;;; Association Establishment Actions.
+
+(defun ae-05 (env tcp-buffer tcp-strm)
+
+ "Issue CONNECTION OPEN message"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer tcp-strm))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%AE-05: Transport Connection open.~%"))
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ae-06 (env tcp-buffer tcp-strm &aux
+ (applic-context-name *Application-Context-Name*)
+ (calling-IP-addr (socket:remote-host tcp-strm))
+ (calling-IP-string
+ (or (ignore-errors (socket:ipaddr-to-dotted calling-IP-addr))
+ (format nil "~D" calling-IP-addr)))
+ (calling-AE-name
+ (item-lookup 'Calling-AE-Title env t :A-Associate-RQ))
+ (ACN-name
+ (item-lookup 'ACN-Str env t
+ :Application-Context-Item :A-Associate-RQ))
+ (protocol-vn
+ (item-lookup 'Protocol-Version env t :A-Associate-RQ))
+ (called-IP-addr (socket:local-host tcp-strm))
+ (called-IP-string
+ (or (ignore-errors (socket:ipaddr-to-dotted called-IP-addr))
+ (format nil "~D" called-IP-addr)))
+ (called-AE-name
+ (item-lookup 'Called-AE-Title env t :A-Associate-RQ))
+ (SOP-class-name
+ (item-lookup 'Role-SOP-Class-UID-Str env nil
+ :SCP/SCU-Role-Item
+ :User-Information-Item
+ :A-Associate-RQ))
+ (callers *remote-entities*) (calleds *local-entities*) called
+ extra-args AE-OK? SOP-OK? (services-list *All-Services*))
+
+ "Stop timer, signal EVENT-07/08 if A-Associate-RQ acceptable or not"
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type list env callers extra-args calleds called services-list)
+ (type simple-base-string calling-IP-string called-IP-string
+ calling-AE-name called-AE-name ACN-name applic-context-name)
+ (type (member nil t) AE-OK?)
+ (type fixnum protocol-vn))
+
+ ;; Cache information for possible error logging.
+ (setq *calling-AE-name* calling-AE-name
+ *called-AE-name* called-AE-name
+ *SOP-class-name* SOP-class-name)
+
+ (cond
+ ((and
+ ;; Application Context Name correct.
+ (string= ACN-name applic-context-name)
+
+ ;; Protocol Version supported includes this version.
+ (= (logand #x0001 protocol-vn) #x0001)
+
+ ;; Calling AE Title is OK or Server is in promiscuous mode.
+ ;; IP address was checked for acceptability when connection was
+ ;; originally accepted by server. It is used here merely as an
+ ;; index to determine which AE Titles are possible matches.
+ (cond
+ ((null callers) ;Promiscuous mode - accept anybody.
+ (setq AE-OK? t))
+
+ ;; Not promiscuous - check for matching AE title.
+ ;; There may be different AE-Title entries with same IP address.
+ ;; Must therefore check all entries with matching IP addresses
+ ;; for match on AE-Title too, not just first as would be returned
+ ;; by ASSOC.
+ ((dolist (item callers nil)
+ (when (and (string= (first item) calling-IP-string)
+ (string= (second item) calling-AE-name))
+ ;; Each ITEM is of form:
+ ;; ( <IP-Address> <AE-Title> <Client-Name> <Patient-DB>
+ ;; <Matched-Pat-Im-DB> <Unmatched-Pat-Im-DB> <Structure-DB> )
+ ;; First three are required and rest are optional.
+ ;; Save optional args [if present] in EXTRA-ARGS [NIL otherwise].
+ (setq extra-args (cdddr item))
+ (setq AE-OK? t)
+ (return t))))
+
+ ;; Non-promiscuous mode and AE Title didn't pass muster.
+ (t nil))
+
+ ;; Called AE name OK (if discriminating on SCU's use of AE name).
+ (or (null calleds)
+ (setq called (assoc called-AE-name calleds :test #'string=)))
+
+ ;; If SOP-Class-UID-Str is not provided [it is optional in
+ ;; the :A-Associate-RQ PDU] accept. If provided, it must
+ ;; match one of the services Server is prepared to handle.
+ (setq SOP-OK?
+ (or (null SOP-class-name)
+ (member SOP-class-name services-list :test #'string=))))
+
+ (format t
+ #.(concatenate
+ 'string
+ "~%Accepting Association, ~A~% From: ~S (at ~A)~%"
+ " To: ~S (at ~A)~% Service: ~S~%")
+ (date/time)
+ calling-AE-name calling-IP-string called-AE-name
+ called-IP-string (or SOP-class-name "Unspecified"))
+
+ ;; Signal EVENT-07: A-Associate Response is ACCEPT.
+ (setq *event* 'event-07)
+
+ ;; Decide which database set to use. These variables are set once at
+ ;; association-acceptance time and used each time files are written on
+ ;; that association. Decision is made by taking default value from
+ ;; global variables set in configuration file unless overriden for this
+ ;; association by extra arguments in *REMOTE-ENTITIES* entry for this
+ ;; caller or by extra arguments in *LOCAL-ENTITIES* entry for this called.
+ (setq *patient-DB* (or (first extra-args)
+ (second called)
+ *patient-database*))
+ (setq *matched-pat-image-DB* (or (second extra-args)
+ (third called)
+ *matched-pat-image-database*))
+ (setq *unmatched-pat-image-DB* (or (third extra-args)
+ (fourth called)
+ *unmatched-pat-image-database*))
+ (setq *structure-DB* (or (fourth extra-args)
+ (fifth called)
+ *structure-database*))
+
+ ;; Decide which Presentation Contexts to accept.
+ (do ((pcs (set-lookup env :Presentation-Context-Item-RQ :A-Associate-RQ)
+ (cdr pcs))
+ (tsn *Transfer-Syntax-Name*)
+ (pc) (response-list '())
+ (asn-OK?) (tsn-OK?))
+ ((null pcs)
+ (setq *args* (list :Set (nreverse response-list))))
+
+ (declare (type list pcs tsn response-list))
+
+ ;; PCS is a LIST of Presentation Context structures each
+ ;; as a Variable-Value-Alist.
+ ;;
+ ;; PC is the <var-value-alist> [containing substructure] of each
+ ;; Presentation Context item in turn. Ie, it looks like a small
+ ;; local environment with values only for one Presentation Context.
+ (setq pc (car pcs))
+
+ ;; Check that Abstract Syntax Name for this Presentation
+ ;; Context matches one of the SOP names of a service.
+ (setq asn-OK? (member
+ (item-lookup 'ASN-Str pc t :Abstract-Syntax-Item-RQ)
+ services-list :test #'string=))
+
+ ;; Check that this Presentation Context contains a Transfer
+ ;; Syntax Name matching the NEMA default.
+ (setq tsn-OK?
+ (dolist (tsi (set-lookup pc :Transfer-Syntax-Item))
+ (when (string= (item-lookup 'TSN-Str tsi t) tsn)
+ (return t))))
+
+ (push `((PC-ID . ,(item-lookup 'PC-ID pc t))
+ (Result/Reason
+ . ,(cond ((and asn-OK? tsn-OK?)
+ 0) ;R/R = 0: Acceptance
+ ((not asn-OK?)
+ 1) ;R/R = 1: User-Rejection
+ (t 4)))) ;R/R = 4: Transfer-Syntax Not Supported
+ response-list)))
+
+ ;; Signal EVENT-08 [Association Rejected] and return
+ ;; rejection reasons as data to next action function.
+ (t (setq *event* 'event-08)
+ (format t
+ #.(concatenate
+ 'string
+ "~%Rejecting Association, ~A~% From: ~S (at ~A)~%"
+ " To: ~S (at ~A)~% Service: ~S~%")
+ (date/time)
+ calling-AE-name calling-IP-string called-AE-name
+ called-IP-string (or SOP-class-name "Unspecified"))
+
+ ;; All rejection reasons shown at Log level 0. Test specifically
+ ;; for each rejection condition so that correct reason is reported.
+ (cond
+ ((string/= ACN-name applic-context-name)
+ (format t "~& Reason: Bad Application-Context-Name.~%")
+ (format t "~& ACtx-Name: ~S~% Should be: ~S~%"
+ ACN-name applic-context-name)
+ ;; RJ-Result = 1: Rejection-Permanent
+ ;; RJ-Source = 1: UL Service-User
+ ;; RJ-Diagnostic = 2: Application-Context-Name Not Supported
+ (setq *args* '(RJ-Result 1 RJ-Source 1 RJ-Diagnostic 2)))
+
+ ((not AE-OK?)
+ (format t "~& Reason: Bad Calling AE Title: ~S~%" calling-AE-name)
+ ;; RJ-Result = 1: Rejection-Permanent
+ ;; RJ-Source = 1: UL Service-User
+ ;; RJ-Diagnostic = 3: Calling-AE-Title Not Recognized
+ (setq *args* '(RJ-Result 1 RJ-Source 1 RJ-Diagnostic 3)))
+
+ ((and (consp calleds) ;Discriminating on Called but
+ (null called)) ;item requested not found.
+ (format t "~& Reason: Bad Called AE Title: ~S~%" called-AE-name)
+ ;; RJ-Result = 1: Rejection-Permanent
+ ;; RJ-Source = 1: UL Service-User
+ ;; RJ-Diagnostic = 7: Called-AE-Title Not Recognized
+ (setq *args* '(RJ-Result 1 RJ-Source 1 RJ-Diagnostic 7)))
+
+ ((/= (logand #x0001 protocol-vn) #x0001)
+ (format t "~& Reason: Protocol Version not supported: ~S~%"
+ protocol-vn)
+ ;; RJ-Result = 1: Rejection-Permanent
+ ;; RJ-Source = 2: UL Service-Provider [ACSE]
+ ;; RJ-Diagnostic = 2: Protocol Version Not Supported
+ (setq *args* '(RJ-Result 1 RJ-Source 2 RJ-Diagnostic 2)))
+
+ ((not SOP-OK?)
+ (format t "~& Reason: SOP-Class-UID not supported: ~S~%"
+ SOP-class-name)
+ ;; RJ-Result = 1: Rejection-Permanent
+ ;; RJ-Source = 2: UL Service-Provider [ACSE]
+ ;; RJ-Diagnostic = 1: No Reason Given
+ (setq *args* '(RJ-Result 1 RJ-Source 2 RJ-Diagnostic 1)))
+
+ ;; This branch should never be taken, but it is here to catch errors
+ ;; that result in failure to trigger any of the above branches.
+ (t (format t "~& Reason: Unknown.~%")
+ ;; RJ-Result = 1: Rejection-Permanent
+ ;; RJ-Source = 2: UL Service-Provider [ACSE]
+ ;; RJ-Diagnostic = 1: No Reason Given
+ (setq *args* '(RJ-Result 1 RJ-Source 2 RJ-Diagnostic 1))))
+
+ (when (>= (the fixnum *log-level*) 2)
+ (report-error env tcp-buffer "Association Refused"))))
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ae-07 (env tcp-buffer tcp-strm)
+
+ "Issue A-Associate-AC message and send associated PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ ;; Client proposed max PDU size - accept it and cache minimum of that value
+ ;; and server's own maximum for all remaining PDUs during this association.
+ (let ((limit (item-lookup 'Max-DataField-Len env nil
+ :Max-DataField-Len-Item
+ :User-Information-Item
+ :A-Associate-RQ)))
+ (cond ((typep limit 'fixnum)
+ ;; Spec requires all P-Data-TF PDUs, and therefore all PDVs,
+ ;; to be of even length.
+ (unless (evenp (the fixnum limit))
+ (mishap env nil "AE-07 [1] Odd datafield length: ~S" limit))
+ (setq *max-datafield-len* (min (the fixnum limit) #.PDU-Bufsize)))
+ (t (setq *max-datafield-len* #.PDU-Bufsize))))
+
+ (when (>= (the fixnum *log-level*) 1)
+ (format t "~%AE-07: Server accepts A-Associate-RQ from Client.~%")
+ (format t "~&Max PDU size negotiated: ~D~%" *max-datafield-len*))
+
+ (apply #'send-pdu :A-Associate-AC env tcp-buffer tcp-strm *args*)
+
+ (setq *args* nil))
+
+;;;-------------------------------------------------------------
+
+(defun ae-08 (env tcp-buffer tcp-strm)
+
+ "Issue A-Associate-RJ message and send associated PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%AE-08: A-Associate rejected.~%"))
+
+ (apply #'send-pdu :A-Associate-RJ env tcp-buffer tcp-strm *args*)
+
+ (setq *args* nil))
+
+;;;=============================================================
+;;; Association Release Actions.
+
+(defun ar-04 (env tcp-buffer tcp-strm)
+
+ "Send A-Release-RSP PDU"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (send-pdu :A-Release-RSP env tcp-buffer tcp-strm)
+
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun ar-10 (env tcp-buffer tcp-strm)
+
+ "Issue A-Release confirmation message"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (ignore env tcp-buffer tcp-strm))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%AR-10: A-Release confirmation.~%"))
+
+ nil)
+
+;;;=============================================================
+;;; This version of REPORT-ERROR is specialized to Server functionality.
+;;; It includes global vars used only by Server.
+
+(defun report-error (env data &optional msg &rest format-args)
+
+ ;; Reports useful information [previously cached as values of global vars]
+ ;; to logging stream in case of run-time errors.
+
+ (declare (type list env format-args)
+ (type (or null simple-base-string) msg)
+ (type
+ (or null list (simple-array (unsigned-byte 8) (#.TCP-Bufsize)))
+ data))
+
+ (format t "~%REPORT-ERROR:~%")
+ (when (typep msg 'simple-base-string)
+ (apply #'cl:format t msg format-args))
+
+ ;; Date, Time:
+ (format t "~&~% Date/Time:~44T~A~%~%" (date/time))
+
+ ;; Identification of communication entities:
+ (format t "~& Remote IP Address:~44T~S~%" *remote-IP-string*)
+ (format t "~& Calling AE Name:~44T~S~%" *calling-AE-name*)
+ (format t "~& Called AE Name:~44T~S~%" *called-AE-name*)
+ (format t "~& Max PDU Size:~44T~S~%~%"*max-datafield-len*)
+
+ ;; Operation being performed:
+ (format t "~& SOP Class Name:~44T~S~%~%" *SOP-class-name*)
+
+ ;; State of PDU/Object parsers and protocol controller:
+ (format t "~& State:~44T~S (~A)~%" *state* (get *state* 'documentation))
+ (format t "~& Event:~44T~S (~A)~%" *event* (get *event* 'documentation))
+ (format t "~& Arguments:~44T~S~%~%" *args*)
+
+ ;; Next set of expressions are used only by Server. If the two versions
+ ;; of this function are merged [when Server invokes Client functionality
+ ;; as subservient system], make this form evaluate conditionally on *MODE*.
+ ;;
+ ;; Cached database selections:
+ (format t "~& Output Patient DB:~44T~S~%" *patient-DB*)
+ (format t "~& Output Matched Pat Image DB:~44T~S~%" *matched-pat-image-DB*)
+ (format t "~& Output Unmatched Pat Image DB:~44T~S~%"
+ *unmatched-pat-image-DB*)
+ (format t "~& Output Structure DB:~44T~S~%" *structure-DB*)
+ ;;
+ ;; Cached patient identification information:
+ (format t "~& Cached DICOM Name:~44T~S~%" *cached-dicom-pat-name*)
+ (format t "~& Cached Prism Name:~44T~S~%" *cached-prism-pat-name*)
+ (format t "~& Cached Dicom ID:~44T~S~%" *cached-dicom-pat-ID*)
+ (format t "~& Cached Prism ID:~44T~S~%" *cached-prism-pat-ID*)
+ (format t "~& Cached Image DB:~44T~S~%" *cached-image-DB*)
+ ;;
+ ;; Cached Image-Set identification information:
+ (format t "~& Cached DICOM Set ID:~44T~S~%" *cached-dicom-set-ID*)
+ (format t "~& Cached Prism Set ID:~44T~S~%~%" *cached-prism-set-ID*)
+ ;;
+ ;; Cached Image ID/UID information:
+ (format t "~& Images stored in this set:~44T~S~%"
+ *stored-image-count-per-set*)
+ (format t "~& ID/UID of images in current Image-Set:")
+ (cond ((consp *image-ID/UID-alist*)
+ (dolist (pair *image-ID/UID-alist*)
+ (format t "~&~44T~S~%" pair)))
+ (t (format t "~44TNone.~%")))
+ (format t "~& Images stored in this association:~44T~S~%"
+ *stored-image-count-cumulative*)
+ (format t "~%")
+ ;;
+ ;; Cached records to append to "image.index" file at end of association:
+ (format t "~& Current Image-Set record:~44T~S~%" *current-im-set-record*)
+ (format t "~& New \"image.index\" records:")
+ (cond ((consp *new-im-index-records*)
+ (dolist (record *new-im-index-records*)
+ (format t "~&~44T~S~%" record)))
+ (t (format t "~44TNone.~%")))
+ (format t "~%")
+ ;;
+ ;; End of Server-Only section.
+
+ ;; Status reports:
+ (format t "~& Status Message:~44T~S~%"
+ (or *status-message* "Unknown error"))
+ (format t "~& Status Code:~44T~S~%" *status-code*)
+
+ ;; State of current Environment:
+ (when (consp env)
+ (print-environment env))
+
+ (cond ((consp data)
+ ;; State of current list-structure object being constructed:
+ ;; PDU datalist is constructed backwards [items CONSed to front].
+ (format t "~% Output PDU or raw data:~% ~S~%" data))
+
+ ;; Contents of current TCP buffer:
+ ((arrayp data)
+ ;; This will dump any shifted bytes from prior PARSE-OBJECT call.
+ ;; New PDU will start at HEAD, which may be non-zero.
+ (dump-bytestream "TCP buffer" data 0 *PDU-tail*)))
+
+ ;; One more Server-Only section.
+ (when (consp *dicom-alist*)
+ (dump-dicom-data *dicom-alist* *standard-output*)))
+
+;;;=============================================================
+;;; Stubs. For now, these functions are used only by Client, but calls
+;;; to them appear [in non-invoked conditional branches] in Common code.
+
+(defun close-connection (tcp-strm)
+ (declare (ignore tcp-strm))
+ (mishap nil nil "CLOSE-CONNECTION called in Server."))
+
+(defun generate-object (object env output-itemlist)
+ (declare (ignore output-itemlist))
+ (mishap env object "GENERATE-OBJECT called in Server."))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/compiler.cl b/dicom/src/compiler.cl
new file mode 100644
index 0000000..9b800a6
--- /dev/null
+++ b/dicom/src/compiler.cl
@@ -0,0 +1,243 @@
+;;;
+;;; compiler
+;;;
+;;; Rule Compiler for State Table and Parsing/Generation Rules.
+;;; Contains functions common to Client and Server.
+;;;
+;;; 02-Mar-2002 BobGian functions embedded in rules moved here from
+;;; "utilities.cl".
+;;; Jul/Aug 2002 BobGian rename local var: RTP-COUNT -> REPEAT-COUNT.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; The run-time versions of rules comprise optimized and compiled
+;;; rule bodies stored as properties on the property lists of the symbols
+;;; naming the rule item types.
+
+(defun compile-rules (rules rule-type &aux tag-symbol
+ (pdutype-alist *Code/PDUtype-Alist*))
+
+ (declare (type list rules pdutype-alist)
+ (type symbol tag-symbol))
+
+ (dolist (rule rules)
+ (setq tag-symbol (first rule))
+ (setq rule
+ (mapcan
+ ;; Expander functions return the LIST of atomic terms
+ ;; that a complex term expression expands into. Must
+ ;; use MAPCAN to append them.
+ #'(lambda (term &aux key output)
+ (setq output
+ (cond
+ ((consp term)
+ (cond ((eq (setq key (first term)) '=fixnum-bytes)
+ (fixnum-bytes-expander (second term)
+ (third term)
+ (fourth term)))
+ ((eq key '=string-bytes)
+ (string-bytes-expander (second term)
+ (third term)
+ (fourth term)))
+ ((eq key '=constant-bytes)
+ (constant-bytes-expander (second term)
+ (third term)))
+ (t (list term))))
+ (t (list term))))
+ output)
+ rule))
+
+ ;; We store all rules as a property of the tag-symbol with the property
+ ;; named by RULE-TYPE value (:Parser-Rule or :Generator-Rule).
+ (setf (get tag-symbol rule-type)
+ (cond ((eq rule-type :Parser-Rule)
+ (cond ((member tag-symbol pdutype-alist :test #'eq :key #'cdr)
+ ;; For Parse rules for the seven basic PDU types,
+ ;; we parse the PDU length procedurally but represent
+ ;; it in the rule [for human readability] by an
+ ;; "(=IGNORED-BYTES 4)" term. Slice this plus the
+ ;; extra =IGNORED-BYTE always present from the run-time
+ ;; version of the rule. Also remove the PDU type code
+ ;; [second element], but leave the type tag [the first
+ ;; element, which PARSE-GROUP uses to tag the variable
+ ;; group for this item in environment].
+ (cons tag-symbol (cddddr rule)))
+
+ ;; For parser non-PDU item rules, leave rule as
+ ;; written. Must include the type tag and type code.
+ ;; This applies to subitem types and message types.
+ (t rule)))
+
+ ;; For all generation rules, remove only the type tag.
+ (t (cdr rule))))))
+
+;;;-------------------------------------------------------------
+
+(defun fixnum-bytes-expander (dataval datalen dataend)
+
+ (unless (typep dataval 'fixnum)
+ ;; Arbitrary Lisp form can be in DATAVAL slot.
+ (setq dataval (eval dataval)))
+
+ (unless (typep datalen 'fixnum)
+ ;; Arbitrary Lisp form can be in DATALEN slot -- not currently used.
+ (setq datalen (eval datalen)))
+
+ (unless (and (typep dataval 'fixnum)
+ (typep datalen 'fixnum)
+ (or (= (the fixnum datalen) 1)
+ ;; For 1 byte, DATAEND = NIL [ie, 3-element term] is OK.
+ (member dataend '(:Big-Endian :Little-Endian) :test #'eq)))
+ (error "FIXNUM-BYTES-EXPANDER [1] Bad args: ~S ~S ~S"
+ dataval datalen dataend))
+
+ (cond ((= (the fixnum datalen) 1)
+ (list (logand #x000000FF (the fixnum dataval))))
+
+ ((and (= (the fixnum datalen) 2)
+ (eq dataend :Big-Endian))
+ (list (ash (logand #x0000FF00 (the fixnum dataval)) -8)
+ (logand #x000000FF (the fixnum dataval))))
+
+ ((and (= (the fixnum datalen) 2)
+ (eq dataend :Little-Endian))
+ (list (logand #x000000FF (the fixnum dataval))
+ (ash (logand #x0000FF00 (the fixnum dataval)) -8)))
+
+ ((and (= (the fixnum datalen) 4)
+ (eq dataend :Big-Endian))
+ ;; Largest mask really should be #xFF000000, but using smaller value
+ ;; keeps it a POSITIVE FIXNUM, and no value will exceed 536870911.
+ (list (ash (logand #x1F000000 (the fixnum dataval)) -24)
+ (ash (logand #x00FF0000 (the fixnum dataval)) -16)
+ (ash (logand #x0000FF00 (the fixnum dataval)) -8)
+ (logand #x000000FF (the fixnum dataval))))
+
+ ((and (= (the fixnum datalen) 4)
+ (eq dataend :Little-Endian))
+ ;; Largest mask really should be #xFF000000, but using smaller value
+ ;; keeps it a POSITIVE FIXNUM, and no value will exceed 536870911.
+ (list (logand #x000000FF (the fixnum dataval))
+ (ash (logand #x0000FF00 (the fixnum dataval)) -8)
+ (ash (logand #x00FF0000 (the fixnum dataval)) -16)
+ (ash (logand #x1F000000 (the fixnum dataval)) -24)))
+
+ (t (error "FIXNUM-BYTES-EXPANDER [2] Bad values: ~S ~S ~S"
+ dataval datalen dataend))))
+
+;;;-------------------------------------------------------------
+;;; :Space-Pad is nowhere used but is included here for completeness.
+
+(defun string-bytes-expander (dataval datalen string-padding &aux (strlen 0))
+
+ (declare (type fixnum strlen))
+
+ (unless (typep dataval 'simple-base-string)
+ ;; Arbitrary Lisp form can be in DATAVAL slot.
+ (setq dataval (eval dataval)))
+
+ (unless (typep datalen 'fixnum)
+ ;; Arbitrary Lisp form can be in DATALEN slot.
+ (setq datalen (eval datalen)))
+
+ (unless (and (typep dataval 'simple-base-string)
+ (typep datalen 'fixnum)
+ (member string-padding '(:No-Pad :Null-Pad #+ignore :Space-Pad)
+ :test #'eq)
+ (<= (setq strlen (length (the simple-base-string dataval)))
+ (the fixnum datalen)))
+ (error "STRING-BYTES-EXPANDER [1] Bad args: ~S ~S ~S"
+ dataval datalen string-padding))
+
+ (do ((idx (the fixnum (1- strlen)) (the fixnum (1- idx)))
+ (output (cond ((eq string-padding :No-Pad)
+ '())
+ ((eq string-padding :Null-Pad)
+ (cond ((oddp strlen)
+ (list 0))
+ (t '())))
+ #+ignore
+ ((and (eq string-padding :Space-Pad)
+ (< strlen (the fixnum datalen)))
+ (make-list (the fixnum (- datalen strlen))
+ :initial-element #.(char-code #\Space)))
+ (t '()))))
+ ((< idx 0)
+ output)
+
+ (declare (type list output)
+ (type fixnum idx))
+
+ (push (char-code (aref (the simple-base-string dataval) idx)) output)))
+
+;;;-------------------------------------------------------------
+
+(defun constant-bytes-expander (byte-value repeat-count)
+
+ (unless (and (typep byte-value 'fixnum)
+ (typep repeat-count 'fixnum))
+ (error "CONSTANT-BYTES-EXPANDER [1] Bad args: ~S ~S"
+ byte-value repeat-count))
+
+ (do ((cnt 0 (the fixnum (1+ cnt)))
+ (output '()))
+ ((= cnt (the fixnum repeat-count))
+ output)
+
+ (declare (type list output)
+ (type fixnum cnt))
+
+ (push (the fixnum byte-value) output)))
+
+;;;-------------------------------------------------------------
+
+(defun compile-states (rules)
+
+ (declare (type list rules))
+
+ (dolist (rule-packet rules)
+ (let ((state (first rule-packet))
+ (doc (second rule-packet)))
+ (setf (get state 'documentation) doc)
+ (dolist (rule (cddr rule-packet))
+ (let ((actions (cdr rule)))
+ (dolist (event (car rule))
+ (setf (get state event) actions)))))))
+
+;;;=============================================================
+;;; Functions Embedded in Rules for DICOM Message Interpretation.
+
+;;; This function computes an even length [rounding up for odd lengths]
+;;; for a string which is to be encoded using :Null-Pad -- all UIDs other
+;;; than when used in A-Associate-RQ and A-Associate-AC rules.
+
+(defun even-length (str &aux (len (length str)))
+
+ (declare (type simple-base-string str)
+ (type fixnum len))
+
+ (cond ((oddp len)
+ (the fixnum (1+ len)))
+ (t len)))
+
+;;;-------------------------------------------------------------
+;;; This function also serves as a variable value predicate embedded
+;;; in generation rules.
+
+(defun item-present? (access-chain env)
+
+ (declare (type list access-chain env))
+
+ (cond
+ ((null access-chain)
+ (mishap env nil "ITEM-PRESENT? [1] Null access-chain."))
+ ((null (cdr access-chain))
+ (assoc (car access-chain) env :test #'eq))
+ (t (assoc (car access-chain) (cdr (item-present? (cdr access-chain) env))
+ :test #'eq))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/dicom.cl b/dicom/src/dicom.cl
new file mode 100644
index 0000000..2e9aa9a
--- /dev/null
+++ b/dicom/src/dicom.cl
@@ -0,0 +1,195 @@
+;;;
+;;; dicom - contains package definition and common globals
+;;;
+;;; 20-Jun-2009 I. Kalet created from dicom-common.system
+;;; 16-Sep-2009 I. Kalet add requires to avoid autoloading in
+;;; standalone system with ACL.
+;;; 5-Oct-2009 I. Kalet add streama to requires.
+;;; 18-Jul-2011 I. Kalet move export for dicom package here from
+;;; wrapper-client.
+;;;
+
+;;;=============================================================
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :acldns) ;; needed for network connections
+ (require :ssl)) ;; and encryption
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :streama) ;; testing shows this is needed
+ (require :streamc)) ;; also needed for extended stream I/O
+
+;;;=============================================================
+;;; Package definitions.
+
+(defpackage :dicom
+ (:use :common-lisp)
+ (:export "RUN-CLIENT"))
+
+(defpackage :prism
+ (:nicknames "PR")
+ (:use :common-lisp)
+ (:export "ACQ-DATE" "ACQ-TIME"
+ "CONTOUR" "CONTOURS"
+ "DESCRIPTION" "DISPLAY-COLOR"
+ "HOSP-NAME"
+ "ID" "IMAGE-2D" "IMAGE-SET-ID" "IMG-TYPE"
+ "NAME"
+ "ORGAN" "ORIGIN"
+ "PATIENT-ID" "PAT-POS" "PIX-PER-CM" "PIXELS"
+ "RANGE"
+ "SCANNER-TYPE" "SIZE"
+ "TARGET" "THICKNESS" "TUMOR"
+ "UID" "UNITS"
+ "VERTICES"
+ "X-ORIENT"
+ "Y-ORIENT"
+ "Z"
+ ))
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; System Constants -- not user-configurable.
+
+;;; TCP-Buffer must be larger than max PDU datafield size by enough to hold
+;;; all the PDU bytes outside the datafield or message plus any shifted bytes
+;;; left over from parsing a prior fragment.
+(defconstant PDU-Bufsize 65536) ;Max PDU DataField Length
+
+;;; Include 1 KB for leeway.
+(defconstant TCP-Bufsize (+ PDU-Bufsize PDU-Bufsize 1024))
+
+;;;=============================================================
+;;; Dicom Upper Layer State Variables.
+;;; These special variables define the DUL state and are all bound on server
+;;; connection acceptance or client invocation so PDS can stack state and run
+;;; a client as a subsystem of the server.
+
+(defvar *mode* nil) ; :Client or :Server - on per-association basis
+(defvar *state* nil) ;Current state as symbol
+(defvar *event* nil) ;Activating event as symbol
+(defvar *args* nil) ;Communication between action functions
+(defvar *remote-IP-string* nil) ;Remembered far-end IP Address for logging
+
+(defvar *calling-AE-name* nil) ;Remembered AE name for logging
+(defvar *called-AE-name* nil) ;Remembered AE name for logging
+(defvar *SOP-class-name* nil) ;Remembered SOP class for logging
+
+(defvar *max-datafield-len* nil) ;Max size to use for PDU
+
+(defvar *status-code* nil) ;NIL or fixnum - reported by client
+(defvar *status-message* nil) ;NIL or string - reported by client
+
+;;; Continuation object for PARSE-OBJECT in case it must be suspended
+;;; and restarted due to PDU fragmentation during parse of an object.
+(defvar *parser-state* nil)
+
+;;; Stream Client opens to Server. Used in common code, so must
+;;; be declared in common and bound by both Client and Server.
+(defvar *connection-strm* nil)
+
+;;; Common SSL variables
+(defvar *use-ssl* nil)
+(defvar *ssl-port* 2762)
+(defvar *certificate* "/radonc/prism/cacert.pem")
+(defvar *private-key* "/radonc/prism/privkey.pem")
+
+;;; Stores environment checkpointed at start of cmd execution for restoration
+;;; at end [to prevent environment overgrowth on successive commands].
+(defvar *checkpointed-environment* nil)
+
+;;; PDU end index passed to REPORT-ERROR to bracket relevant portion
+;;; of TCP buffer for error reporting. Start index is always zero.
+(defvar *PDU-tail* 0)
+
+;;; Handle on parsed Dicom header data for error-reporting functions.
+;;; Must be bound outside main loop in case error happens there.
+(defvar *dicom-alist* nil)
+
+;;; Ranges for Group numbers to be ignored when parsing objects:
+;;; Value NIL -> ignore no ranges [group not found in dictionary -> error].
+;;; Otherwise list of CONS pairs where CAR is an inclusive lower bound
+;;; and CDR is an exclusive upper bound. For example, the value
+;;; (( #x5000 . #x5100 ) ( #x6000 . #x6100 ))
+;;; causes the 50xx and 60xx ranges to be logged and ignored.
+(defvar *ignorable-groups-list* nil)
+
+;;;=============================================================
+;;; System Parameters -- not user-configurable.
+
+;;; Don't do name-server lookup when printing stream;
+;;; takes time, and most hosts don't have names anyway.
+(defparameter socket:*print-hostname-in-stream* nil)
+
+;;; Specified by DICOM Standard -- not configurable.
+(defparameter *Echo-Verification-Service* "1.2.840.10008.1.1")
+(defparameter *Structure-Set-Storage-Service* "1.2.840.10008.5.1.4.1.1.481.3")
+(defparameter *RTPlan-Storage-Service* "1.2.840.10008.5.1.4.1.1.481.5")
+
+;;; Codes for the seven basic PDU types.
+(defparameter *Code/PDUtype-Alist*
+ '((#x01 . :A-Associate-RQ)
+ (#x02 . :A-Associate-AC)
+ (#x03 . :A-Associate-RJ)
+ (#x04 . :P-Data-TF)
+ (#x05 . :A-Release-RQ)
+ (#x06 . :A-Release-RSP)
+ (#x07 . :A-Abort)))
+
+(defparameter *Image-Storage-Services*
+ (list "1.2.840.10008.5.1.4.1.1.1" ;Computed Radiography
+ "1.2.840.10008.5.1.4.1.1.128" ;PET-Image-Storage-Service
+ "1.2.840.10008.5.1.4.1.1.2" ;CT-Image-Storage-Service
+ "1.2.840.10008.5.1.4.1.1.4" ;MR-Image-Storage-Service
+ "1.2.840.10008.5.1.4.1.1.6" ;US-Image-Storage [Retired]
+ "1.2.840.10008.5.1.4.1.1.6.1" ;US-Image-Storage-Service
+ ))
+
+(defparameter *Object-Storage-Services* ;C-Store SOP classes
+ (append *Image-Storage-Services*
+ (list *Structure-Set-Storage-Service*
+ *RTPlan-Storage-Service*)))
+
+(defparameter *All-Services* ;All Server-supported SOP classes
+ (list* *Echo-Verification-Service*
+ "1.2.840.10008.1.20.1" ;Faking Storage Commitment SOP [Push Model]
+ *Object-Storage-Services*))
+
+;(defparameter *Service-Dispatch-Table*
+; `(()))
+
+(defparameter *Application-Context-Name* "1.2.840.10008.3.1.1.1")
+(defparameter *Transfer-Syntax-Name* "1.2.840.10008.1.2")
+
+;;;=============================================================
+;;; Version name and UID applicable to Prism Dicom System.
+;;; Used in both Server and Client but slightly different values in
+;;; each. Set in run-server and run-client.
+
+(defvar *Implementation-Version-Name* "")
+(defvar *Implementation-Class-UID* "")
+
+;;;=============================================================
+;;; System Parameters -- Configurable via "pds.config" file in directory
+;;; "/radonc/prism" for the server. For the client, any parameters overriding
+;;; defaults are configured in "/radonc/prism/prism.config".
+
+(defvar *artim-timeout* 300) ;5 minutes
+
+;;; Logging goes to Standard-Output, which is background window if PDS is run
+;;; in Prism [as Client] or can be redirected to a file if PDS is run as a
+;;; background job [as Server].
+;;;
+;;; Level is set to 2 for the Prism Client for current testing - probably will
+;;; be set to zero for ultimate value.
+;;;
+;;; Set Log Level for Server in config file "pds.config".
+;;;
+(defvar *log-level* 0) ;Logging detail level: 0, 1, 2, 3, or 4.
+
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/dicom.cl~ b/dicom/src/dicom.cl~
new file mode 100644
index 0000000..5e06ad1
--- /dev/null
+++ b/dicom/src/dicom.cl~
@@ -0,0 +1,195 @@
+;;;
+;;; dicom - contains package definition and common globals
+;;;
+;;; 20-Jun-2009 I. Kalet created from dicom-common.system
+;;; 16-Sep-2009 I. Kalet add requires to avoid autoloading in
+;;; standalone system with ACL.
+;;; 5-Oct-2009 I. Kalet add streama to requires.
+;;; 17-Jul-2011 I. Kalet move export for dicom package here from
+;;; wrapper-client.
+;;;
+
+;;;=============================================================
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :acldns) ;; needed for network connections
+ (require :ssl)) ;; and encryption
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :streama) ;; testing shows this is needed
+ (require :streamc)) ;; also needed for extended stream I/O
+
+;;;=============================================================
+;;; Package definitions.
+
+(defpackage :dicom
+ (:use :common-lisp)
+ (export "RUN-CLIENT"))
+
+(defpackage :prism
+ (:nicknames "PR")
+ (:use :common-lisp)
+ (:export "ACQ-DATE" "ACQ-TIME"
+ "CONTOUR" "CONTOURS"
+ "DESCRIPTION" "DISPLAY-COLOR"
+ "HOSP-NAME"
+ "ID" "IMAGE-2D" "IMAGE-SET-ID" "IMG-TYPE"
+ "NAME"
+ "ORGAN" "ORIGIN"
+ "PATIENT-ID" "PAT-POS" "PIX-PER-CM" "PIXELS"
+ "RANGE"
+ "SCANNER-TYPE" "SIZE"
+ "TARGET" "THICKNESS" "TUMOR"
+ "UID" "UNITS"
+ "VERTICES"
+ "X-ORIENT"
+ "Y-ORIENT"
+ "Z"
+ ))
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; System Constants -- not user-configurable.
+
+;;; TCP-Buffer must be larger than max PDU datafield size by enough to hold
+;;; all the PDU bytes outside the datafield or message plus any shifted bytes
+;;; left over from parsing a prior fragment.
+(defconstant PDU-Bufsize 65536) ;Max PDU DataField Length
+
+;;; Include 1 KB for leeway.
+(defconstant TCP-Bufsize (+ PDU-Bufsize PDU-Bufsize 1024))
+
+;;;=============================================================
+;;; Dicom Upper Layer State Variables.
+;;; These special variables define the DUL state and are all bound on server
+;;; connection acceptance or client invocation so PDS can stack state and run
+;;; a client as a subsystem of the server.
+
+(defvar *mode* nil) ; :Client or :Server - on per-association basis
+(defvar *state* nil) ;Current state as symbol
+(defvar *event* nil) ;Activating event as symbol
+(defvar *args* nil) ;Communication between action functions
+(defvar *remote-IP-string* nil) ;Remembered far-end IP Address for logging
+
+(defvar *calling-AE-name* nil) ;Remembered AE name for logging
+(defvar *called-AE-name* nil) ;Remembered AE name for logging
+(defvar *SOP-class-name* nil) ;Remembered SOP class for logging
+
+(defvar *max-datafield-len* nil) ;Max size to use for PDU
+
+(defvar *status-code* nil) ;NIL or fixnum - reported by client
+(defvar *status-message* nil) ;NIL or string - reported by client
+
+;;; Continuation object for PARSE-OBJECT in case it must be suspended
+;;; and restarted due to PDU fragmentation during parse of an object.
+(defvar *parser-state* nil)
+
+;;; Stream Client opens to Server. Used in common code, so must
+;;; be declared in common and bound by both Client and Server.
+(defvar *connection-strm* nil)
+
+;;; Common SSL variables
+(defvar *use-ssl* nil)
+(defvar *ssl-port* 2762)
+(defvar *certificate* "/radonc/prism/cacert.pem")
+(defvar *private-key* "/radonc/prism/privkey.pem")
+
+;;; Stores environment checkpointed at start of cmd execution for restoration
+;;; at end [to prevent environment overgrowth on successive commands].
+(defvar *checkpointed-environment* nil)
+
+;;; PDU end index passed to REPORT-ERROR to bracket relevant portion
+;;; of TCP buffer for error reporting. Start index is always zero.
+(defvar *PDU-tail* 0)
+
+;;; Handle on parsed Dicom header data for error-reporting functions.
+;;; Must be bound outside main loop in case error happens there.
+(defvar *dicom-alist* nil)
+
+;;; Ranges for Group numbers to be ignored when parsing objects:
+;;; Value NIL -> ignore no ranges [group not found in dictionary -> error].
+;;; Otherwise list of CONS pairs where CAR is an inclusive lower bound
+;;; and CDR is an exclusive upper bound. For example, the value
+;;; (( #x5000 . #x5100 ) ( #x6000 . #x6100 ))
+;;; causes the 50xx and 60xx ranges to be logged and ignored.
+(defvar *ignorable-groups-list* nil)
+
+;;;=============================================================
+;;; System Parameters -- not user-configurable.
+
+;;; Don't do name-server lookup when printing stream;
+;;; takes time, and most hosts don't have names anyway.
+(defparameter socket:*print-hostname-in-stream* nil)
+
+;;; Specified by DICOM Standard -- not configurable.
+(defparameter *Echo-Verification-Service* "1.2.840.10008.1.1")
+(defparameter *Structure-Set-Storage-Service* "1.2.840.10008.5.1.4.1.1.481.3")
+(defparameter *RTPlan-Storage-Service* "1.2.840.10008.5.1.4.1.1.481.5")
+
+;;; Codes for the seven basic PDU types.
+(defparameter *Code/PDUtype-Alist*
+ '((#x01 . :A-Associate-RQ)
+ (#x02 . :A-Associate-AC)
+ (#x03 . :A-Associate-RJ)
+ (#x04 . :P-Data-TF)
+ (#x05 . :A-Release-RQ)
+ (#x06 . :A-Release-RSP)
+ (#x07 . :A-Abort)))
+
+(defparameter *Image-Storage-Services*
+ (list "1.2.840.10008.5.1.4.1.1.1" ;Computed Radiography
+ "1.2.840.10008.5.1.4.1.1.128" ;PET-Image-Storage-Service
+ "1.2.840.10008.5.1.4.1.1.2" ;CT-Image-Storage-Service
+ "1.2.840.10008.5.1.4.1.1.4" ;MR-Image-Storage-Service
+ "1.2.840.10008.5.1.4.1.1.6" ;US-Image-Storage [Retired]
+ "1.2.840.10008.5.1.4.1.1.6.1" ;US-Image-Storage-Service
+ ))
+
+(defparameter *Object-Storage-Services* ;C-Store SOP classes
+ (append *Image-Storage-Services*
+ (list *Structure-Set-Storage-Service*
+ *RTPlan-Storage-Service*)))
+
+(defparameter *All-Services* ;All Server-supported SOP classes
+ (list* *Echo-Verification-Service*
+ "1.2.840.10008.1.20.1" ;Faking Storage Commitment SOP [Push Model]
+ *Object-Storage-Services*))
+
+;(defparameter *Service-Dispatch-Table*
+; `(()))
+
+(defparameter *Application-Context-Name* "1.2.840.10008.3.1.1.1")
+(defparameter *Transfer-Syntax-Name* "1.2.840.10008.1.2")
+
+;;;=============================================================
+;;; Version name and UID applicable to Prism Dicom System.
+;;; Used in both Server and Client but slightly different values in
+;;; each. Set in run-server and run-client.
+
+(defvar *Implementation-Version-Name* "")
+(defvar *Implementation-Class-UID* "")
+
+;;;=============================================================
+;;; System Parameters -- Configurable via "pds.config" file in directory
+;;; "/radonc/prism" for the server. For the client, any parameters overriding
+;;; defaults are configured in "/radonc/prism/prism.config".
+
+(defvar *artim-timeout* 300) ;5 minutes
+
+;;; Logging goes to Standard-Output, which is background window if PDS is run
+;;; in Prism [as Client] or can be redirected to a file if PDS is run as a
+;;; background job [as Server].
+;;;
+;;; Level is set to 2 for the Prism Client for current testing - probably will
+;;; be set to zero for ultimate value.
+;;;
+;;; Set Log Level for Server in config file "pds.config".
+;;;
+(defvar *log-level* 0) ;Logging detail level: 0, 1, 2, 3, or 4.
+
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/dictionary.cl b/dicom/src/dictionary.cl
new file mode 100644
index 0000000..c06ee78
--- /dev/null
+++ b/dicom/src/dictionary.cl
@@ -0,0 +1,2412 @@
+;;;
+;;; dictionary
+;;;
+;;; Dictionary of DICOM Object Group/Element Codes, Symbols, and Names.
+;;; Contains declarations common to Client and Server.
+;;;
+;;; 18-Jan-2001 BobGian add dummy entries for 0040:0244, 0040:0245, 0040:0253,
+;;; and 0040;0254, sent by our scanners but not in this table originally.
+;;; 19-Jan-2001 BobGian add missing entry [Group FFFE: DILIM "Delimiters"]
+;;; to *GROUPNAME-ALIST*.
+;;; 22-Apr-2002 BobGian "Other Byte" datatype :No-Pad -> :Null-Pad.
+;;; 21-Aug-2002 BobGian add new slots, as per standard update of Sept 1999:
+;;; ((#x3006 . #x0048) IS "Contour Number")
+;;; ((#x3006 . #x0049) IS "Attached Contours")
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; Spelling: ((#x300C . #x0051) IS "Referenced Dose Reference Number")
+;;; 31-Oct-2003 BobGian
+;;; Spelling: ((#x300A . #x010C) DS "Cumulative Dose Reference Coefficient")
+;;; 21-Dec-2003 BobGian: Add IE ("Ignorable Element") as datatype for field
+;;; to be ignored by object parser.
+;;; 11-Oct-2004 BobGian added missing dictionary entries [data from Dicom
+;;; standard PS 3.6-2003]: 0040:000A, 0040:000B, 0040:0020, 0040:0220,
+;;; and 0040:0241 through 0040:0340 [with some gaps].
+;;; 01-Nov-2004 BobGian regenerated entire database from 2004 edition of std.
+;;; 03-Nov-2004 BobGian flushed symbol naming group from *GROUPNAME-ALIST*
+;;; while preserving group tag and string name. Symbol was used only
+;;; in error messages.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+(defparameter *datatype-alist*
+ '((AE "Application Entity" (string 0 16) :Space-Pad)
+ (AS "Age String" (string 4) :No-Pad)
+ (AT "Attribute Tag" (fixnum 4))
+ (CS "Code String" (string 0 16) :Space-Pad)
+ (DA "Date" (string 8) :No-Pad)
+ (DS "Decimal String" (string 0 16) :Space-Pad)
+ (DT "Date/Time String" (string 0 26) :Space-Pad)
+ (FD "Floating-Point Double" (double-float 8))
+ (FL "Floating-Point Single" (single-float 4))
+ (IE "Ignorable Element" (string 0 *) :Space-Pad)
+ (IS "Integer String" (string 0 12) :Space-Pad)
+ (IT "Item in Sequence")
+ (ITDL "Item Delimiter")
+ (LO "Long String" (string 0 64) :Space-Pad)
+ (LT "Long Text" (string 0 10240) :Space-Pad)
+ (MD "Missing Definition" (string 0 *) :Space-Pad)
+ (OB "Other Byte" ((unsigned-byte 8) 0 *) :Null-Pad)
+ (OF "Other Float" (single-float 4))
+ (OW "Other Word" ((unsigned-byte 16) 0 *) :No-Pad)
+ (PE "Private Element" (string 0 *) :Space-Pad)
+ (PN "Person Name" (string 0 64) :Space-Pad)
+ (RET "Retired" (string 0 *) :Space-Pad)
+ (SH "Short String" (string 0 16) :Space-Pad)
+ (SL "Signed Long" (fixnum 4))
+ (SQ "Sequence of Items")
+ (SQDL "Sequence Delimiter")
+ (SS "Signed Short" (fixnum 2))
+ (SS/US "Signed/Unsigned Short" (fixnum 2))
+ (ST "Short Text" (string 0 1024) :Space-Pad)
+ (TM "Time String" (string 0 16) :Space-Pad)
+ (UI "Unique Identifier" (string 0 64) :Null-Pad)
+ (UL "Unsigned Long" (fixnum 4))
+ (US "Unsigned Short" (fixnum 2))
+ (UT "Unlimited Text" (string 0 2000000000) :Space-Pad)
+ ))
+
+;;;-------------------------------------------------------------
+
+(defparameter *groupname-alist*
+ '((#x0000 "Command")
+ (#x0002 "File Meta")
+ (#x0004 "Basic Directory Information")
+ (#x0008 "Identifying")
+ (#x0010 "Patient Information")
+ (#x0012 "Clinical Trial")
+ (#x0018 "Acquisition")
+ (#x0020 "Relationship")
+ (#x0022 "Light Path")
+ (#x0028 "Image")
+ (#x0032 "Study")
+ (#x0038 "Visit")
+ (#x003A "Waveform")
+ (#x0040 "Procedure Step")
+ (#x0050 "Device")
+ (#x0054 "NM Image")
+ (#x0060 "Histogram")
+ (#x0070 "Graphic")
+ (#x0088 "Media")
+ (#x0100 "Authorization")
+ (#x0400 "Encryption")
+ (#x2000 "Basic Film Session")
+ (#x2010 "Basic Film Box")
+ (#x2020 "Basic Image Box")
+ (#x2030 "Basic Annotation Box")
+ (#x2040 "Basic Image Overlay Box")
+ (#x2050 "Look-Up Table")
+ (#x2100 "Print Job")
+ (#x2110 "Printer")
+ (#x2120 "Print Queue")
+ (#x2130 "Print Management")
+ (#x2200 "Media Label")
+ (#x3002 "Radiation Treatment")
+ (#x3004 "Dose Volume Histogram")
+ (#x3006 "Structure Set")
+ (#x3008 "Dose")
+ (#x300A "Radiation Treatment Plan")
+ (#x300C "Referenced Radiation Treatment Plan")
+ (#x300E "Review")
+ (#x4000 "Comments")
+ (#x4008 "Results")
+ (#x4FFE "MAC Parameters")
+ (#x5000 "Curve")
+ (#x5200 "Functional Groups")
+ (#x5400 "Waveform Sequence")
+ (#x5600 "Spectroscopy")
+ (#x6000 "Overlay")
+ (#x7FE0 "Pixel")
+ (#xFFFA "Digital Signature")
+ (#xFFFC "Padding")
+ (#xFFFE "Delimiters")
+ ))
+
+;;;-------------------------------------------------------------
+
+(defparameter *group/elemname-alist*
+
+ ;;---------------------------------------------
+ ;; Group 0000: "Command"
+ '(((#x0000 . #x0000) UL "Group Length")
+ ((#x0000 . #x0002) UI "Affected SOP Class UID")
+ ((#x0000 . #x0003) UI "Requested SOP Class UID")
+ ((#x0000 . #x0100) US "Command Field")
+ ((#x0000 . #x0110) US "Message ID")
+ ((#x0000 . #x0120) US "Message ID Responded To")
+ ((#x0000 . #x0600) AE "Move Destination")
+ ((#x0000 . #x0700) US "Priority")
+ ((#x0000 . #x0800) US "Data Set Type")
+ ((#x0000 . #x0900) US "Status")
+ ((#x0000 . #x0901) AT "Offending Element")
+ ((#x0000 . #x0902) LO "Error Comment")
+ ((#x0000 . #x0903) US "Error ID")
+ ((#x0000 . #x1000) UI "SOP Affected Instance UID")
+ ((#x0000 . #x1001) UI "SOP Requested Instance UID")
+ ((#x0000 . #x1002) US "Event Type ID")
+ ((#x0000 . #x1005) AT "Attribute Identifier List")
+ ((#x0000 . #x1008) US "Action Type ID")
+ ((#x0000 . #x1020) US "Remaining Suboperations")
+ ((#x0000 . #x1021) US "Completed Suboperations")
+ ((#x0000 . #x1022) US "Failed Suboperations")
+ ((#x0000 . #x1023) US "Warning Suboperations")
+ ((#x0000 . #x1030) AE "AE Title")
+ ((#x0000 . #x1031) US "Message ID")
+
+ ;;---------------------------------------------
+ ;; Group 0002: "File Meta"
+ ((#x0002 . #x0000) UL "Group Length")
+ ((#x0002 . #x0001) OB "File Meta Information Version")
+ ((#x0002 . #x0002) UI "Media Storage SOP Class UID")
+ ((#x0002 . #x0003) UI "Media Storage SOP Instance UID")
+ ((#x0002 . #x0010) UI "Transfer Syntax UID")
+ ((#x0002 . #x0012) UI "Implementation Class UID")
+ ((#x0002 . #x0013) SH "Implementation Version Name")
+ ((#x0002 . #x0016) AE "Source Application Entity Title")
+ ((#x0002 . #x0100) UI "Private Information Creator UID")
+ ((#x0002 . #x0102) OB "Private Information")
+
+ ;;---------------------------------------------
+ ;; Group 0004: "Basic Directory Information"
+ ((#x0004 . #x0000) UL "Group Length")
+ ((#x0004 . #x1130) CS "File-set ID")
+ ((#x0004 . #x1141) CS "File-set Descriptor File ID")
+ ((#x0004 . #x1142) CS "Specific Character Set of File-set Descriptor File")
+ ((#x0004 . #x1200) UL "Offset of the First Directory Record of the Root Directory Entity")
+ ((#x0004 . #x1202) UL "Offset of the Last Directory Record of the Root Directory Entity")
+ ((#x0004 . #x1212) US "File-set Consistency Flag")
+ ((#x0004 . #x1220) SQ "Directory Record Sequence")
+ ((#x0004 . #x1400) UL "Offset of the Next Directory Record")
+ ((#x0004 . #x1410) US "Record In-use Flag")
+ ((#x0004 . #x1420) UL "Offset of Referenced Lower-Level Directory Entity")
+ ((#x0004 . #x1430) CS "Directory Record Type")
+ ((#x0004 . #x1432) UI "Private Record UID")
+ ((#x0004 . #x1500) CS "Referenced File ID")
+ ((#x0004 . #x1504) UL "MRDR Directory Record Offset")
+ ((#x0004 . #x1510) UI "Referenced SOP Class UID in File")
+ ((#x0004 . #x1511) UI "Referenced SOP Instance UID in File")
+ ((#x0004 . #x1512) UI "Referenced Transfer Syntax UID in File")
+ ((#x0004 . #x151A) UI "Referenced Related General SOP Class UID in File")
+ ((#x0004 . #x1600) UL "Number of References")
+
+ ;;---------------------------------------------
+ ;; Group 0008: "Identifying"
+ ((#x0008 . #x0000) UL "Group Length")
+ ((#x0008 . #x0001) RET "Length to End (RET)")
+ ((#x0008 . #x0005) CS "Specific Character Set")
+ ((#x0008 . #x0008) CS "Image Type")
+ ((#x0008 . #x0010) RET "Recognition Code (RET)")
+ ((#x0008 . #x0012) DA "Instance Creation Date")
+ ((#x0008 . #x0013) TM "Instance Creation Time")
+ ((#x0008 . #x0014) UI "Instance Creator UID")
+ ((#x0008 . #x0016) UI "SOP Class UID")
+ ((#x0008 . #x0018) UI "SOP Instance UID")
+ ((#x0008 . #x001A) UI "Related General SOP Class UID")
+ ((#x0008 . #x001B) UI "Original Specialized SOP Class UID")
+ ((#x0008 . #x0020) DA "Study Date")
+ ((#x0008 . #x0021) DA "Series Date")
+ ((#x0008 . #x0022) DA "Acquisition Date")
+ ((#x0008 . #x0023) DA "Content Date")
+ ((#x0008 . #x0024) DA "Overlay Date")
+ ((#x0008 . #x0025) DA "Curve Date")
+ ((#x0008 . #x002A) DT "Acquisition Datetime")
+ ((#x0008 . #x0030) TM "Study Time")
+ ((#x0008 . #x0031) TM "Series Time")
+ ((#x0008 . #x0032) TM "Acquisition Time")
+ ((#x0008 . #x0033) TM "Content Time")
+ ((#x0008 . #x0034) TM "Overlay Time")
+ ((#x0008 . #x0035) TM "Curve Time")
+ ((#x0008 . #x0040) RET "Data Set Type (RET)")
+ ((#x0008 . #x0041) RET "Data Set Subtype (RET)")
+ ((#x0008 . #x0042) RET "Nuclear Medicine Series Type (RET)")
+ ((#x0008 . #x0050) SH "Accession Number")
+ ((#x0008 . #x0052) CS "Query/Retrieve Level")
+ ((#x0008 . #x0054) AE "Retrieve AE Title")
+ ((#x0008 . #x0056) CS "Instance Availability")
+ ((#x0008 . #x0058) UI "Failed SOP Instance UID List")
+ ((#x0008 . #x0060) CS "Modality")
+ ((#x0008 . #x0061) CS "Modalities in Study")
+ ((#x0008 . #x0062) UI "SOP Classes in Study")
+ ((#x0008 . #x0064) CS "Conversion Type")
+ ((#x0008 . #x0068) CS "Presentation Intent Type")
+ ((#x0008 . #x0070) LO "Manufacturer")
+ ((#x0008 . #x0080) LO "Institution Name")
+ ((#x0008 . #x0081) ST "Institution Address")
+ ((#x0008 . #x0082) SQ "Institution Code Sequence")
+ ((#x0008 . #x0090) PN "Referring Physician's Name")
+ ((#x0008 . #x0092) ST "Referring Physician's Address")
+ ((#x0008 . #x0094) SH "Referring Physician's Telephone Numbers")
+ ((#x0008 . #x0096) SQ "Referring Physician Identification Sequence")
+ ((#x0008 . #x0100) SH "Code Value")
+ ((#x0008 . #x0102) SH "Coding Scheme Designator")
+ ((#x0008 . #x0103) SH "Coding Scheme Version")
+ ((#x0008 . #x0104) LO "Code Meaning")
+ ((#x0008 . #x0105) CS "Mapping Resource")
+ ((#x0008 . #x0106) DT "Context Group Version")
+ ((#x0008 . #x0107) DT "Context Group Local Version")
+ ((#x0008 . #x010B) CS "Context Group Extension Flag")
+ ((#x0008 . #x010C) UI "Coding Scheme UID")
+ ((#x0008 . #x010D) UI "Context Group Extension Creator UID")
+ ((#x0008 . #x010E) SQ "Mapping Resource Sequence")
+ ((#x0008 . #x010F) CS "Context Identifier")
+ ((#x0008 . #x0110) SQ "Coding Scheme Identification Sequence")
+ ((#x0008 . #x0112) LO "Coding Scheme Registry")
+ ((#x0008 . #x0114) ST "Coding Scheme External ID")
+ ((#x0008 . #x0115) ST "Coding Scheme Name")
+ ((#x0008 . #x0116) ST "Responsible Organization")
+ ((#x0008 . #x0201) SH "Timezone Offset From UTC")
+ ((#x0008 . #x1000) RET "Network ID (RET)")
+ ((#x0008 . #x1010) SH "Station Name")
+ ((#x0008 . #x1030) LO "Study Description")
+ ((#x0008 . #x1032) SQ "Procedure Code Sequence")
+ ((#x0008 . #x103E) LO "Series Description")
+ ((#x0008 . #x1040) LO "Institutional Department Name")
+ ((#x0008 . #x1048) PN "Physician(s) of Record")
+ ((#x0008 . #x1049) SQ "Physician(s) of Record Identification Sequence")
+ ((#x0008 . #x1050) PN "Performing Physician's Name")
+ ((#x0008 . #x1052) SQ "Performing Physician Identification Sequence")
+ ((#x0008 . #x1060) PN "Name of Physician(s) Reading Study")
+ ((#x0008 . #x1062) SQ "Physician(s) Reading Study Identification Sequence")
+ ((#x0008 . #x1070) PN "Operator's Name")
+ ((#x0008 . #x1072) SQ "Operator Identification Sequence")
+ ((#x0008 . #x1080) LO "Admitting Diagnoses Description")
+ ((#x0008 . #x1084) SQ "Admitting Diagnoses Code Sequence")
+ ((#x0008 . #x1090) LO "Manufacturer's Model Name")
+ ((#x0008 . #x1100) SQ "Referenced Results Sequence")
+ ((#x0008 . #x1110) SQ "Referenced Study Sequence")
+ ((#x0008 . #x1111) SQ "Referenced Performed Procedure Step Sequence")
+ ((#x0008 . #x1115) SQ "Referenced Series Sequence")
+ ((#x0008 . #x1120) SQ "Referenced Patient Sequence")
+ ((#x0008 . #x1125) SQ "Referenced Visit Sequence")
+ ((#x0008 . #x1130) SQ "Referenced Overlay Sequence")
+ ((#x0008 . #x113A) SQ "Referenced Waveform Sequence")
+ ((#x0008 . #x1140) SQ "Referenced Image Sequence")
+ ((#x0008 . #x1145) SQ "Referenced Curve Sequence")
+ ((#x0008 . #x1148) SQ "Referenced Previous Waveform")
+ ((#x0008 . #x114A) SQ "Referenced Instance Sequence")
+ ((#x0008 . #x114C) SQ "Referenced Subsequent Waveform")
+ ((#x0008 . #x1150) UI "Referenced SOP Class UID")
+ ((#x0008 . #x1155) UI "Referenced SOP Instance UID")
+ ((#x0008 . #x115A) UI "SOP Classes Supported")
+ ((#x0008 . #x1160) IS "Referenced Frame Number")
+ ((#x0008 . #x1195) UI "Transaction UID")
+ ((#x0008 . #x1197) US "Failure Reason")
+ ((#x0008 . #x1198) SQ "Failed SOP Sequence")
+ ((#x0008 . #x1199) SQ "Referenced SOP Sequence")
+ ((#x0008 . #x1250) SQ "Related Series Sequence")
+ ((#x0008 . #x2110) RET "Lossy Image Compression (RET)")
+ ((#x0008 . #x2111) ST "Derivation Description")
+ ((#x0008 . #x2112) SQ "Source Image Sequence")
+ ((#x0008 . #x2120) SH "Stage Name")
+ ((#x0008 . #x2122) IS "Stage Number")
+ ((#x0008 . #x2124) IS "Number of Stages")
+ ((#x0008 . #x2127) SH "View Name")
+ ((#x0008 . #x2128) IS "View Number")
+ ((#x0008 . #x2129) IS "Number of Event Timers")
+ ((#x0008 . #x212A) IS "Number of Views in Stage")
+ ((#x0008 . #x2130) DS "Event Elapsed Time(s)")
+ ((#x0008 . #x2132) LO "Event Timer Name(s)")
+ ((#x0008 . #x2142) IS "Start Trim")
+ ((#x0008 . #x2143) IS "Stop Trim")
+ ((#x0008 . #x2144) IS "Recommended Display Frame Rate")
+ ((#x0008 . #x2200) RET "Transducer Position (RET)")
+ ((#x0008 . #x2204) RET "Transducer Orientation (RET)")
+ ((#x0008 . #x2208) RET "Anatomic Structure (RET)")
+ ((#x0008 . #x2218) SQ "Anatomic Region Sequence")
+ ((#x0008 . #x2220) SQ "Anatomic Region Modifier Sequence")
+ ((#x0008 . #x2228) SQ "Primary Anatomic Structure Sequence")
+ ((#x0008 . #x2229) SQ "Anatomic Structure, Space or Region Sequence")
+ ((#x0008 . #x2230) SQ "Primary Anatomic Structure Modifier Sequence")
+ ((#x0008 . #x2240) SQ "Transducer Position Sequence")
+ ((#x0008 . #x2242) SQ "Transducer Position Modifier Sequence")
+ ((#x0008 . #x2244) SQ "Transducer Orientation Sequence")
+ ((#x0008 . #x2246) SQ "Transducer Orientation Modifier Sequence")
+ ((#x0008 . #x3001) SQ "Alternate Representation Sequence")
+ ((#x0008 . #x4000) RET "Comments (RET)")
+ ((#x0008 . #x9007) CS "Frame Type")
+ ((#x0008 . #x9092) SQ "Referenced Image Evidence Sequence")
+ ((#x0008 . #x9121) SQ "Referenced Raw Data Sequence")
+ ((#x0008 . #x9123) UI "Creator-Version UID")
+ ((#x0008 . #x9124) SQ "Derivation Image Sequence")
+ ((#x0008 . #x9154) SQ "Source Image Evidence Sequence")
+ ((#x0008 . #x9205) CS "Pixel Presentation")
+ ((#x0008 . #x9206) CS "Volumetric Properties")
+ ((#x0008 . #x9207) CS "Volume Based Calculation Technique")
+ ((#x0008 . #x9208) CS "Complex Image Component")
+ ((#x0008 . #x9209) CS "Acquisition Contrast")
+ ((#x0008 . #x9215) SQ "Derivation Code Sequence")
+ ((#x0008 . #x9237) SQ "Referenced Grayscale Presentation State Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 0010: "Patient Information"
+ ((#x0010 . #x0000) UL "Group Length")
+ ((#x0010 . #x0010) PN "Patient's Name")
+ ((#x0010 . #x0020) LO "Patient ID")
+ ((#x0010 . #x0021) LO "Issuer of Patient ID")
+ ((#x0010 . #x0030) DA "Patient's Birth Date")
+ ((#x0010 . #x0032) TM "Patient's Birth Time")
+ ((#x0010 . #x0040) CS "Patient's Sex")
+ ((#x0010 . #x0050) SQ "Patient's Insurance Plan Code Sequence")
+ ((#x0010 . #x0101) SQ "Patient's Primary Language Code Sequence")
+ ((#x0010 . #x0102) SQ "Patient's Primary Language Code Modifier Sequence")
+ ((#x0010 . #x1000) LO "Other Patient IDs")
+ ((#x0010 . #x1001) PN "Other Patient Names")
+ ((#x0010 . #x1005) PN "Patient's Birth Name")
+ ((#x0010 . #x1010) AS "Patient's Age")
+ ((#x0010 . #x1020) DS "Patient's Size")
+ ((#x0010 . #x1030) DS "Patient's Weight")
+ ((#x0010 . #x1040) LO "Patient's Address")
+ ((#x0010 . #x1050) RET "Insurance Plan Identification (RET)")
+ ((#x0010 . #x1060) PN "Patient's Mother's Birth Name")
+ ((#x0010 . #x1080) LO "Military Rank")
+ ((#x0010 . #x1081) LO "Branch of Service")
+ ((#x0010 . #x1090) LO "Medical Record Locator")
+ ((#x0010 . #x2000) LO "Medical Alerts")
+ ((#x0010 . #x2110) LO "Contrast Allergies")
+ ((#x0010 . #x2150) LO "Country of Residence")
+ ((#x0010 . #x2152) LO "Region of Residence")
+ ((#x0010 . #x2154) SH "Patient's Telephone Numbers")
+ ((#x0010 . #x2160) SH "Ethnic Group")
+ ((#x0010 . #x2180) SH "Occupation")
+ ((#x0010 . #x21A0) CS "Smoking Status")
+ ((#x0010 . #x21B0) LT "Additional Patient History")
+ ((#x0010 . #x21C0) US "Pregnancy Status")
+ ((#x0010 . #x21D0) DA "Last Menstrual Date")
+ ((#x0010 . #x21F0) LO "Patient's Religious Preference")
+ ((#x0010 . #x4000) LT "Patient Comments")
+
+ ;;---------------------------------------------
+ ;; Group 0012: "Clinical Trial"
+ ((#x0012 . #x0000) UL "Group Length")
+ ((#x0012 . #x0010) LO "Clinical Trial Sponsor Name")
+ ((#x0012 . #x0020) LO "Clinical Trial Protocol ID")
+ ((#x0012 . #x0021) LO "Clinical Trial Protocol Name")
+ ((#x0012 . #x0030) LO "Clinical Trial Site ID")
+ ((#x0012 . #x0031) LO "Clinical Trial Site Name")
+ ((#x0012 . #x0040) LO "Clinical Trial Subject ID")
+ ((#x0012 . #x0042) LO "Clinical Trial Subject Reading ID")
+ ((#x0012 . #x0050) LO "Clinical Trial Time Point ID")
+ ((#x0012 . #x0051) ST "Clinical Trial Time Point Description")
+ ((#x0012 . #x0060) LO "Clinical Trial Coordinating Center Name")
+
+ ;;---------------------------------------------
+ ;; Group 0018: "Acquisition"
+ ((#x0018 . #x0000) UL "Group Length")
+ ((#x0018 . #x0010) LO "Contrast/Bolus Agent")
+ ((#x0018 . #x0012) SQ "Contrast/Bolus Agent Sequence")
+ ((#x0018 . #x0014) SQ "Contrast/Bolus Administration Route Sequence")
+ ((#x0018 . #x0015) CS "Body Part Examined")
+ ((#x0018 . #x0020) CS "Scanning Sequence")
+ ((#x0018 . #x0021) CS "Sequence Variant")
+ ((#x0018 . #x0022) CS "Scan Options")
+ ((#x0018 . #x0023) CS "MR Acquisition Type")
+ ((#x0018 . #x0024) SH "Sequence Name")
+ ((#x0018 . #x0025) CS "Angio Flag")
+ ((#x0018 . #x0026) SQ "Intervention Drug Information Sequence")
+ ((#x0018 . #x0027) TM "Intervention Drug Stop Time")
+ ((#x0018 . #x0028) DS "Intervention Drug Dose")
+ ((#x0018 . #x0029) SQ "Intervention Drug Sequence")
+ ((#x0018 . #x002A) SQ "Additional Drug Sequence")
+ ((#x0018 . #x0030) RET "Radionuclide (RET)")
+ ((#x0018 . #x0031) LO "Radiopharmaceutical")
+ ((#x0018 . #x0032) RET "Energy Window Centerline (RET)")
+ ((#x0018 . #x0033) RET "Energy Window Total Width (RET)")
+ ((#x0018 . #x0034) LO "Intervention Drug Name")
+ ((#x0018 . #x0035) TM "Intervention Drug Start Time")
+ ((#x0018 . #x0036) SQ "Intervention Sequence")
+ ((#x0018 . #x0037) RET "Therapy Type (RET)")
+ ((#x0018 . #x0038) CS "Intervention Status")
+ ((#x0018 . #x0039) RET "Therapy Description (RET)")
+ ((#x0018 . #x003A) ST "Intervention Description")
+ ((#x0018 . #x0040) IS "Cine Rate")
+ ((#x0018 . #x0050) DS "Slice Thickness")
+ ((#x0018 . #x0060) DS "KVP")
+ ((#x0018 . #x0070) IS "Counts Accumulated")
+ ((#x0018 . #x0071) CS "Acquisition Termination Condition")
+ ((#x0018 . #x0072) DS "Effective Duration")
+ ((#x0018 . #x0073) CS "Acquisition Start Condition")
+ ((#x0018 . #x0074) IS "Acquisition Start Condition Data")
+ ((#x0018 . #x0075) IS "Acquisition Termination Condition Data")
+ ((#x0018 . #x0080) DS "Repetition Time")
+ ((#x0018 . #x0081) DS "Echo Time")
+ ((#x0018 . #x0082) DS "Inversion Time")
+ ((#x0018 . #x0083) DS "Number of Averages")
+ ((#x0018 . #x0084) DS "Imaging Frequency")
+ ((#x0018 . #x0085) SH "Imaged Nucleus")
+ ((#x0018 . #x0086) IS "Echo Number(s)")
+ ((#x0018 . #x0087) DS "Magnetic Field Strength")
+ ((#x0018 . #x0088) DS "Spacing Between Slices")
+ ((#x0018 . #x0089) IS "Number of Phase Encoding Steps")
+ ((#x0018 . #x0090) DS "Data Collection Diameter")
+ ((#x0018 . #x0091) IS "Echo Train Length")
+ ((#x0018 . #x0093) DS "Percent Sampling")
+ ((#x0018 . #x0094) DS "Percent Phase Field of View")
+ ((#x0018 . #x0095) DS "Pixel Bandwidth")
+ ((#x0018 . #x1000) LO "Device Serial Number")
+ ((#x0018 . #x1004) LO "Plate ID")
+ ((#x0018 . #x1010) LO "Secondary Capture Device ID")
+ ((#x0018 . #x1011) LO "Hardcopy Creation Device ID")
+ ((#x0018 . #x1012) DA "Date of Secondary Capture")
+ ((#x0018 . #x1014) TM "Time of Secondary Capture")
+ ((#x0018 . #x1016) LO "Secondary Capture Device Manufacturer")
+ ((#x0018 . #x1017) LO "Hardcopy Device Manufacturer")
+ ((#x0018 . #x1018) LO "Secondary Capture Device Manufacturer's Model Name")
+ ((#x0018 . #x1019) LO "Secondary Capture Device Software Version(s)")
+ ((#x0018 . #x101A) LO "Hardcopy Device Software Version")
+ ((#x0018 . #x101B) LO "Hardcopy Device Manufacturer's Model Name")
+ ((#x0018 . #x1020) LO "Software Version(s)")
+ ((#x0018 . #x1022) SH "Video Image Format Acquired")
+ ((#x0018 . #x1023) LO "Digital Image Format Acquired")
+ ((#x0018 . #x1030) LO "Protocol Name")
+ ((#x0018 . #x1040) LO "Contrast/Bolus Route")
+ ((#x0018 . #x1041) DS "Contrast/Bolus Volume")
+ ((#x0018 . #x1042) TM "Contrast/Bolus Start Time")
+ ((#x0018 . #x1043) TM "Contrast/Bolus Stop Time")
+ ((#x0018 . #x1044) DS "Contrast/Bolus Total Dose")
+ ((#x0018 . #x1045) IS "Syringe Counts")
+ ((#x0018 . #x1046) DS "Contrast Flow Rate")
+ ((#x0018 . #x1047) DS "Contrast Flow Duration")
+ ((#x0018 . #x1048) CS "Contrast/Bolus Ingredient")
+ ((#x0018 . #x1049) DS "Contrast/Bolus Ingredient Concentration")
+ ((#x0018 . #x1050) DS "Spatial Resolution")
+ ((#x0018 . #x1060) DS "Trigger Time")
+ ((#x0018 . #x1061) LO "Trigger Source or Type")
+ ((#x0018 . #x1062) IS "Nominal Interval")
+ ((#x0018 . #x1063) DS "Frame Time")
+ ((#x0018 . #x1064) LO "Framing Type")
+ ((#x0018 . #x1065) DS "Frame Time Vector")
+ ((#x0018 . #x1066) DS "Frame Delay")
+ ((#x0018 . #x1067) DS "Image Trigger Delay")
+ ((#x0018 . #x1068) DS "Multiplex Group Time Offset")
+ ((#x0018 . #x1069) DS "Trigger Time Offset")
+ ((#x0018 . #x106A) CS "Synchronization Trigger")
+ ((#x0018 . #x106B) UI "Synchronization Frame of Reference")
+ ((#x0018 . #x106C) US "Synchronization Channel")
+ ((#x0018 . #x106E) UL "Trigger Sample Position")
+ ((#x0018 . #x1070) LO "Radiopharmaceutical Route")
+ ((#x0018 . #x1071) DS "Radiopharmaceutical Volume")
+ ((#x0018 . #x1072) TM "Radiopharmaceutical Start Time")
+ ((#x0018 . #x1073) TM "Radiopharmaceutical Stop Time")
+ ((#x0018 . #x1074) DS "Radionuclide Total Dose")
+ ((#x0018 . #x1075) DS "Radionuclide Half Life")
+ ((#x0018 . #x1076) DS "Radionuclide Positron Fraction")
+ ((#x0018 . #x1077) DS "Radiopharmaceutical Specific Activity")
+ ((#x0018 . #x1080) CS "Beat Rejection Flag")
+ ((#x0018 . #x1081) IS "Low R-R Value")
+ ((#x0018 . #x1082) IS "High R-R Value")
+ ((#x0018 . #x1083) IS "Intervals Acquired")
+ ((#x0018 . #x1084) IS "Intervals Rejected")
+ ((#x0018 . #x1085) LO "PVC Rejection")
+ ((#x0018 . #x1086) IS "Skip Beats")
+ ((#x0018 . #x1088) IS "Heart Rate")
+ ((#x0018 . #x1090) IS "Cardiac Number of Images")
+ ((#x0018 . #x1094) IS "Trigger Window")
+ ((#x0018 . #x1100) DS "Reconstruction Diameter")
+ ((#x0018 . #x1110) DS "Distance Source to Detector")
+ ((#x0018 . #x1111) DS "Distance Source to Patient")
+ ((#x0018 . #x1114) DS "Estimated Radiographic Magnification Factor")
+ ((#x0018 . #x1120) DS "Gantry/Detector Tilt")
+ ((#x0018 . #x1121) DS "Gantry/Detector Slew")
+ ((#x0018 . #x1130) DS "Table Height")
+ ((#x0018 . #x1131) DS "Table Traverse")
+ ((#x0018 . #x1134) CS "Table Motion")
+ ((#x0018 . #x1135) DS "Table Vertical Increment")
+ ((#x0018 . #x1136) DS "Table Lateral Increment")
+ ((#x0018 . #x1137) DS "Table Longitudinal Increment")
+ ((#x0018 . #x1138) DS "Table Angle")
+ ((#x0018 . #x113A) CS "Table Type")
+ ((#x0018 . #x1140) CS "Rotation Direction")
+ ((#x0018 . #x1141) DS "Angular Position")
+ ((#x0018 . #x1142) DS "Radial Position")
+ ((#x0018 . #x1143) DS "Scan Arc")
+ ((#x0018 . #x1144) DS "Angular Step")
+ ((#x0018 . #x1145) DS "Center of Rotation Offset")
+ ((#x0018 . #x1146) RET "Rotation Offset (RET)")
+ ((#x0018 . #x1147) CS "Field of View Shape")
+ ((#x0018 . #x1149) IS "Field of View Dimension(s)")
+ ((#x0018 . #x1150) IS "Exposure Time")
+ ((#x0018 . #x1151) IS "X-ray Tube Current")
+ ((#x0018 . #x1152) IS "Exposure")
+ ((#x0018 . #x1153) IS "Exposure in uAs")
+ ((#x0018 . #x1154) DS "Average Pulse Width")
+ ((#x0018 . #x1155) CS "Radiation Setting")
+ ((#x0018 . #x1156) CS "Rectification Type")
+ ((#x0018 . #x115A) CS "Radiation Mode")
+ ((#x0018 . #x115E) DS "Image Area Dose Product")
+ ((#x0018 . #x1160) SH "Filter Type")
+ ((#x0018 . #x1161) LO "Type of Filters")
+ ((#x0018 . #x1162) DS "Intensifier Size")
+ ((#x0018 . #x1164) DS "Imager Pixel Spacing")
+ ((#x0018 . #x1166) CS "Grid")
+ ((#x0018 . #x1170) IS "Generator Power")
+ ((#x0018 . #x1180) SH "Collimator/grid Name")
+ ((#x0018 . #x1181) CS "Collimator Type")
+ ((#x0018 . #x1182) IS "Focal Distance")
+ ((#x0018 . #x1183) DS "X Focus Center")
+ ((#x0018 . #x1184) DS "Y Focus Center")
+ ((#x0018 . #x1190) DS "Focal Spot(s)")
+ ((#x0018 . #x1191) CS "Anode Target Material")
+ ((#x0018 . #x11A0) DS "Body Part Thickness")
+ ((#x0018 . #x11A2) DS "Compression Force")
+ ((#x0018 . #x1200) DA "Date of Last Calibration")
+ ((#x0018 . #x1201) TM "Time of Last Calibration")
+ ((#x0018 . #x1210) SH "Convolution Kernel")
+ ((#x0018 . #x1240) RET "Upper/Lower Pixel Values (RET)")
+ ((#x0018 . #x1242) IS "Actual Frame Duration")
+ ((#x0018 . #x1243) IS "Count Rate")
+ ((#x0018 . #x1244) US "Preferred Playback Sequencing")
+ ((#x0018 . #x1250) SH "Receive Coil Name")
+ ((#x0018 . #x1251) SH "Transmit Coil Name")
+ ((#x0018 . #x1260) SH "Plate Type")
+ ((#x0018 . #x1261) LO "Phosphor Type")
+ ((#x0018 . #x1300) DS "Scan Velocity")
+ ((#x0018 . #x1301) CS "Whole Body Technique")
+ ((#x0018 . #x1302) IS "Scan Length")
+ ((#x0018 . #x1310) US "Acquisition Matrix")
+ ((#x0018 . #x1312) CS "In-plane Phase Encoding Direction")
+ ((#x0018 . #x1314) DS "Flip Angle")
+ ((#x0018 . #x1315) CS "Variable Flip Angle Flag")
+ ((#x0018 . #x1316) DS "SAR")
+ ((#x0018 . #x1318) DS "dB/dt")
+ ((#x0018 . #x1400) LO "Acquisition Device Processing Description")
+ ((#x0018 . #x1401) LO "Acquisition Device Processing Code")
+ ((#x0018 . #x1402) CS "Cassette Orientation")
+ ((#x0018 . #x1403) CS "Cassette Size")
+ ((#x0018 . #x1404) US "Exposures on Plate")
+ ((#x0018 . #x1405) IS "Relative X-ray Exposure")
+ ((#x0018 . #x1450) DS "Column Angulation")
+ ((#x0018 . #x1460) DS "Tomo Layer Height")
+ ((#x0018 . #x1470) DS "Tomo Angle")
+ ((#x0018 . #x1480) DS "Tomo Time")
+ ((#x0018 . #x1490) CS "Tomo Type")
+ ((#x0018 . #x1491) CS "Tomo Class")
+ ((#x0018 . #x1495) IS "Number of Tomosynthesis Source Images")
+ ((#x0018 . #x1500) CS "Positioner Motion")
+ ((#x0018 . #x1508) CS "Positioner Type")
+ ((#x0018 . #x1510) DS "Positioner Primary Angle")
+ ((#x0018 . #x1511) DS "Positioner Secondary Angle")
+ ((#x0018 . #x1520) DS "Positioner Primary Angle Increment")
+ ((#x0018 . #x1521) DS "Positioner Secondary Angle Increment")
+ ((#x0018 . #x1530) DS "Detector Primary Angle")
+ ((#x0018 . #x1531) DS "Detector Secondary Angle")
+ ((#x0018 . #x1600) CS "Shutter Shape")
+ ((#x0018 . #x1602) IS "Shutter Left Vertical Edge")
+ ((#x0018 . #x1604) IS "Shutter Right Vertical Edge")
+ ((#x0018 . #x1606) IS "Shutter Upper Horizontal Edge")
+ ((#x0018 . #x1608) IS "Shutter Lower Horizontal Edge")
+ ((#x0018 . #x1610) IS "Center of Circular Shutter")
+ ((#x0018 . #x1612) IS "Radius of Circular Shutter")
+ ((#x0018 . #x1620) IS "Vertices of the Polygonal Shutter")
+ ((#x0018 . #x1622) US "Shutter Presentation Value")
+ ((#x0018 . #x1623) US "Shutter Overlay Group")
+ ((#x0018 . #x1700) CS "Collimator Shape")
+ ((#x0018 . #x1702) IS "Collimator Left Vertical Edge")
+ ((#x0018 . #x1704) IS "Collimator Right Vertical Edge")
+ ((#x0018 . #x1706) IS "Collimator Upper Horizontal Edge")
+ ((#x0018 . #x1708) IS "Collimator Lower Horizontal Edge")
+ ((#x0018 . #x1710) IS "Center of Circular Collimator")
+ ((#x0018 . #x1712) IS "Radius of Circular Collimator")
+ ((#x0018 . #x1720) IS "Vertices of the Polygonal Collimator")
+ ((#x0018 . #x1800) CS "Acquisition Time Synchronized")
+ ((#x0018 . #x1801) SH "Time Source")
+ ((#x0018 . #x1802) CS "Time Distribution Protocol")
+ ((#x0018 . #x1803) LO "NTP Source Address")
+ ((#x0018 . #x2001) IS "Page Number Vector")
+ ((#x0018 . #x2002) SH "Frame Label Vector")
+ ((#x0018 . #x2003) DS "Frame Primary Angle Vector")
+ ((#x0018 . #x2004) DS "Frame Secondary Angle Vector")
+ ((#x0018 . #x2005) DS "Slice Location Vector")
+ ((#x0018 . #x2006) SH "Display Window Label Vector")
+ ((#x0018 . #x2010) DS "Nominal Scanned Pixel Spacing")
+ ((#x0018 . #x2020) CS "Digitizing Device Transport Direction")
+ ((#x0018 . #x2030) DS "Rotation of Scanned Film")
+ ((#x0018 . #x3100) CS "IVUS Acquisition")
+ ((#x0018 . #x3101) DS "IVUS Pullback Rate")
+ ((#x0018 . #x3102) DS "IVUS Gated Rate")
+ ((#x0018 . #x3103) IS "IVUS Pullback Start Frame Number")
+ ((#x0018 . #x3104) IS "IVUS Pullback Stop Frame Number")
+ ((#x0018 . #x3105) IS "Lesion Number")
+ ((#x0018 . #x4000) RET "Comments (RET)")
+ ((#x0018 . #x5000) SH "Output Power")
+ ((#x0018 . #x5010) LO "Transducer Data")
+ ((#x0018 . #x5012) DS "Focus Depth")
+ ((#x0018 . #x5020) LO "Processing Function")
+ ((#x0018 . #x5021) LO "Postprocessing Function")
+ ((#x0018 . #x5022) DS "Mechanical Index")
+ ((#x0018 . #x5024) DS "Bone Thermal Index")
+ ((#x0018 . #x5026) DS "Cranial Thermal Index")
+ ((#x0018 . #x5027) DS "Soft Tissue Thermal Index")
+ ((#x0018 . #x5028) DS "Soft Tissue-focus Thermal Index")
+ ((#x0018 . #x5029) DS "Soft Tissue-surface Thermal Index")
+ ((#x0018 . #x5030) RET "Dynamic Range (RET)")
+ ((#x0018 . #x5040) RET "Total Gain (RET)")
+ ((#x0018 . #x5050) IS "Depth of Scan Field")
+ ((#x0018 . #x5100) CS "Patient Position")
+ ((#x0018 . #x5101) CS "View Position")
+ ((#x0018 . #x5104) SQ "Projection Eponymous Name Code Sequence")
+ ((#x0018 . #x5210) RET "Image Transformation Matrix (RET)")
+ ((#x0018 . #x5212) RET "Image Translation Vector (RET)")
+ ((#x0018 . #x6000) DS "Sensitivity")
+ ((#x0018 . #x6011) SQ "Sequence of Ultrasound Regions")
+ ((#x0018 . #x6012) US "Region Spatial Format")
+ ((#x0018 . #x6014) US "Region Data Type")
+ ((#x0018 . #x6016) UL "Region Flags")
+ ((#x0018 . #x6018) UL "Region Location Min X0")
+ ((#x0018 . #x601A) UL "Region Location Min Y0")
+ ((#x0018 . #x601C) UL "Region Location Max X1")
+ ((#x0018 . #x601E) UL "Region Location Max Y1")
+ ((#x0018 . #x6020) SL "Reference Pixel X0")
+ ((#x0018 . #x6022) SL "Reference Pixel Y0")
+ ((#x0018 . #x6024) US "Physical Units X Direction")
+ ((#x0018 . #x6026) US "Physical Units Y Direction")
+ ((#x0018 . #x6028) FD "Reference Pixel Physical Value X")
+ ((#x0018 . #x602A) FD "Reference Pixel Physical Value Y")
+ ((#x0018 . #x602C) FD "Physical Delta X")
+ ((#x0018 . #x602E) FD "Physical Delta Y")
+ ((#x0018 . #x6030) UL "Transducer Frequency")
+ ((#x0018 . #x6031) CS "Transducer Type")
+ ((#x0018 . #x6032) UL "Pulse Repetition Frequency")
+ ((#x0018 . #x6034) FD "Doppler Correction Angle")
+ ((#x0018 . #x6036) FD "Steering Angle")
+ ((#x0018 . #x6038) RET "Doppler Sample Volume X Position (RET)")
+ ((#x0018 . #x6039) SL "Doppler Sample Volume X Position")
+ ((#x0018 . #x603A) RET "Doppler Sample Volume Y Position (RET)")
+ ((#x0018 . #x603B) SL "Doppler Sample Volume Y Position")
+ ((#x0018 . #x603C) RET "TM-Line Position X0 (RET)")
+ ((#x0018 . #x603D) SL "TM-Line Position X0")
+ ((#x0018 . #x603E) RET "TM-Line Position Y0 (RET)")
+ ((#x0018 . #x603F) SL "TM-Line Position Y0")
+ ((#x0018 . #x6040) RET "TM-Line Position X1 (RET)")
+ ((#x0018 . #x6041) SL "TM-Line Position X1")
+ ((#x0018 . #x6042) RET "TM-Line Position Y1 (RET)")
+ ((#x0018 . #x6043) SL "TM-Line Position Y1")
+ ((#x0018 . #x6044) US "Pixel Component Organization")
+ ((#x0018 . #x6046) UL "Pixel Component Mask")
+ ((#x0018 . #x6048) UL "Pixel Component Range Start")
+ ((#x0018 . #x604A) UL "Pixel Component Range Stop")
+ ((#x0018 . #x604C) US "Pixel Component Physical Units")
+ ((#x0018 . #x604E) US "Pixel Component Data Type")
+ ((#x0018 . #x6050) UL "Number of Table Break Points")
+ ((#x0018 . #x6052) UL "Table of X Break Points")
+ ((#x0018 . #x6054) FD "Table of Y Break Points")
+ ((#x0018 . #x6056) UL "Number of Table Entries")
+ ((#x0018 . #x6058) UL "Table of Pixel Values")
+ ((#x0018 . #x605A) FL "Table of Parameter Values")
+ ((#x0018 . #x6060) FL "R Wave Time Vector")
+ ((#x0018 . #x7000) CS "Detector Conditions Nominal Flag")
+ ((#x0018 . #x7001) DS "Detector Temperature")
+ ((#x0018 . #x7004) CS "Detector Type")
+ ((#x0018 . #x7005) CS "Detector Configuration")
+ ((#x0018 . #x7006) LT "Detector Description")
+ ((#x0018 . #x7008) LT "Detector Mode")
+ ((#x0018 . #x700A) SH "Detector ID")
+ ((#x0018 . #x700C) DA "Date of Last Detector Calibration")
+ ((#x0018 . #x700E) TM "Time of Last Detector Calibration")
+ ((#x0018 . #x7010) IS "Exposures on Detector Since Last Calibration")
+ ((#x0018 . #x7011) IS "Exposures on Detector Since Manufactured")
+ ((#x0018 . #x7012) DS "Detector Time Since Last Exposure")
+ ((#x0018 . #x7014) DS "Detector Active Time")
+ ((#x0018 . #x7016) DS "Detector Activation Offset From Exposure")
+ ((#x0018 . #x701A) DS "Detector Binning")
+ ((#x0018 . #x7020) DS "Detector Element Physical Size")
+ ((#x0018 . #x7022) DS "Detector Element Spacing")
+ ((#x0018 . #x7024) CS "Detector Active Shape")
+ ((#x0018 . #x7026) DS "Detector Active Dimension(s)")
+ ((#x0018 . #x7028) DS "Detector Active Origin")
+ ((#x0018 . #x702A) LO "Detector Manufacturer Name")
+ ((#x0018 . #x702B) LO "Detector Manufacturer's Model Name")
+ ((#x0018 . #x7030) DS "Field of View Origin")
+ ((#x0018 . #x7032) DS "Field of View Rotation")
+ ((#x0018 . #x7034) CS "Field of View Horizontal Flip")
+ ((#x0018 . #x7040) LT "Grid Absorbing Material")
+ ((#x0018 . #x7041) LT "Grid Spacing Material")
+ ((#x0018 . #x7042) DS "Grid Thickness")
+ ((#x0018 . #x7044) DS "Grid Pitch")
+ ((#x0018 . #x7046) IS "Grid Aspect Ratio")
+ ((#x0018 . #x7048) DS "Grid Period")
+ ((#x0018 . #x704C) DS "Grid Focal Distance")
+ ((#x0018 . #x7050) CS "Filter Material")
+ ((#x0018 . #x7052) DS "Filter Thickness Minimum")
+ ((#x0018 . #x7054) DS "Filter Thickness Maximum")
+ ((#x0018 . #x7060) CS "Exposure Control Mode")
+ ((#x0018 . #x7062) LT "Exposure Control Mode Description")
+ ((#x0018 . #x7064) CS "Exposure Status")
+ ((#x0018 . #x7065) DS "Phototimer Setting")
+ ((#x0018 . #x8150) DS "Exposure Time in *S")
+ ((#x0018 . #x8151) DS "X-Ray Tube Current in *A")
+ ((#x0018 . #x9004) CS "Content Qualification")
+ ((#x0018 . #x9005) SH "Pulse Sequence Name")
+ ((#x0018 . #x9006) SQ "MR Imaging Modifier Sequence")
+ ((#x0018 . #x9008) CS "Echo Pulse Sequence")
+ ((#x0018 . #x9009) CS "Inversion Recovery")
+ ((#x0018 . #x9010) CS "Flow Compensation")
+ ((#x0018 . #x9011) CS "Multiple Spin Echo")
+ ((#x0018 . #x9012) CS "Multi-planar Excitation")
+ ((#x0018 . #x9014) CS "Phase Contrast")
+ ((#x0018 . #x9015) CS "Time of Flight Contrast")
+ ((#x0018 . #x9016) CS "Spoiling")
+ ((#x0018 . #x9017) CS "Steady State Pulse Sequence")
+ ((#x0018 . #x9018) CS "Echo Planar Pulse Sequence")
+ ((#x0018 . #x9019) FD "Tag Angle First Axis")
+ ((#x0018 . #x9020) CS "Magnetization Transfer")
+ ((#x0018 . #x9021) CS "T2 Preparation")
+ ((#x0018 . #x9022) CS "Blood Signal Nulling")
+ ((#x0018 . #x9024) CS "Saturation Recovery")
+ ((#x0018 . #x9025) CS "Spectrally Selected Suppression")
+ ((#x0018 . #x9026) CS "Spectrally Selected Excitation")
+ ((#x0018 . #x9027) CS "Spatial Pre-saturation")
+ ((#x0018 . #x9028) CS "Tagging")
+ ((#x0018 . #x9029) CS "Oversampling Phase")
+ ((#x0018 . #x9030) FD "Tag Spacing First Dimension")
+ ((#x0018 . #x9032) CS "Geometry of k-Space Traversal")
+ ((#x0018 . #x9033) CS "Segmented k-Space Traversal")
+ ((#x0018 . #x9034) CS "Rectilinear Phase Encode Reordering")
+ ((#x0018 . #x9035) FD "Tag Thickness")
+ ((#x0018 . #x9036) CS "Partial Fourier Direction")
+ ((#x0018 . #x9037) CS "Cardiac Synchronization Technique")
+ ((#x0018 . #x9041) LO "Receive Coil Manufacturer Name")
+ ((#x0018 . #x9042) SQ "MR Receive Coil Sequence")
+ ((#x0018 . #x9043) CS "Receive Coil Type")
+ ((#x0018 . #x9044) CS "Quadrature Receive Coil")
+ ((#x0018 . #x9045) SQ "Multi-Coil Definition Sequence")
+ ((#x0018 . #x9046) LO "Multi-Coil Configuration")
+ ((#x0018 . #x9047) SH "Multi-Coil Element Name")
+ ((#x0018 . #x9048) CS "Multi-Coil Element Used")
+ ((#x0018 . #x9049) SQ "MR Transmit Coil Sequence")
+ ((#x0018 . #x9050) LO "Transmit Coil Manufacturer Name")
+ ((#x0018 . #x9051) CS "Transmit Coil Type")
+ ((#x0018 . #x9052) FD "Spectral Width")
+ ((#x0018 . #x9053) FD "Chemical Shift Reference")
+ ((#x0018 . #x9054) CS "Volume Localization Technique")
+ ((#x0018 . #x9058) US "MR Acquisition Frequency Encoding Steps")
+ ((#x0018 . #x9059) CS "De-coupling")
+ ((#x0018 . #x9060) CS "De-coupled Nucleus")
+ ((#x0018 . #x9061) FD "De-coupling Frequency")
+ ((#x0018 . #x9062) CS "De-coupling Method")
+ ((#x0018 . #x9063) FD "De-coupling Chemical Shift Reference")
+ ((#x0018 . #x9064) CS "k-space Filtering")
+ ((#x0018 . #x9065) CS "Time Domain Filtering")
+ ((#x0018 . #x9066) US "Number of Zero fills")
+ ((#x0018 . #x9067) CS "Baseline Correction")
+ ((#x0018 . #x9069) FD "Parallel Reduction Factor In-plane")
+ ((#x0018 . #x9070) FD "Cardiac R-R Interval Specified")
+ ((#x0018 . #x9074) DT "Frame Acquisition Datetime")
+ ((#x0018 . #x9075) CS "Diffusion Directionality")
+ ((#x0018 . #x9076) SQ "Diffusion Gradient Direction Sequence")
+ ((#x0018 . #x9077) CS "Parallel Acquisition")
+ ((#x0018 . #x9078) CS "Parallel Acquisition Technique")
+ ((#x0018 . #x9079) FD "Inversion Times")
+ ((#x0018 . #x9080) ST "Metabolite Map Description")
+ ((#x0018 . #x9081) CS "Partial Fourier")
+ ((#x0018 . #x9082) FD "Effective Echo Time")
+ ((#x0018 . #x9083) SQ "Metabolite Map Code Sequence")
+ ((#x0018 . #x9084) SQ "Chemical Shift Sequence")
+ ((#x0018 . #x9085) CS "Cardiac Signal Source")
+ ((#x0018 . #x9087) FD "Diffusion b-value")
+ ((#x0018 . #x9089) FD "Diffusion Gradient Orientation")
+ ((#x0018 . #x9090) FD "Velocity Encoding Direction")
+ ((#x0018 . #x9091) FD "Velocity Encoding Minimum Value")
+ ((#x0018 . #x9093) US "Number of k-Space Trajectories")
+ ((#x0018 . #x9094) CS "Coverage of k-Space")
+ ((#x0018 . #x9095) UL "Spectroscopy Acquisition Phase Rows")
+ ((#x0018 . #x9098) FD "Transmitter Frequency")
+ ((#x0018 . #x9100) CS "Resonant Nucleus")
+ ((#x0018 . #x9101) CS "Frequency Correction")
+ ((#x0018 . #x9103) SQ "MR Spectroscopy FOV/Geometry Sequence")
+ ((#x0018 . #x9104) FD "Slab Thickness")
+ ((#x0018 . #x9105) FD "Slab Orientation")
+ ((#x0018 . #x9106) FD "Mid Slab Position")
+ ((#x0018 . #x9107) SQ "MR Spatial Saturation Sequence")
+ ((#x0018 . #x9112) SQ "MR Timing and Related Parameters Sequence")
+ ((#x0018 . #x9114) SQ "MR Echo Sequence")
+ ((#x0018 . #x9115) SQ "MR Modifier Sequence")
+ ((#x0018 . #x9117) SQ "MR Diffusion Sequence")
+ ((#x0018 . #x9118) SQ "Cardiac Trigger Sequence")
+ ((#x0018 . #x9119) SQ "MR Averages Sequence")
+ ((#x0018 . #x9125) SQ "MR FOV/Geometry Sequence")
+ ((#x0018 . #x9126) SQ "Volume Localization Sequence")
+ ((#x0018 . #x9127) UL "Spectroscopy Acquisition Data Columns")
+ ((#x0018 . #x9147) CS "Diffusion Anisotropy Type")
+ ((#x0018 . #x9151) DT "Frame Reference Datetime")
+ ((#x0018 . #x9152) SQ "MR Metabolite Map Sequence")
+ ((#x0018 . #x9155) FD "Parallel Reduction Factor out-of-plane")
+ ((#x0018 . #x9159) UL "Spectroscopy Acquisition Out-of-plane Phase Steps")
+ ((#x0018 . #x9166) CS "Bulk Motion Status")
+ ((#x0018 . #x9168) FD "Parallel Reduction Factor Second In-plane")
+ ((#x0018 . #x9169) CS "Cardiac Beat Rejection Technique")
+ ((#x0018 . #x9170) CS "Respiratory Motion Compensation Technique")
+ ((#x0018 . #x9171) CS "Respiratory Signal Source")
+ ((#x0018 . #x9172) CS "Bulk Motion Compensation Technique")
+ ((#x0018 . #x9173) CS "Bulk Motion Signal Source")
+ ((#x0018 . #x9174) CS "Applicable Safety Standard Agency")
+ ((#x0018 . #x9175) LO "Applicable Safety Standard Description")
+ ((#x0018 . #x9176) SQ "Operating Mode Sequence")
+ ((#x0018 . #x9177) CS "Operating Mode Type")
+ ((#x0018 . #x9178) CS "Operating Mode")
+ ((#x0018 . #x9179) CS "Specific Absorption Rate Definition")
+ ((#x0018 . #x9180) CS "Gradient Output Type")
+ ((#x0018 . #x9181) FD "Specific Absorption Rate Value")
+ ((#x0018 . #x9182) FD "Gradient Output")
+ ((#x0018 . #x9183) CS "Flow Compensation Direction")
+ ((#x0018 . #x9184) FD "Tagging Delay")
+ ((#x0018 . #x9195) RET "Chemical Shifts Minimum Integration Limit in Hz (RET)")
+ ((#x0018 . #x9196) RET "Chemical Shifts Maximum Integration Limit in Hz (RET)")
+ ((#x0018 . #x9197) SQ "MR Velocity Encoding Sequence")
+ ((#x0018 . #x9198) CS "First Order Phase Correction")
+ ((#x0018 . #x9199) CS "Water Referenced Phase Correction")
+ ((#x0018 . #x9200) CS "MR Spectroscopy Acquisition Type")
+ ((#x0018 . #x9214) CS "Respiratory Cycle Position")
+ ((#x0018 . #x9217) FD "Velocity Encoding Maximum Value")
+ ((#x0018 . #x9218) FD "Tag Spacing Second Dimension")
+ ((#x0018 . #x9219) SS "Tag Angle Second Axis")
+ ((#x0018 . #x9220) FD "Frame Acquisition Duration")
+ ((#x0018 . #x9226) SQ "MR Image Frame Type Sequence")
+ ((#x0018 . #x9227) SQ "MR Spectroscopy Frame Type Sequence")
+ ((#x0018 . #x9231) US "MR Acquisition Phase Encoding Steps in-plane")
+ ((#x0018 . #x9232) US "MR Acquisition Phase Encoding Steps out-of-plane")
+ ((#x0018 . #x9234) UL "Spectroscopy Acquisition Phase Columns")
+ ((#x0018 . #x9236) CS "Cardiac Cycle Position")
+ ((#x0018 . #x9239) SQ "Specific Absorption Rate Sequence")
+ ((#x0018 . #x9240) US "RF Echo Train Length")
+ ((#x0018 . #x9241) US "Gradient Echo Train Length")
+ ((#x0018 . #x9295) FD "Chemical Shifts Minimum Integration Limit in ppm")
+ ((#x0018 . #x9296) FD "Chemical Shifts Maximum Integration Limit in ppm")
+ ((#x0018 . #x9301) SQ "CT Acquisition Type Sequence")
+ ((#x0018 . #x9302) CS "Acquisition Type")
+ ((#x0018 . #x9303) FD "Tube Angle")
+ ((#x0018 . #x9304) SQ "CT Acquisition Details Sequence")
+ ((#x0018 . #x9305) FD "Revolution Time")
+ ((#x0018 . #x9306) FD "Single Collimation Width")
+ ((#x0018 . #x9307) FD "Total Collimation Width")
+ ((#x0018 . #x9308) SQ "CT Table Dynamics Sequence")
+ ((#x0018 . #x9309) FD "Table Speed")
+ ((#x0018 . #x9310) FD "Table Feed per Rotation")
+ ((#x0018 . #x9311) FD "Spiral Pitch Factor")
+ ((#x0018 . #x9312) SQ "CT Geometry Sequence")
+ ((#x0018 . #x9313) FD "Data Collection Center (Patient)")
+ ((#x0018 . #x9314) SQ "CT Reconstruction Sequence")
+ ((#x0018 . #x9315) CS "Reconstruction Algorithm")
+ ((#x0018 . #x9316) CS "Convolution Kernel Group")
+ ((#x0018 . #x9317) FD "Reconstruction Field of View")
+ ((#x0018 . #x9318) FD "Reconstruction Target Center (Patient)")
+ ((#x0018 . #x9319) FD "Reconstruction Angle")
+ ((#x0018 . #x9320) SH "Image Filter")
+ ((#x0018 . #x9321) SQ "CT Exposure Sequence")
+ ((#x0018 . #x9322) FD "Reconstruction Pixel Spacing")
+ ((#x0018 . #x9323) CS "Exposure Modulation Type")
+ ((#x0018 . #x9324) FD "Estimated Dose Saving")
+ ((#x0018 . #x9325) SQ "CT X-ray Details Sequence")
+ ((#x0018 . #x9326) SQ "CT Position Sequence")
+ ((#x0018 . #x9327) FD "Table Position")
+ ((#x0018 . #x9328) FD "Exposure Time in ms")
+ ((#x0018 . #x9329) SQ "CT Image Frame Type Sequence")
+ ((#x0018 . #x9330) FD "X-Ray Tube Current in mA")
+ ((#x0018 . #x9332) FD "Exposure in mAs")
+ ((#x0018 . #x9333) CS "Constant Volume Flag")
+ ((#x0018 . #x9334) CS "Fluoroscopy Flag")
+ ((#x0018 . #x9335) FD "Distance Source to Data Collection Center")
+ ((#x0018 . #x9337) US "Contrast/Bolus Agent Number")
+ ((#x0018 . #x9338) SQ "Contrast/Bolus Ingredient Code Sequence")
+ ((#x0018 . #x9340) SQ "Contrast Administration Profile Sequence")
+ ((#x0018 . #x9341) SQ "Contrast/Bolus Usage Sequence")
+ ((#x0018 . #x9342) CS "Contrast/Bolus Agent Administered")
+ ((#x0018 . #x9343) CS "Contrast/Bolus Agent Detected")
+ ((#x0018 . #x9344) CS "Contrast/Bolus Agent Phase")
+ ((#x0018 . #x9345) FD "CTDIvol")
+ ((#x0018 . #xA001) SQ "Contributing Equipment Sequence")
+ ((#x0018 . #xA003) ST "Contribution Description")
+
+ ;;---------------------------------------------
+ ;; Group 0020: "Relationship"
+ ((#x0020 . #x0000) UL "Group Length")
+ ((#x0020 . #x000D) UI "Study Instance UID")
+ ((#x0020 . #x000E) UI "Series Instance UID")
+ ((#x0020 . #x0010) SH "Study ID")
+ ((#x0020 . #x0011) IS "Series Number")
+ ((#x0020 . #x0012) IS "Acquisition Number")
+ ((#x0020 . #x0013) IS "Instance Number")
+ ((#x0020 . #x0014) RET "Isotope Number (RET)")
+ ((#x0020 . #x0015) RET "Phase Number (RET)")
+ ((#x0020 . #x0016) RET "Interval Number (RET)")
+ ((#x0020 . #x0017) RET "Time Slot Number (RET)")
+ ((#x0020 . #x0018) RET "Angle Number (RET)")
+ ((#x0020 . #x0019) IS "Item Number")
+ ((#x0020 . #x0020) CS "Patient Orientation")
+ ((#x0020 . #x0022) IS "Overlay Number")
+ ((#x0020 . #x0024) IS "Curve Number")
+ ((#x0020 . #x0026) IS "Lookup Table Number")
+ ((#x0020 . #x0030) RET "Image Position (RET)")
+ ((#x0020 . #x0032) DS "Image Position (Patient)")
+ ((#x0020 . #x0035) RET "Image Orientation (RET)")
+ ((#x0020 . #x0037) DS "Image Orientation (Patient)")
+ ((#x0020 . #x0050) RET "Location (RET)")
+ ((#x0020 . #x0052) UI "Frame of Reference UID")
+ ((#x0020 . #x0060) CS "Laterality")
+ ((#x0020 . #x0062) CS "Image Laterality")
+ ((#x0020 . #x0070) RET "Image Geometry Type (RET)")
+ ((#x0020 . #x0080) RET "Masking Image (RET)")
+ ((#x0020 . #x0100) IS "Temporal Position Identifier")
+ ((#x0020 . #x0105) IS "Number of Temporal Positions")
+ ((#x0020 . #x0110) DS "Temporal Resolution")
+ ((#x0020 . #x0200) UI "Synchronization Frame of Reference UID")
+ ((#x0020 . #x1000) IS "Series in Study")
+ ((#x0020 . #x1001) RET "Acquisitions in Series (RET)")
+ ((#x0020 . #x1002) IS "Images in Acquisition")
+ ((#x0020 . #x1004) IS "Acquisitions in Study")
+ ((#x0020 . #x1020) RET "Reference (RET)")
+ ((#x0020 . #x1040) LO "Position Reference Indicator")
+ ((#x0020 . #x1041) DS "Slice Location")
+ ((#x0020 . #x1070) IS "Other Study Numbers")
+ ((#x0020 . #x1200) IS "Number of Patient Related Studies")
+ ((#x0020 . #x1202) IS "Number of Patient Related Series")
+ ((#x0020 . #x1204) IS "Number of Patient Related Instances")
+ ((#x0020 . #x1206) IS "Number of Study Related Series")
+ ((#x0020 . #x1208) IS "Number of Study Related Instances")
+ ((#x0020 . #x1209) IS "Number of Series Related Instances")
+ ((#x0020 . #x3100) RET "Source Image IDs (RET)")
+ ((#x0020 . #x3401) RET "Modifying Device ID (RET)")
+ ((#x0020 . #x3402) RET "Modified Image ID (RET)")
+ ((#x0020 . #x3403) RET "Modified Image Date (RET)")
+ ((#x0020 . #x3404) RET "Modifying Device Manufacturer (RET)")
+ ((#x0020 . #x3405) RET "Modified Image Time (RET)")
+ ((#x0020 . #x3406) RET "Modified Image Description (RET)")
+ ((#x0020 . #x4000) LT "Image Comments")
+ ((#x0020 . #x5000) RET "Original Image Identification (RET)")
+ ((#x0020 . #x5002) RET "Original Image Identification Nomenclature (RET)")
+ ((#x0020 . #x9056) SH "Stack ID")
+ ((#x0020 . #x9057) UL "In-Stack Position Number")
+ ((#x0020 . #x9071) SQ "Frame Anatomy Sequence")
+ ((#x0020 . #x9072) CS "Frame Laterality")
+ ((#x0020 . #x9111) SQ "Frame Content Sequence")
+ ((#x0020 . #x9113) SQ "Plane Position Sequence")
+ ((#x0020 . #x9116) SQ "Plane Orientation Sequence")
+ ((#x0020 . #x9128) UL "Temporal Position Index")
+ ((#x0020 . #x9153) FD "Trigger Delay Time")
+ ((#x0020 . #x9156) US "Frame Acquisition Number")
+ ((#x0020 . #x9157) UL "Dimension Index Values")
+ ((#x0020 . #x9158) LT "Frame Comments")
+ ((#x0020 . #x9161) UI "Concatenation UID")
+ ((#x0020 . #x9162) US "In-concatenation Number")
+ ((#x0020 . #x9163) US "In-concatenation Total Number")
+ ((#x0020 . #x9164) UI "Dimension Organization UID")
+ ((#x0020 . #x9165) AT "Dimension Index Pointer")
+ ((#x0020 . #x9167) AT "Functional Group Pointer")
+ ((#x0020 . #x9213) LO "Dimension Index Private Creator")
+ ((#x0020 . #x9221) SQ "Dimension Organization Sequence")
+ ((#x0020 . #x9222) SQ "Dimension Index Sequence")
+ ((#x0020 . #x9228) UL "Concatenation Frame Offset Number")
+ ((#x0020 . #x9238) LO "Functional Group Private Creator")
+
+ ;;---------------------------------------------
+ ;; Group 0022: "Light Path"
+ ((#x0022 . #x0000) UL "Group Length")
+ ((#x0022 . #x0001) US "Light Path Filter Pass-Through Wavelength")
+ ((#x0022 . #x0002) US "Light Path Filter Pass Band")
+ ((#x0022 . #x0003) US "Image Path Filter Pass-Through Wavelength")
+ ((#x0022 . #x0004) US "Image Path Filter Pass Band")
+ ((#x0022 . #x0005) CS "Patient Eye Movement Commanded")
+ ((#x0022 . #x0006) SQ "Patient Eye Movement Command Code Sequence")
+ ((#x0022 . #x0007) FL "Spherical Lens Power")
+ ((#x0022 . #x0008) FL "Cylinder Lens Power")
+ ((#x0022 . #x0009) FL "Cylinder Axis")
+ ((#x0022 . #x000A) FL "Emmetropic Magnification")
+ ((#x0022 . #x000B) FL "Intra Ocular Pressure")
+ ((#x0022 . #x000C) FL "Horizontal Field of View")
+ ((#x0022 . #x000D) CS "Pupil Dilated")
+ ((#x0022 . #x000E) FL "Degree of Dilation")
+ ((#x0022 . #x0010) FL "Stereo Baseline Angle")
+ ((#x0022 . #x0011) FL "Stereo Baseline Displacement")
+ ((#x0022 . #x0012) FL "Stereo Horizontal Pixel Offset")
+ ((#x0022 . #x0013) FL "Stereo Vertical Pixel Offset")
+ ((#x0022 . #x0014) FL "Stereo Rotation")
+ ((#x0022 . #x0015) SQ "Acquisition Device Type Code Sequence")
+ ((#x0022 . #x0016) SQ "Illumination Type Code Sequence")
+ ((#x0022 . #x0017) SQ "Light Path Filter Type Stack Code Sequence")
+ ((#x0022 . #x0018) SQ "Image Path Filter Type Stack Code Sequence")
+ ((#x0022 . #x0019) SQ "Lenses Code Sequence")
+ ((#x0022 . #x001A) SQ "Channel Description Code Sequence")
+ ((#x0022 . #x001B) SQ "Refractive State Sequence")
+ ((#x0022 . #x001C) SQ "Mydriatic Agent Code Sequence")
+ ((#x0022 . #x001D) SQ "Relative Image Position Code Sequence")
+ ((#x0022 . #x0020) SQ "Stereo Pairs Sequence")
+ ((#x0022 . #x0021) SQ "Left Image Sequence")
+ ((#x0022 . #x0022) SQ "Right Image Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 0028: "Image"
+ ((#x0028 . #x0000) UL "Group Length")
+ ((#x0028 . #x0002) US "Samples per Pixel")
+ ((#x0028 . #x0003) US "Samples per Pixel Used")
+ ((#x0028 . #x0004) CS "Photometric Interpretation")
+ ((#x0028 . #x0005) RET "Image Dimensions (RET)")
+ ((#x0028 . #x0006) US "Planar Configuration")
+ ((#x0028 . #x0008) IS "Number of Frames")
+ ((#x0028 . #x0009) AT "Frame Increment Pointer")
+ ((#x0028 . #x000A) AT "Frame Dimension Pointer")
+ ((#x0028 . #x0010) US "Rows")
+ ((#x0028 . #x0011) US "Columns")
+ ((#x0028 . #x0012) US "Planes")
+ ((#x0028 . #x0014) US "Ultrasound Color Data Present")
+ ((#x0028 . #x0030) DS "Pixel Spacing")
+ ((#x0028 . #x0031) DS "Zoom Factor")
+ ((#x0028 . #x0032) DS "Zoom Center")
+ ((#x0028 . #x0034) IS "Pixel Aspect Ratio")
+ ((#x0028 . #x0040) RET "Image Format (RET)")
+ ((#x0028 . #x0050) RET "Manipulated Image (RET)")
+ ((#x0028 . #x0051) CS "Corrected Image")
+ ((#x0028 . #x0060) RET "Compression Code (RET)")
+ ((#x0028 . #x0100) US "Bits Allocated")
+ ((#x0028 . #x0101) US "Bits Stored")
+ ((#x0028 . #x0102) US "High Bit")
+ ((#x0028 . #x0103) US "Pixel Representation")
+ ((#x0028 . #x0104) RET "Smallest Valid Pixel Value (RET)")
+ ((#x0028 . #x0105) RET "Largest Valid Pixel Value (RET)")
+ ((#x0028 . #x0106) SS/US "Smallest Image Pixel Value")
+ ((#x0028 . #x0107) SS/US "Largest Image Pixel Value")
+ ((#x0028 . #x0108) SS/US "Smallest Pixel Value in Series")
+ ((#x0028 . #x0109) SS/US "Largest Pixel Value in Series")
+ ((#x0028 . #x0110) SS/US "Smallest Image Pixel Value in Plane")
+ ((#x0028 . #x0111) SS/US "Largest Image Pixel Value in Plane")
+ ((#x0028 . #x0120) SS/US "Pixel Padding Value")
+ ((#x0028 . #x0122) SS/US "Waveform Padding Value")
+ ((#x0028 . #x0200) RET "Image Location (RET)")
+ ((#x0028 . #x0300) CS "Quality Control Image")
+ ((#x0028 . #x0301) CS "Burned In Annotation")
+ ((#x0028 . #x1040) CS "Pixel Intensity Relationship")
+ ((#x0028 . #x1041) SS "Pixel Intensity Relationship Sign")
+ ((#x0028 . #x1050) DS "Window Center")
+ ((#x0028 . #x1051) DS "Window Width")
+ ((#x0028 . #x1052) DS "Rescale Intercept")
+ ((#x0028 . #x1053) DS "Rescale Slope")
+ ((#x0028 . #x1054) LO "Rescale Type")
+ ((#x0028 . #x1055) LO "Window Center & Width Explanation")
+ ((#x0028 . #x1080) RET "Gray Scale (RET)")
+ ((#x0028 . #x1090) CS "Recommended Viewing Mode")
+ ((#x0028 . #x1100) RET "Gray Lookup Table Descriptor (RET)")
+ ((#x0028 . #x1101) SS/US "Red Palette Color Lookup Table Descriptor")
+ ((#x0028 . #x1102) SS/US "Green Palette Color Lookup Table Descriptor")
+ ((#x0028 . #x1103) SS/US "Blue Palette Color Lookup Table Descriptor")
+ ((#x0028 . #x1199) UI "Palette Color Lookup Table UID")
+ ((#x0028 . #x1200) RET "Gray Lookup Table Data (RET)")
+ ((#x0028 . #x1201) OW "Red Palette Color Lookup Table Data")
+ ((#x0028 . #x1202) OW "Green Palette Color Lookup Table Data")
+ ((#x0028 . #x1203) OW "Blue Palette Color Lookup Table Data")
+ ((#x0028 . #x1221) OW "Segmented Red Palette Color Lookup Table Data")
+ ((#x0028 . #x1222) OW "Segmented Green Palette Color Lookup Table Data")
+ ((#x0028 . #x1223) OW "Segmented Blue Palette Color Lookup Table Data")
+ ((#x0028 . #x1300) CS "Implant Present")
+ ((#x0028 . #x1350) CS "Partial View")
+ ((#x0028 . #x1351) ST "Partial View Description")
+ ((#x0028 . #x2110) CS "Lossy Image Compression")
+ ((#x0028 . #x2112) DS "Lossy Image Compression Ratio")
+ ((#x0028 . #x2114) CS "Lossy Image Compression Method")
+ ((#x0028 . #x3000) SQ "Modality LUT Sequence")
+ ((#x0028 . #x3002) SS/US "LUT Descriptor")
+ ((#x0028 . #x3003) LO "LUT Explanation")
+ ((#x0028 . #x3004) LO "Modality LUT Type")
+ ((#x0028 . #x3006) OW "LUT Data")
+ ((#x0028 . #x3010) SQ "VOI LUT Sequence")
+ ((#x0028 . #x3110) SQ "Softcopy VOI LUT Sequence")
+ ((#x0028 . #x4000) RET "Comments (RET)")
+ ((#x0028 . #x5000) SQ "Bi-Plane Acquisition Sequence")
+ ((#x0028 . #x6010) US "Representative Frame Number")
+ ((#x0028 . #x6020) US "Frame Numbers of Interest (FOI)")
+ ((#x0028 . #x6022) LO "Frame(s) of Interest Description")
+ ((#x0028 . #x6023) CS "Frame of Interest Type")
+ ((#x0028 . #x6030) RET "Mask Pointer(s) (RET)")
+ ((#x0028 . #x6040) US "R Wave Pointer")
+ ((#x0028 . #x6100) SQ "Mask Subtraction Sequence")
+ ((#x0028 . #x6101) CS "Mask Operation")
+ ((#x0028 . #x6102) US "Applicable Frame Range")
+ ((#x0028 . #x6110) US "Mask Frame Numbers")
+ ((#x0028 . #x6112) US "Contrast Frame Averaging")
+ ((#x0028 . #x6114) FL "Mask Sub-pixel Shift")
+ ((#x0028 . #x6120) SS "TID Offset")
+ ((#x0028 . #x6190) ST "Mask Operation Explanation")
+ ((#x0028 . #x9001) UL "Data Point Rows")
+ ((#x0028 . #x9002) UL "Data Point Columns")
+ ((#x0028 . #x9003) CS "Signal Domain Columns")
+ ((#x0028 . #x9099) RET "Largest Monochrome Pixel Value (RET)")
+ ((#x0028 . #x9108) CS "Data Representation")
+ ((#x0028 . #x9110) SQ "Pixel Measures Sequence")
+ ((#x0028 . #x9132) SQ "Frame VOI LUT Sequence")
+ ((#x0028 . #x9145) SQ "Pixel Value Transformation Sequence")
+ ((#x0028 . #x9235) CS "Signal Domain Rows")
+
+ ;;---------------------------------------------
+ ;; Group 0032: "Study"
+ ((#x0032 . #x0000) UL "Group length")
+ ((#x0032 . #x000A) CS "Study Status ID")
+ ((#x0032 . #x000C) CS "Study Priority ID")
+ ((#x0032 . #x0012) LO "Study ID Issuer")
+ ((#x0032 . #x0032) DA "Study Verified Date")
+ ((#x0032 . #x0033) TM "Study Verified Time")
+ ((#x0032 . #x0034) DA "Study Read Date")
+ ((#x0032 . #x0035) TM "Study Read Time")
+ ((#x0032 . #x1000) DA "Scheduled Study Start Date")
+ ((#x0032 . #x1001) TM "Scheduled Study Start Time")
+ ((#x0032 . #x1010) DA "Scheduled Study Stop Date")
+ ((#x0032 . #x1011) TM "Scheduled Study Stop Time")
+ ((#x0032 . #x1020) LO "Scheduled Study Location")
+ ((#x0032 . #x1021) AE "Scheduled Study Location AE Title(s)")
+ ((#x0032 . #x1030) LO "Reason for Study")
+ ((#x0032 . #x1031) SQ "Requesting Physician Identification Sequence")
+ ((#x0032 . #x1032) PN "Requesting Physician")
+ ((#x0032 . #x1033) LO "Requesting Service")
+ ((#x0032 . #x1040) DA "Study Arrival Date")
+ ((#x0032 . #x1041) TM "Study Arrival Time")
+ ((#x0032 . #x1050) DA "Study Completion Date")
+ ((#x0032 . #x1051) TM "Study Completion Time")
+ ((#x0032 . #x1055) CS "Study Component Status ID")
+ ((#x0032 . #x1060) LO "Requested Procedure Description")
+ ((#x0032 . #x1064) SQ "Requested Procedure Code Sequence")
+ ((#x0032 . #x1070) LO "Requested Contrast Agent")
+ ((#x0032 . #x4000) LT "Study Comments")
+
+ ;;---------------------------------------------
+ ;; Group 0038: "Visit"
+ ((#x0038 . #x0000) UL "Group Length")
+ ((#x0038 . #x0004) SQ "Referenced Patient Alias Sequence")
+ ((#x0038 . #x0008) CS "Visit Status ID")
+ ((#x0038 . #x0010) LO "Admission ID")
+ ((#x0038 . #x0011) LO "Issuer of Admission ID")
+ ((#x0038 . #x0016) LO "Route of Admissions")
+ ((#x0038 . #x001A) DA "Scheduled Admission Date")
+ ((#x0038 . #x001B) TM "Scheduled Admission Time")
+ ((#x0038 . #x001C) DA "Scheduled Discharge Date")
+ ((#x0038 . #x001D) TM "Scheduled Discharge Time")
+ ((#x0038 . #x001E) LO "Scheduled Patient Institution Residence")
+ ((#x0038 . #x0020) DA "Admitting Date")
+ ((#x0038 . #x0021) TM "Admitting Time")
+ ((#x0038 . #x0030) DA "Discharge Date")
+ ((#x0038 . #x0032) TM "Discharge Time")
+ ((#x0038 . #x0040) LO "Discharge Diagnosis Description")
+ ((#x0038 . #x0044) SQ "Discharge Diagnosis Code Sequence")
+ ((#x0038 . #x0050) LO "Special Needs")
+ ((#x0038 . #x0300) LO "Current Patient Location")
+ ((#x0038 . #x0400) LO "Patient's Institution Residence")
+ ((#x0038 . #x0500) LO "Patient State")
+ ((#x0038 . #x4000) LT "Visit Comments")
+
+ ;;---------------------------------------------
+ ;; Group 003A: "Waveform"
+ ((#x003A . #x0000) UL "Group Length")
+ ((#x003A . #x0002) SQ "Waveform Sequence")
+ ((#x003A . #x0004) CS "Waveform Originality")
+ ((#x003A . #x0005) US "Number of Waveform Channels")
+ ((#x003A . #x0010) UL "Number of Waveform Samples")
+ ((#x003A . #x001A) DS "Sampling Frequency")
+ ((#x003A . #x0020) SH "Multiplex Group Label")
+ ((#x003A . #x0103) CS "Data Value Representation")
+ ((#x003A . #x0200) SQ "Channel Definition Sequence")
+ ((#x003A . #x0202) IS "Waveform Channel Number")
+ ((#x003A . #x0203) SH "Channel Label")
+ ((#x003A . #x0205) CS "Channel Status")
+ ((#x003A . #x0208) SQ "Channel Source Sequence")
+ ((#x003A . #x0209) SQ "Channel Source Modifiers Sequence")
+ ((#x003A . #x020A) SQ "Source Waveform Sequence")
+ ((#x003A . #x020B) SQ "Differential Waveform Source Modifiers")
+ ((#x003A . #x020C) LO "Channel Derivation Description")
+ ((#x003A . #x0210) DS "Channel Sensitivity")
+ ((#x003A . #x0211) SQ "Channel Sensitivity Units")
+ ((#x003A . #x0212) DS "Channel Sensitivity Correction Factor")
+ ((#x003A . #x0213) DS "Channel Baseline")
+ ((#x003A . #x0214) DS "Channel Time Skew")
+ ((#x003A . #x0215) DS "Channel Sample Skew")
+ ((#x003A . #x0216) SS/US "Channel Minimum Value")
+ ((#x003A . #x0217) SS/US "Channel Maximum Value")
+ ((#x003A . #x0218) DS "Channel Offset")
+ ((#x003A . #x021A) US "Waveform Bits Stored")
+ ((#x003A . #x0220) DS "Filter Low Frequency")
+ ((#x003A . #x0221) DS "Filter High Frequency")
+ ((#x003A . #x0222) DS "Notch Filter Frequency")
+ ((#x003A . #x0223) DS "Notch Filter Bandwidth")
+ ((#x003A . #x0300) SQ "Multiplexed Audio Channels Description Code Sequence")
+ ((#x003A . #x0301) IS "Channel Identification Code")
+ ((#x003A . #x0302) CS "Channel Mode")
+ ((#x003A . #x1000) SS/US "Waveform Data")
+
+ ;;---------------------------------------------
+ ;; Group 0040: "Procedure Step"
+ ((#x0040 . #x0000) UL "Group Length")
+ ((#x0040 . #x0001) AE "Scheduled Station AE Title")
+ ((#x0040 . #x0002) DA "Scheduled Procedure Step Start Date")
+ ((#x0040 . #x0003) TM "Scheduled Procedure Step Start Time")
+ ((#x0040 . #x0004) DA "Scheduled Procedure Step End Date")
+ ((#x0040 . #x0005) TM "Scheduled Procedure Step End Time")
+ ((#x0040 . #x0006) PN "Scheduled Performing Physician's Name")
+ ((#x0040 . #x0007) LO "Scheduled Procedure Step Description")
+ ((#x0040 . #x0008) SQ "Scheduled Protocol Code Sequence")
+ ((#x0040 . #x0009) SH "Scheduled Procedure Step ID")
+ ((#x0040 . #x000A) SQ "Stage Code Sequence")
+ ((#x0040 . #x000B) SQ "Scheduled Performing Physician Identification Sequence")
+ ((#x0040 . #x0010) SH "Scheduled Station Name")
+ ((#x0040 . #x0011) SH "Scheduled Procedure Step Location")
+ ((#x0040 . #x0012) LO "Pre-Medication")
+ ((#x0040 . #x0020) CS "Scheduled Procedure Step Status")
+ ((#x0040 . #x0100) SQ "Scheduled Procedure Step Sequence")
+ ((#x0040 . #x0220) SQ "Referenced Non-Image Composite SOP Instance Sequence")
+ ((#x0040 . #x0241) AE "Performed Station AE Title")
+ ((#x0040 . #x0242) SH "Performed Station Name")
+ ((#x0040 . #x0243) SH "Performed Location")
+ ((#x0040 . #x0244) DA "Performed Procedure Step Start Date")
+ ((#x0040 . #x0245) TM "Performed Procedure Step Start Time")
+ ((#x0040 . #x0250) DA "Performed Procedure Step End Date")
+ ((#x0040 . #x0251) TM "Performed Procedure Step End Time")
+ ((#x0040 . #x0252) CS "Performed Procedure Step Status")
+ ((#x0040 . #x0253) SH "Performed Procedure Step ID")
+ ((#x0040 . #x0254) LO "Performed Procedure Step Description")
+ ((#x0040 . #x0255) LO "Performed Procedure Type Description")
+ ((#x0040 . #x0260) SQ "Performed Protocol Code Sequence")
+ ((#x0040 . #x0270) SQ "Scheduled Step Attributes Sequence")
+ ((#x0040 . #x0275) SQ "Request Attributes Sequence")
+ ((#x0040 . #x0280) ST "Comments on the Performed Procedure Step")
+ ((#x0040 . #x0281) SQ "Performed Procedure Step Discontinuation Reason Code Sequence")
+ ((#x0040 . #x0293) SQ "Quantity Sequence")
+ ((#x0040 . #x0294) DS "Quantity")
+ ((#x0040 . #x0295) SQ "Measuring Units Sequence")
+ ((#x0040 . #x0296) SQ "Billing Item Sequence")
+ ((#x0040 . #x0300) US "Total Time of Fluoroscopy")
+ ((#x0040 . #x0301) US "Total Number of Exposures")
+ ((#x0040 . #x0302) US "Entrance Dose")
+ ((#x0040 . #x0303) US "Exposed Area")
+ ((#x0040 . #x0306) DS "Distance Source to Entrance")
+ ((#x0040 . #x0307) RET "Distance Source to Support (RET)")
+ ((#x0040 . #x030E) SQ "Exposure Dose Sequence")
+ ((#x0040 . #x0310) ST "Comments on Radiation Dose")
+ ((#x0040 . #x0312) DS "X-Ray Output")
+ ((#x0040 . #x0314) DS "Half Value Layer")
+ ((#x0040 . #x0316) DS "Organ Dose")
+ ((#x0040 . #x0318) CS "Organ Exposed")
+ ((#x0040 . #x0320) SQ "Billing Procedure Step Sequence")
+ ((#x0040 . #x0321) SQ "Film Consumption Sequence")
+ ((#x0040 . #x0324) SQ "Billing Supplies and Devices Sequence")
+ ((#x0040 . #x0330) RET "Referenced Procedure Step Sequence (RET)")
+ ((#x0040 . #x0340) SQ "Performed Series Sequence")
+ ((#x0040 . #x0400) LT "Comments on the Scheduled Procedure Step")
+ ((#x0040 . #x0440) SQ "Protocol Context Sequence")
+ ((#x0040 . #x0441) SQ "Content Item Modifier Sequence")
+ ((#x0040 . #x050A) LO "Specimen Accession Number")
+ ((#x0040 . #x0550) SQ "Specimen Sequence")
+ ((#x0040 . #x0551) LO "Specimen Identifier")
+ ((#x0040 . #x0552) SQ "Specimen Description Sequence")
+ ((#x0040 . #x0553) ST "Specimen Description")
+ ((#x0040 . #x0555) SQ "Acquisition Context Sequence")
+ ((#x0040 . #x0556) ST "Acquisition Context Description")
+ ((#x0040 . #x059A) SQ "Specimen Type Code Sequence")
+ ((#x0040 . #x06FA) LO "Slide Identifier")
+ ((#x0040 . #x071A) SQ "Image Center Point Coordinates Sequence")
+ ((#x0040 . #x072A) DS "X offset in Slide Coordinate System")
+ ((#x0040 . #x073A) DS "Y offset in Slide Coordinate System")
+ ((#x0040 . #x074A) DS "Z offset in Slide Coordinate System")
+ ((#x0040 . #x08D8) SQ "Pixel Spacing Sequence")
+ ((#x0040 . #x08DA) SQ "Coordinate System Axis Code Sequence")
+ ((#x0040 . #x08EA) SQ "Measurement Units Code Sequence")
+ ((#x0040 . #x09F8) SQ "Vital Stain Code Sequence")
+ ((#x0040 . #x1001) SH "Requested Procedure ID")
+ ((#x0040 . #x1002) LO "Reason for the Requested Procedure")
+ ((#x0040 . #x1003) SH "Requested Procedure Priority")
+ ((#x0040 . #x1004) LO "Patient Transport Arrangements")
+ ((#x0040 . #x1005) LO "Requested Procedure Location")
+ ((#x0040 . #x1006) RET "Placer Order Number / Procedure (RET)")
+ ((#x0040 . #x1007) RET "Filler Order Number / Procedure (RET)")
+ ((#x0040 . #x1008) LO "Confidentiality Code")
+ ((#x0040 . #x1009) SH "Reporting Priority")
+ ((#x0040 . #x100A) SQ "Reason for Requested Procedure Code Sequence")
+ ((#x0040 . #x1010) PN "Names of Intended Recipients of Results")
+ ((#x0040 . #x1011) SQ "Intended Recipients of Results Identification Sequence")
+ ((#x0040 . #x1101) SQ "Person Identification Code Sequence")
+ ((#x0040 . #x1102) ST "Person's Address")
+ ((#x0040 . #x1103) LO "Person's Telephone Numbers")
+ ((#x0040 . #x1400) LT "Requested Procedure Comments")
+ ((#x0040 . #x2001) RET "Reason for the Imaging Service Request (RET)")
+ ((#x0040 . #x2004) DA "Issue Date of Imaging Service Request")
+ ((#x0040 . #x2005) TM "Issue Time of Imaging Service Request")
+ ((#x0040 . #x2006) RET "Placer Order Number / Imaging Service Request (RET)")
+ ((#x0040 . #x2007) RET "Filler Order Number / Imaging Service Request (RET)")
+ ((#x0040 . #x2008) PN "Order Entered By")
+ ((#x0040 . #x2009) SH "Order Enterer's Location")
+ ((#x0040 . #x2010) SH "Order Callback Phone Number")
+ ((#x0040 . #x2016) LO "Placer Order Number / Imaging Service Request")
+ ((#x0040 . #x2017) LO "Filler Order Number / Imaging Service Request")
+ ((#x0040 . #x2400) LT "Imaging Service Request Comments")
+ ((#x0040 . #x3001) LO "Confidentiality Constraint on Patient Data Description")
+ ((#x0040 . #x4001) CS "General Purpose Scheduled Procedure Step Status")
+ ((#x0040 . #x4002) CS "General Purpose Performed Procedure Step Status")
+ ((#x0040 . #x4003) CS "General Purpose Scheduled Procedure Step Priority")
+ ((#x0040 . #x4004) SQ "Scheduled Processing Applications Code Sequence")
+ ((#x0040 . #x4005) DT "Scheduled Procedure Step Start Date and Time")
+ ((#x0040 . #x4006) CS "Multiple Copies Flag")
+ ((#x0040 . #x4007) SQ "Performed Processing Applications Code Sequence")
+ ((#x0040 . #x4009) SQ "Human Performer Code Sequence")
+ ((#x0040 . #x4010) DT "Scheduled Procedure Step Modification Date and Time")
+ ((#x0040 . #x4011) DT "Expected Completion Date and Time")
+ ((#x0040 . #x4015) SQ "Resulting General Purpose Performed Procedure Steps Sequence")
+ ((#x0040 . #x4016) SQ "Referenced General Purpose Scheduled Procedure Step Sequence")
+ ((#x0040 . #x4018) SQ "Scheduled Workitem Code Sequence")
+ ((#x0040 . #x4019) SQ "Performed Workitem Code Sequence")
+ ((#x0040 . #x4020) CS "Input Availability Flag")
+ ((#x0040 . #x4021) SQ "Input Information Sequence")
+ ((#x0040 . #x4022) SQ "Relevant Information Sequence")
+ ((#x0040 . #x4023) UI "Referenced General Purpose Scheduled Procedure Step Transaction UID")
+ ((#x0040 . #x4025) SQ "Scheduled Station Name Code Sequence")
+ ((#x0040 . #x4026) SQ "Scheduled Station Class Code Sequence")
+ ((#x0040 . #x4027) SQ "Scheduled Station Geographic Location Code Sequence")
+ ((#x0040 . #x4028) SQ "Performed Station Name Code Sequence")
+ ((#x0040 . #x4029) SQ "Performed Station Class Code Sequence")
+ ((#x0040 . #x4030) SQ "Performed Station Geographic Location Code Sequence")
+ ((#x0040 . #x4031) SQ "Requested Subsequent Workitem Code Sequence")
+ ((#x0040 . #x4032) SQ "Non-DICOM Output Code Sequence")
+ ((#x0040 . #x4033) SQ "Output Information Sequence")
+ ((#x0040 . #x4034) SQ "Scheduled Human Performers Sequence")
+ ((#x0040 . #x4035) SQ "Actual Human Performers Sequence")
+ ((#x0040 . #x4036) LO "Human Performer's Organization")
+ ((#x0040 . #x4037) PN "Human Performer's Name")
+ ((#x0040 . #x8302) DS "Entrance Dose in mGy")
+ ((#x0040 . #x9096) SQ "Real World Value Mapping Sequence")
+ ((#x0040 . #x9210) SH "LUT Label")
+ ((#x0040 . #x9211) SS/US "Real World Value Last Value Mapped")
+ ((#x0040 . #x9212) FD "Real World Value LUT Data")
+ ((#x0040 . #x9216) SS/US "Real World Value First Value Mapped")
+ ((#x0040 . #x9224) FD "Real World Value Intercept")
+ ((#x0040 . #x9225) FD "Real World Value Slope")
+ ((#x0040 . #xA027) LO "Verifying Organization")
+ ((#x0040 . #xA030) DT "Verification DateTime")
+ ((#x0040 . #xA032) DT "Observation DateTime")
+ ((#x0040 . #xA040) CS "Value Type")
+ ((#x0040 . #xA043) SQ "Concept Name Code Sequence")
+ ((#x0040 . #xA050) CS "Continuity Of Content")
+ ((#x0040 . #xA073) SQ "Verifying Observer Sequence")
+ ((#x0040 . #xA075) PN "Verifying Observer Name")
+ ((#x0040 . #xA088) SQ "Verifying Observer Identification Code Sequence")
+ ((#x0040 . #xA0A0) CS "Referenced Type of Data")
+ ((#x0040 . #xA0B0) US "Referenced Waveform Channels")
+ ((#x0040 . #xA120) DT "DateTime")
+ ((#x0040 . #xA121) DA "Date")
+ ((#x0040 . #xA122) TM "Time")
+ ((#x0040 . #xA123) PN "Person Name")
+ ((#x0040 . #xA124) UI "UID")
+ ((#x0040 . #xA130) CS "Temporal Range Type")
+ ((#x0040 . #xA132) UL "Referenced Sample Positions")
+ ((#x0040 . #xA136) US "Referenced Frame Numbers")
+ ((#x0040 . #xA138) DS "Referenced Time Offsets")
+ ((#x0040 . #xA13A) DT "Referenced Datetime")
+ ((#x0040 . #xA160) UT "Text Value")
+ ((#x0040 . #xA168) SQ "Concept Code Sequence")
+ ((#x0040 . #xA16A) ST "Bibliographics Citation")
+ ((#x0040 . #xA170) SQ "Purpose of Reference Code Sequence")
+ ((#x0040 . #xA180) US "Annotation Group Number")
+ ((#x0040 . #xA195) SQ "Modifier Code Sequence")
+ ((#x0040 . #xA300) SQ "Measured Value Sequence")
+ ((#x0040 . #xA301) SQ "Numeric Value Qualifier Code Sequence")
+ ((#x0040 . #xA30A) DS "Numeric Value")
+ ((#x0040 . #xA353) ST "Address")
+ ((#x0040 . #xA354) LO "Telephone Number")
+ ((#x0040 . #xA360) SQ "Predecessor Documents Sequence")
+ ((#x0040 . #xA370) SQ "Referenced Request Sequence")
+ ((#x0040 . #xA372) SQ "Performed Procedure Code Sequence")
+ ((#x0040 . #xA375) SQ "Current Requested Procedure Evidence Sequence")
+ ((#x0040 . #xA385) SQ "Pertinent Other Evidence Sequence")
+ ((#x0040 . #xA491) CS "Completion Flag")
+ ((#x0040 . #xA492) LO "Completion Flag Description")
+ ((#x0040 . #xA493) CS "Verification Flag")
+ ((#x0040 . #xA504) SQ "Content Template Sequence")
+ ((#x0040 . #xA525) SQ "Identical Documents Sequence")
+ ((#x0040 . #xA730) SQ "Content Sequence")
+ ((#x0040 . #xA992) ST "Uniform Resource Locator")
+ ((#x0040 . #xB020) SQ "Annotation Sequence")
+ ((#x0040 . #xDB00) CS "Template Identifier")
+ ((#x0040 . #xDB06) RET "Template Version (RET)")
+ ((#x0040 . #xDB07) RET "Template Local Version (RET)")
+ ((#x0040 . #xDB0B) RET "Template Extension Flag (RET)")
+ ((#x0040 . #xDB0C) RET "Template Extension Organization UID (RET)")
+ ((#x0040 . #xDB0D) RET "Template Extension Creator UID (RET)")
+ ((#x0040 . #xDB73) UL "Referenced Content Item Identifier")
+
+ ;;---------------------------------------------
+ ;; Group 0050: "Device"
+ ((#x0050 . #x0000) UL "Group Length")
+ ((#x0050 . #x0004) CS "Calibration Image")
+ ((#x0050 . #x0010) SQ "Device Sequence")
+ ((#x0050 . #x0014) DS "Device Length")
+ ((#x0050 . #x0016) DS "Device Diameter")
+ ((#x0050 . #x0017) CS "Device Diameter Units")
+ ((#x0050 . #x0018) DS "Device Volume")
+ ((#x0050 . #x0019) DS "Inter-marker Distance")
+ ((#x0050 . #x0020) LO "Device Description")
+
+ ;;---------------------------------------------
+ ;; Group 0054: "NM Image"
+ ((#x0054 . #x0000) UL "Group Length")
+ ((#x0054 . #x0010) US "Energy Window Vector")
+ ((#x0054 . #x0011) US "Number of Energy Windows")
+ ((#x0054 . #x0012) SQ "Energy Window Information Sequence")
+ ((#x0054 . #x0013) SQ "Energy Window Range Sequence")
+ ((#x0054 . #x0014) DS "Energy Window Lower Limit")
+ ((#x0054 . #x0015) DS "Energy Window Upper Limit")
+ ((#x0054 . #x0016) SQ "Radiopharmaceutical Information Sequence")
+ ((#x0054 . #x0017) IS "Residual Syringe Counts")
+ ((#x0054 . #x0018) SH "Energy Window Name")
+ ((#x0054 . #x0020) US "Detector Vector")
+ ((#x0054 . #x0021) US "Number of Detectors")
+ ((#x0054 . #x0022) SQ "Detector Information Sequence")
+ ((#x0054 . #x0030) US "Phase Vector")
+ ((#x0054 . #x0031) US "Number of Phases")
+ ((#x0054 . #x0032) SQ "Phase Information Sequence")
+ ((#x0054 . #x0033) US "Number of Frames in Phase")
+ ((#x0054 . #x0036) IS "Phase Delay")
+ ((#x0054 . #x0038) IS "Pause Between Frames")
+ ((#x0054 . #x0039) CS "Phase Description")
+ ((#x0054 . #x0050) US "Rotation Vector")
+ ((#x0054 . #x0051) US "Number of Rotations")
+ ((#x0054 . #x0052) SQ "Rotation Information Sequence")
+ ((#x0054 . #x0053) US "Number of Frames in Rotation")
+ ((#x0054 . #x0060) US "R-R Interval Vector")
+ ((#x0054 . #x0061) US "Number of R-R Intervals")
+ ((#x0054 . #x0062) SQ "Gated Information Sequence")
+ ((#x0054 . #x0063) SQ "Data Information Sequence")
+ ((#x0054 . #x0070) US "Time Slot Vector")
+ ((#x0054 . #x0071) US "Number of Time Slots")
+ ((#x0054 . #x0072) SQ "Time Slot Information Sequence")
+ ((#x0054 . #x0073) DS "Time Slot Time")
+ ((#x0054 . #x0080) US "Slice Vector")
+ ((#x0054 . #x0081) US "Number of Slices")
+ ((#x0054 . #x0090) US "Angular View Vector")
+ ((#x0054 . #x0100) US "Time Slice Vector")
+ ((#x0054 . #x0101) US "Number of Time Slices")
+ ((#x0054 . #x0200) DS "Start Angle")
+ ((#x0054 . #x0202) CS "Type of Detector Motion")
+ ((#x0054 . #x0210) IS "Trigger Vector")
+ ((#x0054 . #x0211) US "Number of Triggers in Phase")
+ ((#x0054 . #x0220) SQ "View Code Sequence")
+ ((#x0054 . #x0222) SQ "View Modifier Code Sequence")
+ ((#x0054 . #x0300) SQ "Radionuclide Code Sequence")
+ ((#x0054 . #x0302) SQ "Administration Route Code Sequence")
+ ((#x0054 . #x0304) SQ "Radiopharmaceutical Code Sequence")
+ ((#x0054 . #x0306) SQ "Calibration Data Sequence")
+ ((#x0054 . #x0308) US "Energy Window Number")
+ ((#x0054 . #x0400) SH "Image ID")
+ ((#x0054 . #x0410) SQ "Patient Orientation Code Sequence")
+ ((#x0054 . #x0412) SQ "Patient Orientation Modifier Code Sequence")
+ ((#x0054 . #x0414) SQ "Patient Gantry Relationship Code Sequence")
+ ((#x0054 . #x0500) CS "Slice Progression Direction")
+ ((#x0054 . #x1000) CS "Series Type")
+ ((#x0054 . #x1001) CS "Units")
+ ((#x0054 . #x1002) CS "Counts Source")
+ ((#x0054 . #x1004) CS "Reprojection Method")
+ ((#x0054 . #x1100) CS "Randoms Correction Method")
+ ((#x0054 . #x1101) LO "Attenuation Correction Method")
+ ((#x0054 . #x1102) CS "Decay Correction")
+ ((#x0054 . #x1103) LO "Reconstruction Method")
+ ((#x0054 . #x1104) LO "Detector Lines of Response Used")
+ ((#x0054 . #x1105) LO "Scatter Correction Method")
+ ((#x0054 . #x1200) DS "Axial Acceptance")
+ ((#x0054 . #x1201) IS "Axial Mash")
+ ((#x0054 . #x1202) IS "Transverse Mash")
+ ((#x0054 . #x1203) DS "Detector Element Size")
+ ((#x0054 . #x1210) DS "Coincidence Window Width")
+ ((#x0054 . #x1220) CS "Secondary Counts Type")
+ ((#x0054 . #x1300) DS "Frame Reference Time")
+ ((#x0054 . #x1310) IS "Primary (Prompts) Counts Accumulated")
+ ((#x0054 . #x1311) IS "Secondary Counts Accumulated")
+ ((#x0054 . #x1320) DS "Slice Sensitivity Factor")
+ ((#x0054 . #x1321) DS "Decay Factor")
+ ((#x0054 . #x1322) DS "Dose Calibration Factor")
+ ((#x0054 . #x1323) DS "Scatter Fraction Factor")
+ ((#x0054 . #x1324) DS "Dead Time Factor")
+ ((#x0054 . #x1330) US "Image Index")
+ ((#x0054 . #x1400) CS "Counts Included")
+ ((#x0054 . #x1401) CS "Dead Time Correction Flag")
+
+ ;;---------------------------------------------
+ ;; Group 0060: "Histogram"
+ ((#x0060 . #x0000) UL "Group Length")
+ ((#x0060 . #x3000) SQ "Histogram Sequence")
+ ((#x0060 . #x3002) US "Histogram Number of Bins")
+ ((#x0060 . #x3004) SS/US "Histogram First Bin Value")
+ ((#x0060 . #x3006) SS/US "Histogram Last Bin Value")
+ ((#x0060 . #x3008) US "Histogram Bin Width")
+ ((#x0060 . #x3010) LO "Histogram Explanation")
+ ((#x0060 . #x3020) UL "Histogram Data")
+
+ ;;---------------------------------------------
+ ;; Group 0070: "Graphic"
+ ((#x0070 . #x0000) UL "Group Length")
+ ((#x0070 . #x0001) SQ "Graphic Annotation Sequence")
+ ((#x0070 . #x0002) CS "Graphic Layer")
+ ((#x0070 . #x0003) CS "Bounding Box Annotation Units")
+ ((#x0070 . #x0004) CS "Anchor Point Annotation Units")
+ ((#x0070 . #x0005) CS "Graphic Annotation Units")
+ ((#x0070 . #x0006) ST "Unformatted Text Value")
+ ((#x0070 . #x0008) SQ "Text Object Sequence")
+ ((#x0070 . #x0009) SQ "Graphic Object Sequence")
+ ((#x0070 . #x0010) FL "Bounding Box Top Left Hand Corner")
+ ((#x0070 . #x0011) FL "Bounding Box Bottom Right Hand Corner")
+ ((#x0070 . #x0012) CS "Bounding Box Text Horizontal Justification")
+ ((#x0070 . #x0014) FL "Anchor Point")
+ ((#x0070 . #x0015) CS "Anchor Point Visibility")
+ ((#x0070 . #x0020) US "Graphic Dimensions")
+ ((#x0070 . #x0021) US "Number of Graphic Points")
+ ((#x0070 . #x0022) FL "Graphic Data")
+ ((#x0070 . #x0023) CS "Graphic Type")
+ ((#x0070 . #x0024) CS "Graphic Filled")
+ ((#x0070 . #x0041) CS "Image Horizontal Flip")
+ ((#x0070 . #x0042) US "Image Rotation")
+ ((#x0070 . #x0052) SL "Displayed Area Top Left Hand Corner")
+ ((#x0070 . #x0053) SL "Displayed Area Bottom Right Hand Corner")
+ ((#x0070 . #x005A) SQ "Displayed Area Selection Sequence")
+ ((#x0070 . #x0060) SQ "Graphic Layer Sequence")
+ ((#x0070 . #x0062) IS "Graphic Layer Order")
+ ((#x0070 . #x0066) US "Graphic Layer Recommended Display Grayscale Value")
+ ((#x0070 . #x0067) US "Graphic Layer Recommended Display RGB Value")
+ ((#x0070 . #x0068) LO "Graphic Layer Description")
+ ((#x0070 . #x0080) CS "Content Label")
+ ((#x0070 . #x0081) LO "Content Description")
+ ((#x0070 . #x0082) DA "Presentation Creation Date")
+ ((#x0070 . #x0083) TM "Presentation Creation Time")
+ ((#x0070 . #x0084) PN "Content Creator's Name")
+ ((#x0070 . #x0100) CS "Presentation Size Mode")
+ ((#x0070 . #x0101) DS "Presentation Pixel Spacing")
+ ((#x0070 . #x0102) IS "Presentation Pixel Aspect Ratio")
+ ((#x0070 . #x0103) FL "Presentation Pixel Magnification Ratio")
+ ((#x0070 . #x0306) CS "Shape Type")
+ ((#x0070 . #x0308) SQ "Registration Sequence")
+ ((#x0070 . #x0309) SQ "Matrix Registration Sequence")
+ ((#x0070 . #x030A) SQ "Matrix Sequence")
+ ((#x0070 . #x030C) CS "Frame of Reference Transformation Matrix Type")
+ ((#x0070 . #x030D) SQ "Registration Type Code Sequence")
+ ((#x0070 . #x030F) ST "Fiducial Description")
+ ((#x0070 . #x0310) SH "Fiducial Identifier")
+ ((#x0070 . #x0311) SQ "Fiducial Identifier Code Sequence")
+ ((#x0070 . #x0312) FD "Contour Uncertainty Radius")
+ ((#x0070 . #x0314) SQ "Used Fiducials Sequence")
+ ((#x0070 . #x0318) SQ "Graphic Coordinates Data Sequence")
+ ((#x0070 . #x031A) UI "Fiducial UID")
+ ((#x0070 . #x031C) SQ "Fiducial Set Sequence")
+ ((#x0070 . #x031E) SQ "Fiducial Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 0088: "Media"
+ ((#x0088 . #x0000) UL "Group Length ")
+ ((#x0088 . #x0130) SH "Storage Media File-set ID")
+ ((#x0088 . #x0140) UI "Storage Media File-set UID")
+ ((#x0088 . #x0200) SQ "Icon Image Sequence")
+ ((#x0088 . #x0904) LO "Topic Title")
+ ((#x0088 . #x0906) ST "Topic Subject")
+ ((#x0088 . #x0910) LO "Topic Author")
+ ((#x0088 . #x0912) LO "Topic Key Words")
+
+ ;;---------------------------------------------
+ ;; Group 0100: "Authorization"
+ ((#x0100 . #x0000) UL "Group Length")
+ ((#x0100 . #x0410) CS "SOP Instance Status")
+ ((#x0100 . #x0420) DT "SOP Authorization Date and Time")
+ ((#x0100 . #x0424) LT "SOP Authorization Comment")
+ ((#x0100 . #x0426) LO "Authorization Equipment Certification Number")
+
+ ;;---------------------------------------------
+ ;; Group 0400: "Encryption"
+ ((#x0400 . #x0000) UL "Group Length")
+ ((#x0400 . #x0005) US "MAC ID Number")
+ ((#x0400 . #x0010) UI "MAC Calculation Transfer Syntax UID")
+ ((#x0400 . #x0015) CS "MAC Algorithm")
+ ((#x0400 . #x0020) AT "Data Elements Signed")
+ ((#x0400 . #x0100) UI "Digital Signature UID")
+ ((#x0400 . #x0105) DT "Digital Signature DateTime")
+ ((#x0400 . #x0110) CS "Certificate Type")
+ ((#x0400 . #x0115) OB "Certificate of Signer")
+ ((#x0400 . #x0120) OB "Signature")
+ ((#x0400 . #x0305) CS "Certified Timestamp Type")
+ ((#x0400 . #x0310) OB "Certified Timestamp")
+ ((#x0400 . #x0500) SQ "Encrypted Attributes Sequence")
+ ((#x0400 . #x0510) UI "Encrypted Content Transfer Syntax UID")
+ ((#x0400 . #x0520) OB "Encrypted Content")
+ ((#x0400 . #x0550) SQ "Modified Attributes Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 2000: "Basic Film Session"
+ ((#x2000 . #x0000) UL "Group Length")
+ ((#x2000 . #x0010) IS "Number of Copies")
+ ((#x2000 . #x001E) SQ "Printer Configuration Sequence")
+ ((#x2000 . #x0020) CS "Print Priority")
+ ((#x2000 . #x0030) CS "Medium Type")
+ ((#x2000 . #x0040) CS "Film Destination")
+ ((#x2000 . #x0050) LO "Film Session Label")
+ ((#x2000 . #x0060) IS "Memory Allocation")
+ ((#x2000 . #x0061) IS "Maximum Memory Allocation")
+ ((#x2000 . #x0062) CS "Color Image Printing Flag")
+ ((#x2000 . #x0063) CS "Collation Flag")
+ ((#x2000 . #x0065) CS "Annotation Flag")
+ ((#x2000 . #x0067) CS "Image Overlay Flag")
+ ((#x2000 . #x0069) CS "Presentation LUT Flag")
+ ((#x2000 . #x006A) CS "Image Box Presentation LUT Flag")
+ ((#x2000 . #x00A0) US "Memory Bit Depth")
+ ((#x2000 . #x00A1) US "Printing Bit Depth")
+ ((#x2000 . #x00A2) SQ "Media Installed Sequence")
+ ((#x2000 . #x00A4) SQ "Other Media Available Sequence")
+ ((#x2000 . #x00A8) SQ "Supported Image Display Formats Sequence")
+ ((#x2000 . #x0500) SQ "Referenced Film Box Sequence")
+ ((#x2000 . #x0510) SQ "Referenced Stored Print Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 2010: "Basic Film Box"
+ ((#x2010 . #x0000) UL "Group Length")
+ ((#x2010 . #x0010) ST "Image Display Format")
+ ((#x2010 . #x0030) CS "Annotation Display Format ID")
+ ((#x2010 . #x0040) CS "Film Orientation")
+ ((#x2010 . #x0050) CS "Film Size ID")
+ ((#x2010 . #x0052) CS "Printer Resolution ID")
+ ((#x2010 . #x0054) CS "Default Printer Resolution ID")
+ ((#x2010 . #x0060) CS "Magnification Type")
+ ((#x2010 . #x0080) CS "Smoothing Type")
+ ((#x2010 . #x00A6) CS "Default Magnification Type")
+ ((#x2010 . #x00A7) CS "Other Magnification Types Available")
+ ((#x2010 . #x00A8) CS "Default Smoothing Type")
+ ((#x2010 . #x00A9) CS "Other Smoothing Types Available")
+ ((#x2010 . #x0100) CS "Border Density")
+ ((#x2010 . #x0110) CS "Empty Image Density")
+ ((#x2010 . #x0120) US "Min Density")
+ ((#x2010 . #x0130) US "Maximum density of images on the film")
+ ((#x2010 . #x0140) CS "Trim")
+ ((#x2010 . #x0150) ST "Configuration Information")
+ ((#x2010 . #x0152) LT "Configuration Information Description")
+ ((#x2010 . #x0154) IS "Maximum Collated Films")
+ ((#x2010 . #x015E) US "Illumination")
+ ((#x2010 . #x0160) US "Reflected Ambient Light")
+ ((#x2010 . #x0376) DS "Printer Pixel Spacing")
+ ((#x2010 . #x0500) SQ "Referenced Film Session Sequence")
+ ((#x2010 . #x0510) SQ "Referenced Image Box Sequence")
+ ((#x2010 . #x0520) SQ "Referenced Basic Annotation Box Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 2020: "Basic Image Box"
+ ((#x2020 . #x0000) UL "Group Length")
+ ((#x2020 . #x0010) US "Image Position")
+ ((#x2020 . #x0020) CS "Polarity")
+ ((#x2020 . #x0030) DS "Requested Image Size")
+ ((#x2020 . #x0040) CS "Requested Decimate/Crop Behavior")
+ ((#x2020 . #x0050) CS "Requested Resolution ID")
+ ((#x2020 . #x00A0) CS "Requested Image Size Flag")
+ ((#x2020 . #x00A2) CS "Decimate/Crop Result")
+ ((#x2020 . #x0110) SQ "Basic Grayscale Image Sequence")
+ ((#x2020 . #x0111) SQ "Basic Color Image Sequence")
+ ((#x2020 . #x0130) RET "Referenced Image Overlay Box Sequence (RET)")
+ ((#x2020 . #x0140) RET "Referenced VOI LUT Box Sequence (RET)")
+
+ ;;---------------------------------------------
+ ;; Group 2030: "Basic Annotation Box"
+ ((#x2030 . #x0000) UL "Group Length")
+ ((#x2030 . #x0010) US "Annotation Position")
+ ((#x2030 . #x0020) LO "Text String")
+
+ ;;---------------------------------------------
+ ;; Group 2040: "Basic Image Overlay Box"
+ ((#x2040 . #x0000) UL "Group Length")
+ ((#x2040 . #x0010) SQ "Referenced Overlay Plane Sequence")
+ ((#x2040 . #x0011) US "Referenced Overlay Plane Groups")
+ ((#x2040 . #x0020) SQ "Overlay Pixel Data Sequence")
+ ((#x2040 . #x0060) CS "Overlay Magnification Type")
+ ((#x2040 . #x0070) CS "Overlay Smoothing Type")
+ ((#x2040 . #x0072) CS "Overlay or Image Magnification")
+ ((#x2040 . #x0074) US "Magnify to Number of Columns")
+ ((#x2040 . #x0080) CS "Overlay Foreground Density")
+ ((#x2040 . #x0082) CS "Overlay Background Density")
+ ((#x2040 . #x0090) RET "Overlay Mode (RET)")
+ ((#x2040 . #x0100) RET "Threshold Density (RET)")
+ ((#x2040 . #x0500) RET "Referenced Image Box Sequence (RET)")
+
+ ;;---------------------------------------------
+ ;; Group 2050: "Look-Up Table"
+ ((#x2050 . #x0000) UL "Group Length")
+ ((#x2050 . #x0010) SQ "Presentation LUT Sequence")
+ ((#x2050 . #x0020) CS "Presentation LUT Shape")
+ ((#x2050 . #x0500) SQ "Referenced Presentation LUT Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 2100: "Print Job"
+ ((#x2100 . #x0000) UL "Group Length")
+ ((#x2100 . #x0010) SH "Print Job ID")
+ ((#x2100 . #x0020) CS "Execution Status")
+ ((#x2100 . #x0030) CS "Execution Status Info")
+ ((#x2100 . #x0040) DA "Creation Date")
+ ((#x2100 . #x0050) TM "Creation Time")
+ ((#x2100 . #x0070) AE "Originator")
+ ((#x2100 . #x0140) AE "Destination AE")
+ ((#x2100 . #x0160) SH "Owner ID")
+ ((#x2100 . #x0170) IS "Number of Films")
+ ((#x2100 . #x0500) SQ "Referenced Print Job Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 2110: "Printer"
+ ((#x2110 . #x0000) UL "Group Length")
+ ((#x2110 . #x0010) CS "Printer Status")
+ ((#x2110 . #x0020) CS "Printer Status Info")
+ ((#x2110 . #x0030) LO "Printer Name")
+ ((#x2110 . #x0099) SH "Print Queue ID")
+
+ ;;---------------------------------------------
+ ;; Group 2120: "Print Queue"
+ ((#x2120 . #x0000) UL "Group Length")
+ ((#x2120 . #x0010) CS "Queue Status")
+ ((#x2120 . #x0050) SQ "Print Job Description Sequence")
+ ((#x2120 . #x0070) SQ "Referenced Print Job Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 2130: "Print Management"
+ ((#x2130 . #x0000) UL "Group Length")
+ ((#x2130 . #x0010) SQ "Print Management Capabilities Sequence")
+ ((#x2130 . #x0015) SQ "Printer Characteristics Sequence")
+ ((#x2130 . #x0030) SQ "Film Box Content Sequence")
+ ((#x2130 . #x0040) SQ "Image Box Content Sequence")
+ ((#x2130 . #x0050) SQ "Annotation Content Sequence")
+ ((#x2130 . #x0060) SQ "Image Overlay Box Content Sequence")
+ ((#x2130 . #x0080) SQ "Presentation LUT Content Sequence")
+ ((#x2130 . #x00A0) SQ "Proposed Study Sequence")
+ ((#x2130 . #x00C0) SQ "Original Image Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 2200: "Media Label"
+ ((#x2200 . #x0000) UL "Group Length")
+ ((#x2200 . #x0001) CS "Label Using Information Extracted From Instances")
+ ((#x2200 . #x0002) UT "Label Text")
+ ((#x2200 . #x0003) CS "Label Style Selection")
+ ((#x2200 . #x0005) LT "Barcode Value")
+ ((#x2200 . #x0006) CS "Barcode Symbology")
+ ((#x2200 . #x0007) CS "Allow Media Splitting")
+ ((#x2200 . #x0008) CS "Include Non-DICOM Objects")
+ ((#x2200 . #x0009) CS "Include Display Application")
+ ((#x2200 . #x000A) CS "Preserve Composite Instances After Media Creation")
+ ((#x2200 . #x000B) US "Total Number of Pieces of Media Created")
+ ((#x2200 . #x000C) LO "Requested Media Application Profile")
+ ((#x2200 . #x000D) SQ "Referenced Storage Media Sequence")
+ ((#x2200 . #x000E) AT "Failure Attributes")
+ ((#x2200 . #x000F) CS "Allow Lossy Compression")
+ ((#x2200 . #x0020) CS "Request Priority")
+
+ ;;---------------------------------------------
+ ;; Group 3002: "Radiation Treatment"
+ ((#x3002 . #x0000) UL "Group Length")
+ ((#x3002 . #x0002) SH "RT Image Label")
+ ((#x3002 . #x0003) LO "RT Image Name")
+ ((#x3002 . #x0004) ST "RT Image Description")
+ ((#x3002 . #x000A) CS "Reported Values Origin")
+ ((#x3002 . #x000C) CS "RT Image Plane")
+ ((#x3002 . #x000D) DS "X-Ray Image Receptor Translation")
+ ((#x3002 . #x000E) DS "X-Ray Image Receptor Angle")
+ ((#x3002 . #x0010) DS "RT Image Orientation")
+ ((#x3002 . #x0011) DS "Image Plane Pixel Spacing")
+ ((#x3002 . #x0012) DS "RT Image Position")
+ ((#x3002 . #x0020) SH "Radiation Machine Name")
+ ((#x3002 . #x0022) DS "Radiation Machine SAD")
+ ((#x3002 . #x0024) DS "Radiation Machine SSD")
+ ((#x3002 . #x0026) DS "RT Image SID")
+ ((#x3002 . #x0028) DS "Source to Reference Object Distance")
+ ((#x3002 . #x0029) IS "Fraction Number")
+ ((#x3002 . #x0030) SQ "Exposure Sequence")
+ ((#x3002 . #x0032) DS "Meterset Exposure")
+ ((#x3002 . #x0034) DS "Diaphragm Position")
+ ((#x3002 . #x0040) SQ "Fluence Map Sequence")
+ ((#x3002 . #x0041) CS "Fluence Data Source")
+ ((#x3002 . #x0042) DS "Fluence Data Scale")
+
+ ;;---------------------------------------------
+ ;; Group 3004: "Dose Volume Histogram"
+ ((#x3004 . #x0000) UL "Group Length")
+ ((#x3004 . #x0001) CS "DVH Type")
+ ((#x3004 . #x0002) CS "Dose Units")
+ ((#x3004 . #x0004) CS "Dose Type")
+ ((#x3004 . #x0006) LO "Dose Comment")
+ ((#x3004 . #x0008) DS "Normalization Point")
+ ((#x3004 . #x000A) CS "Dose Summation Type")
+ ((#x3004 . #x000C) DS "Grid Frame Offset Vector")
+ ((#x3004 . #x000E) DS "Dose Grid Scaling")
+ ((#x3004 . #x0010) SQ "RT Dose ROI Sequence")
+ ((#x3004 . #x0012) DS "Dose Value")
+ ((#x3004 . #x0014) CS "Tissue Heterogeneity Correction")
+ ((#x3004 . #x0040) DS "DVH Normalization Point")
+ ((#x3004 . #x0042) DS "DVH Normalization Dose Value")
+ ((#x3004 . #x0050) SQ "DVH Sequence")
+ ((#x3004 . #x0052) DS "DVH Dose Scaling")
+ ((#x3004 . #x0054) CS "DVH Volume Units")
+ ((#x3004 . #x0056) IS "DVH Number of Bins")
+ ((#x3004 . #x0058) DS "DVH Data")
+ ((#x3004 . #x0060) SQ "DVH Referenced ROI Sequence")
+ ((#x3004 . #x0062) CS "DVH ROI Contribution Type")
+ ((#x3004 . #x0070) DS "DVH Minimum Dose")
+ ((#x3004 . #x0072) DS "DVH Maximum Dose")
+ ((#x3004 . #x0074) DS "DVH Mean Dose")
+
+ ;;---------------------------------------------
+ ;; Group 3006: "Structure Set"
+ ((#x3006 . #x0000) UL "Group Length")
+ ((#x3006 . #x0002) SH "Structure Set Label")
+ ((#x3006 . #x0004) LO "Structure Set Name")
+ ((#x3006 . #x0006) ST "Structure Set Description")
+ ((#x3006 . #x0008) DA "Structure Set Date")
+ ((#x3006 . #x0009) TM "Structure Set Time")
+ ((#x3006 . #x0010) SQ "Referenced Frame of Reference Sequence")
+ ((#x3006 . #x0012) SQ "RT Referenced Study Sequence")
+ ((#x3006 . #x0014) SQ "RT Referenced Series Sequence")
+ ((#x3006 . #x0016) SQ "Contour Image Sequence")
+ ((#x3006 . #x0020) SQ "Structure Set ROI Sequence")
+ ((#x3006 . #x0022) IS "ROI Number")
+ ((#x3006 . #x0024) UI "Referenced Frame of Reference UID")
+ ((#x3006 . #x0026) LO "ROI Name")
+ ((#x3006 . #x0028) ST "ROI Description")
+ ((#x3006 . #x002A) IS "ROI Display Color")
+ ((#x3006 . #x002C) DS "ROI Volume")
+ ((#x3006 . #x0030) SQ "RT Related ROI Sequence")
+ ((#x3006 . #x0033) CS "RT ROI Relationship")
+ ((#x3006 . #x0036) CS "ROI Generation Algorithm")
+ ((#x3006 . #x0038) LO "ROI Generation Description")
+ ((#x3006 . #x0039) SQ "ROI Contour Sequence")
+ ((#x3006 . #x0040) SQ "Contour Sequence")
+ ((#x3006 . #x0042) CS "Contour Geometric Type")
+ ((#x3006 . #x0044) DS "Contour Slab Thickness")
+ ((#x3006 . #x0045) DS "Contour Offset Vector")
+ ((#x3006 . #x0046) IS "Number of Contour Points")
+ ((#x3006 . #x0048) IS "Contour Number")
+ ((#x3006 . #x0049) IS "Attached Contours")
+ ((#x3006 . #x0050) DS "Contour Data")
+ ((#x3006 . #x0080) SQ "RT ROI Observations Sequence")
+ ((#x3006 . #x0082) IS "Observation Number")
+ ((#x3006 . #x0084) IS "Referenced ROI Number")
+ ((#x3006 . #x0085) SH "ROI Observation Label")
+ ((#x3006 . #x0086) SQ "RT ROI Identification Code Sequence")
+ ((#x3006 . #x0088) ST "ROI Observation Description")
+ ((#x3006 . #x00A0) SQ "Related RT ROI Observations Sequence")
+ ((#x3006 . #x00A4) CS "RT ROI Interpreted Type")
+ ((#x3006 . #x00A6) PN "ROI Interpreter")
+ ((#x3006 . #x00B0) SQ "ROI Physical Properties Sequence")
+ ((#x3006 . #x00B2) CS "ROI Physical Property")
+ ((#x3006 . #x00B4) DS "ROI Physical Property Value")
+ ((#x3006 . #x00C0) SQ "Frame of Reference Relationship Sequence")
+ ((#x3006 . #x00C2) UI "Related Frame of Reference UID")
+ ((#x3006 . #x00C4) CS "Frame of Reference Transformation Type")
+ ((#x3006 . #x00C6) DS "Frame of Reference Transformation Matrix6")
+ ((#x3006 . #x00C8) LO "Frame of Reference Transformation Comment")
+
+ ;;---------------------------------------------
+ ;; Group 3008: "Dose"
+ ((#x3008 . #x0000) UL "Group Length")
+ ((#x3008 . #x0010) SQ "Measured Dose Reference Sequence")
+ ((#x3008 . #x0012) ST "Measured Dose Description")
+ ((#x3008 . #x0014) CS "Measured Dose Type")
+ ((#x3008 . #x0016) DS "Measured Dose Value")
+ ((#x3008 . #x0020) SQ "Treatment Session Beam Sequence")
+ ((#x3008 . #x0022) IS "Current Fraction Number")
+ ((#x3008 . #x0024) DA "Treatment Control Point Date")
+ ((#x3008 . #x0025) TM "Treatment Control Point Time")
+ ((#x3008 . #x002A) CS "Treatment Termination Status")
+ ((#x3008 . #x002B) SH "Treatment Termination Code")
+ ((#x3008 . #x002C) CS "Treatment Verification Status")
+ ((#x3008 . #x0030) SQ "Referenced Treatment Record Sequence")
+ ((#x3008 . #x0032) DS "Specified Primary Meterset")
+ ((#x3008 . #x0033) DS "Specified Secondary Meterset")
+ ((#x3008 . #x0036) DS "Delivered Primary Meterset")
+ ((#x3008 . #x0037) DS "Delivered Secondary Meterset")
+ ((#x3008 . #x003A) DS "Specified Treatment Time")
+ ((#x3008 . #x003B) DS "Delivered Treatment Time")
+ ((#x3008 . #x0040) SQ "Control Point Delivery Sequence")
+ ((#x3008 . #x0042) DS "Specified Meterset")
+ ((#x3008 . #x0044) DS "Delivered Meterset")
+ ((#x3008 . #x0048) DS "Dose Rate Delivered")
+ ((#x3008 . #x0050) SQ "Treatment Summary Calculated Dose Reference Sequence")
+ ((#x3008 . #x0052) DS "Cumulative Dose to Dose Reference")
+ ((#x3008 . #x0054) DA "First Treatment Date")
+ ((#x3008 . #x0056) DA "Most Recent Treatment Date")
+ ((#x3008 . #x005A) IS "Number of Fractions Delivered")
+ ((#x3008 . #x0060) SQ "Override Sequence")
+ ((#x3008 . #x0062) AT "Override Parameter Pointer")
+ ((#x3008 . #x0064) IS "Measured Dose Reference Number")
+ ((#x3008 . #x0066) ST "Override Reason")
+ ((#x3008 . #x0070) SQ "Calculated Dose Reference Sequence")
+ ((#x3008 . #x0072) IS "Calculated Dose Reference Number")
+ ((#x3008 . #x0074) ST "Calculated Dose Reference Description")
+ ((#x3008 . #x0076) DS "Calculated Dose Reference Dose Value")
+ ((#x3008 . #x0078) DS "Start Meterset")
+ ((#x3008 . #x007A) DS "End Meterset")
+ ((#x3008 . #x0080) SQ "Referenced Measured Dose Reference Sequence")
+ ((#x3008 . #x0082) IS "Referenced Measured Dose Reference Number")
+ ((#x3008 . #x0090) SQ "Referenced Calculated Dose Reference Sequence")
+ ((#x3008 . #x0092) IS "Referenced Calculated Dose Reference Number")
+ ((#x3008 . #x00A0) SQ "Beam Limiting Device Leaf Pairs Sequence")
+ ((#x3008 . #x00B0) SQ "Recorded Wedge Sequence")
+ ((#x3008 . #x00C0) SQ "Recorded Compensator Sequence")
+ ((#x3008 . #x00D0) SQ "Recorded Block Sequence")
+ ((#x3008 . #x00E0) SQ "Treatment Summary Measured Dose Reference Sequence")
+ ((#x3008 . #x0100) SQ "Recorded Source Sequence")
+ ((#x3008 . #x0105) LO "Source Serial Number")
+ ((#x3008 . #x0110) SQ "Treatment Session Application Setup Sequence")
+ ((#x3008 . #x0116) CS "Application Setup Check")
+ ((#x3008 . #x0120) SQ "Recorded Brachy Accessory Device Sequence")
+ ((#x3008 . #x0122) IS "Referenced Brachy Accessory Device Number")
+ ((#x3008 . #x0130) SQ "Recorded Channel Sequence")
+ ((#x3008 . #x0132) DS "Specified Channel Total Time")
+ ((#x3008 . #x0134) DS "Delivered Channel Total Time")
+ ((#x3008 . #x0136) IS "Specified Number of Pulses")
+ ((#x3008 . #x0138) IS "Delivered Number of Pulses")
+ ((#x3008 . #x013A) DS "Specified Pulse Repetition Interval")
+ ((#x3008 . #x013C) DS "Delivered Pulse Repetition Interval")
+ ((#x3008 . #x0140) SQ "Recorded Source Applicator Sequence")
+ ((#x3008 . #x0142) IS "Referenced Source Applicator Number")
+ ((#x3008 . #x0150) SQ "Recorded Channel Shield Sequence")
+ ((#x3008 . #x0152) IS "Referenced Channel Shield Number")
+ ((#x3008 . #x0160) SQ "Brachy Control Point Delivered Sequence")
+ ((#x3008 . #x0162) DA "Safe Position Exit Date")
+ ((#x3008 . #x0164) TM "Safe Position Exit Time")
+ ((#x3008 . #x0166) DA "Safe Position Return Date")
+ ((#x3008 . #x0168) TM "Safe Position Return Time")
+ ((#x3008 . #x0200) CS "Current Treatment Status")
+ ((#x3008 . #x0202) ST "Treatment Status Comment")
+ ((#x3008 . #x0220) SQ "Fraction Group Summary Sequence")
+ ((#x3008 . #x0223) IS "Referenced Fraction Number")
+ ((#x3008 . #x0224) CS "Fraction Group Type")
+ ((#x3008 . #x0230) CS "Beam Stopper Position")
+ ((#x3008 . #x0240) SQ "Fraction Status Summary Sequence")
+ ((#x3008 . #x0250) DA "Treatment Date")
+ ((#x3008 . #x0251) TM "Treatment Time")
+
+ ;;---------------------------------------------
+ ;; Group 300A: "Radiation Treatment Plan"
+ ((#x300A . #x0000) UL "Group Length")
+ ((#x300A . #x0002) SH "RT Plan Label")
+ ((#x300A . #x0003) LO "RT Plan Name")
+ ((#x300A . #x0004) ST "RT Plan Description")
+ ((#x300A . #x0006) DA "RT Plan Date")
+ ((#x300A . #x0007) TM "RT Plan Time")
+ ((#x300A . #x0009) LO "Treatment Protocols")
+ ((#x300A . #x000A) CS "Treatment Intent")
+ ((#x300A . #x000B) LO "Treatment Sites")
+ ((#x300A . #x000C) CS "RT Plan Geometry")
+ ((#x300A . #x000E) ST "Prescription Description")
+ ((#x300A . #x0010) SQ "Dose Reference Sequence")
+ ((#x300A . #x0012) IS "Dose Reference Number")
+ ((#x300A . #x0013) UI "Dose Reference UID")
+ ((#x300A . #x0014) CS "Dose Reference Structure Type")
+ ((#x300A . #x0015) CS "Nominal Beam Energy Unit")
+ ((#x300A . #x0016) LO "Dose Reference Description")
+ ((#x300A . #x0018) DS "Dose Reference Point Coordinates")
+ ((#x300A . #x001A) DS "Nominal Prior Dose")
+ ((#x300A . #x0020) CS "Dose Reference Type")
+ ((#x300A . #x0021) DS "Constraint Weight")
+ ((#x300A . #x0022) DS "Delivery Warning Dose")
+ ((#x300A . #x0023) DS "Delivery Maximum Dose")
+ ((#x300A . #x0025) DS "Target Minimum Dose")
+ ((#x300A . #x0026) DS "Target Prescription Dose")
+ ((#x300A . #x0027) DS "Target Maximum Dose")
+ ((#x300A . #x0028) DS "Target Underdose Volume Fraction")
+ ((#x300A . #x002A) DS "Organ at Risk Full-volume Dose")
+ ((#x300A . #x002B) DS "Organ at Risk Limit Dose")
+ ((#x300A . #x002C) DS "Organ at Risk Maximum Dose")
+ ((#x300A . #x002D) DS "Organ at Risk Overdose Volume Fraction")
+ ((#x300A . #x0040) SQ "Tolerance Table Sequence")
+ ((#x300A . #x0042) IS "Tolerance Table Number")
+ ((#x300A . #x0043) SH "Tolerance Table Label")
+ ((#x300A . #x0044) DS "Gantry Angle Tolerance")
+ ((#x300A . #x0046) DS "Beam Limiting Device Angle Tolerance")
+ ((#x300A . #x0048) SQ "Beam Limiting Device Tolerance Sequence")
+ ((#x300A . #x004A) DS "Beam Limiting Device Position Tolerance")
+ ((#x300A . #x004C) DS "Patient Support Angle Tolerance")
+ ((#x300A . #x004E) DS "Table Top Eccentric Angle Tolerance")
+ ((#x300A . #x0051) DS "Table Top Vertical Position Tolerance")
+ ((#x300A . #x0052) DS "Table Top Longitudinal Position Tolerance")
+ ((#x300A . #x0053) DS "Table Top Lateral Position Tolerance")
+ ((#x300A . #x0055) CS "RT Plan Relationship")
+ ((#x300A . #x0070) SQ "Fraction Group Sequence")
+ ((#x300A . #x0071) IS "Fraction Group Number")
+ ((#x300A . #x0072) LO "Fraction Group Description")
+ ((#x300A . #x0078) IS "Number of Fractions Planned")
+ ((#x300A . #x0079) IS "Number of Fraction Pattern Digits Per Day")
+ ((#x300A . #x007A) IS "Repeat Fraction Cycle Length")
+ ((#x300A . #x007B) LT "Fraction Pattern")
+ ((#x300A . #x0080) IS "Number of Beams")
+ ((#x300A . #x0082) DS "Beam Dose Specification Point")
+ ((#x300A . #x0084) DS "Beam Dose")
+ ((#x300A . #x0086) DS "Beam Meterset")
+ ((#x300A . #x00A0) IS "Number of Brachy Application Setups")
+ ((#x300A . #x00A2) DS "Brachy Application Setup Dose Specification Point")
+ ((#x300A . #x00A4) DS "Brachy Application Setup Dose")
+ ((#x300A . #x00B0) SQ "Beam Sequence")
+ ((#x300A . #x00B2) SH "Treatment Machine Name")
+ ((#x300A . #x00B3) CS "Primary Dosimeter Unit")
+ ((#x300A . #x00B4) DS "Source-Axis Distance")
+ ((#x300A . #x00B6) SQ "Beam Limiting Device Sequence")
+ ((#x300A . #x00B8) CS "RT Beam Limiting Device Type")
+ ((#x300A . #x00BA) DS "Source to Beam Limiting Device Distance")
+ ((#x300A . #x00BC) IS "Number of Leaf/Jaw Pairs")
+ ((#x300A . #x00BE) DS "Leaf Position Boundaries")
+ ((#x300A . #x00C0) IS "Beam Number")
+ ((#x300A . #x00C2) LO "Beam Name")
+ ((#x300A . #x00C3) ST "Beam Description")
+ ((#x300A . #x00C4) CS "Beam Type")
+ ((#x300A . #x00C6) CS "Radiation Type")
+ ((#x300A . #x00C7) CS "High-Dose Technique Type")
+ ((#x300A . #x00C8) IS "Reference Image Number")
+ ((#x300A . #x00CA) SQ "Planned Verification Image Sequence")
+ ((#x300A . #x00CC) LO "Imaging Device-Specific Acquisition Parameters")
+ ((#x300A . #x00CE) CS "Treatment Delivery Type")
+ ((#x300A . #x00D0) IS "Number of Wedges")
+ ((#x300A . #x00D1) SQ "Wedge Sequence")
+ ((#x300A . #x00D2) IS "Wedge Number")
+ ((#x300A . #x00D3) CS "Wedge Type")
+ ((#x300A . #x00D4) SH "Wedge ID")
+ ((#x300A . #x00D5) IS "Wedge Angle")
+ ((#x300A . #x00D6) DS "Wedge Factor")
+ ((#x300A . #x00D8) DS "Wedge Orientation")
+ ((#x300A . #x00DA) DS "Source to Wedge Tray Distance")
+ ((#x300A . #x00E0) IS "Number of Compensators")
+ ((#x300A . #x00E1) SH "Material ID")
+ ((#x300A . #x00E2) DS "Total Compensator Tray Factor")
+ ((#x300A . #x00E3) SQ "Compensator Sequence")
+ ((#x300A . #x00E4) IS "Compensator Number")
+ ((#x300A . #x00E5) SH "Compensator ID")
+ ((#x300A . #x00E6) DS "Source to Compensator Tray Distance")
+ ((#x300A . #x00E7) IS "Compensator Rows")
+ ((#x300A . #x00E8) IS "Compensator Columns")
+ ((#x300A . #x00E9) DS "Compensator Pixel Spacing")
+ ((#x300A . #x00EA) DS "Compensator Position")
+ ((#x300A . #x00EB) DS "Compensator Transmission Data")
+ ((#x300A . #x00EC) DS "Compensator Thickness Data")
+ ((#x300A . #x00ED) IS "Number of Boli")
+ ((#x300A . #x00EE) CS "Compensator Type")
+ ((#x300A . #x00F0) IS "Number of Blocks")
+ ((#x300A . #x00F2) DS "Total Block Tray Factor")
+ ((#x300A . #x00F4) SQ "Block Sequence")
+ ((#x300A . #x00F5) SH "Block Tray ID")
+ ((#x300A . #x00F6) DS "Source to Block Tray Distance")
+ ((#x300A . #x00F8) CS "Block Type")
+ ((#x300A . #x00F9) LO "Accessory Code")
+ ((#x300A . #x00FA) CS "Block Divergence")
+ ((#x300A . #x00FB) CS "Block Mounting Position")
+ ((#x300A . #x00FC) IS "Block Number")
+ ((#x300A . #x00FE) LO "Block Name")
+ ((#x300A . #x0100) DS "Block Thickness")
+ ((#x300A . #x0102) DS "Block Transmission")
+ ((#x300A . #x0104) IS "Block Number of Points")
+ ((#x300A . #x0106) DS "Block Data")
+ ((#x300A . #x0107) SQ "Applicator Sequence")
+ ((#x300A . #x0108) SH "Applicator ID")
+ ((#x300A . #x0109) CS "Applicator Type")
+ ((#x300A . #x010A) LO "Applicator Description")
+ ((#x300A . #x010C) DS "Cumulative Dose Reference Coefficient")
+ ((#x300A . #x010E) DS "Final Cumulative Meterset Weight")
+ ((#x300A . #x0110) IS "Number of Control Points")
+ ((#x300A . #x0111) SQ "Control Point Sequence")
+ ((#x300A . #x0112) IS "Control Point Index")
+ ((#x300A . #x0114) DS "Nominal Beam Energy")
+ ((#x300A . #x0115) DS "Dose Rate Set")
+ ((#x300A . #x0116) SQ "Wedge Position Sequence")
+ ((#x300A . #x0118) CS "Wedge Position")
+ ((#x300A . #x011A) SQ "Beam Limiting Device Position Sequence")
+ ((#x300A . #x011C) DS "Leaf/Jaw Positions")
+ ((#x300A . #x011E) DS "Gantry Angle")
+ ((#x300A . #x011F) CS "Gantry Rotation Direction")
+ ((#x300A . #x0120) DS "Beam Limiting Device Angle")
+ ((#x300A . #x0121) CS "Beam Limiting Device Rotation Direction")
+ ((#x300A . #x0122) DS "Patient Support Angle")
+ ((#x300A . #x0123) CS "Patient Support Rotation Direction")
+ ((#x300A . #x0124) DS "Table Top Eccentric Axis Distance")
+ ((#x300A . #x0125) DS "Table Top Eccentric Angle")
+ ((#x300A . #x0126) CS "Table Top Eccentric Rotation Direction")
+ ((#x300A . #x0128) DS "Table Top Vertical Position")
+ ((#x300A . #x0129) DS "Table Top Longitudinal Position")
+ ((#x300A . #x012A) DS "Table Top Lateral Position")
+ ((#x300A . #x012C) DS "Isocenter Position")
+ ((#x300A . #x012E) DS "Surface Entry Point")
+ ((#x300A . #x0130) DS "Source to Surface Distance")
+ ((#x300A . #x0134) DS "Cumulative Meterset Weight")
+ ((#x300A . #x0180) SQ "Patient Setup Sequence")
+ ((#x300A . #x0182) IS "Patient Setup Number")
+ ((#x300A . #x0184) LO "Patient Additional Position")
+ ((#x300A . #x0190) SQ "Fixation Device Sequence")
+ ((#x300A . #x0192) CS "Fixation Device Type")
+ ((#x300A . #x0194) SH "Fixation Device Label")
+ ((#x300A . #x0196) ST "Fixation Device Description")
+ ((#x300A . #x0198) SH "Fixation Device Position")
+ ((#x300A . #x01A0) SQ "Shielding Device Sequence")
+ ((#x300A . #x01A2) CS "Shielding Device Type")
+ ((#x300A . #x01A4) SH "Shielding Device Label")
+ ((#x300A . #x01A6) ST "Shielding Device Description")
+ ((#x300A . #x01A8) SH "Shielding Device Position")
+ ((#x300A . #x01B0) CS "Setup Technique")
+ ((#x300A . #x01B2) ST "Setup Technique Description")
+ ((#x300A . #x01B4) SQ "Setup Device Sequence")
+ ((#x300A . #x01B6) CS "Setup Device Type")
+ ((#x300A . #x01B8) SH "Setup Device Label")
+ ((#x300A . #x01BA) ST "Setup Device Description")
+ ((#x300A . #x01BC) DS "Setup Device Parameter")
+ ((#x300A . #x01D0) ST "Setup Reference Description")
+ ((#x300A . #x01D2) DS "Table Top Vertical Setup Displacement")
+ ((#x300A . #x01D4) DS "Table Top Longitudinal Setup Displacement")
+ ((#x300A . #x01D6) DS "Table Top Lateral Setup Displacement")
+ ((#x300A . #x0200) CS "Brachy Treatment Technique")
+ ((#x300A . #x0202) CS "Brachy Treatment Type")
+ ((#x300A . #x0206) SQ "Treatment Machine Sequence")
+ ((#x300A . #x0210) SQ "Source Sequence")
+ ((#x300A . #x0212) IS "Source Number")
+ ((#x300A . #x0214) CS "Source Type")
+ ((#x300A . #x0216) LO "Source Manufacturer")
+ ((#x300A . #x0218) DS "Active Source Diameter")
+ ((#x300A . #x021A) DS "Active Source Length")
+ ((#x300A . #x0222) DS "Source Encapsulation Nominal Thickness")
+ ((#x300A . #x0224) DS "Source Encapsulation Nominal Transmission")
+ ((#x300A . #x0226) LO "Source Isotope Name")
+ ((#x300A . #x0228) DS "Source Isotope Half Life")
+ ((#x300A . #x022A) DS "Reference Air Kerma Rate")
+ ((#x300A . #x022C) DA "Air Kerma Rate Reference Date")
+ ((#x300A . #x022E) TM "Air Kerma Rate Reference Time")
+ ((#x300A . #x0230) SQ "Application Setup Sequence")
+ ((#x300A . #x0232) CS "Application Setup Type")
+ ((#x300A . #x0234) IS "Application Setup Number")
+ ((#x300A . #x0236) LO "Application Setup Name")
+ ((#x300A . #x0238) LO "Application Setup Manufacturer")
+ ((#x300A . #x0240) IS "Template Number")
+ ((#x300A . #x0242) SH "Template Type")
+ ((#x300A . #x0244) LO "Template Name")
+ ((#x300A . #x0250) DS "Total Reference Air Kerma")
+ ((#x300A . #x0260) SQ "Brachy Accessory Device Sequence")
+ ((#x300A . #x0262) IS "Brachy Accessory Device Number")
+ ((#x300A . #x0263) SH "Brachy Accessory Device ID")
+ ((#x300A . #x0264) CS "Brachy Accessory Device Type")
+ ((#x300A . #x0266) LO "Brachy Accessory Device Name")
+ ((#x300A . #x026A) DS "Brachy Accessory Device Nominal Thickness")
+ ((#x300A . #x026C) DS "Brachy Accessory Device Nominal Transmission")
+ ((#x300A . #x0280) SQ "Channel Sequence")
+ ((#x300A . #x0282) IS "Channel Number")
+ ((#x300A . #x0284) DS "Channel Length")
+ ((#x300A . #x0286) DS "Channel Total Time")
+ ((#x300A . #x0288) CS "Source Movement Type")
+ ((#x300A . #x028A) IS "Number of Pulses")
+ ((#x300A . #x028C) DS "Pulse Repetition Interval")
+ ((#x300A . #x0290) IS "Source Applicator Number")
+ ((#x300A . #x0291) SH "Source Applicator ID")
+ ((#x300A . #x0292) CS "Source Applicator Type")
+ ((#x300A . #x0294) LO "Source Applicator Name")
+ ((#x300A . #x0296) DS "Source Applicator Length")
+ ((#x300A . #x0298) LO "Source Applicator Manufacturer")
+ ((#x300A . #x029C) DS "Source Applicator Wall Nominal Thickness")
+ ((#x300A . #x029E) DS "Source Applicator Wall Nominal Transmission")
+ ((#x300A . #x02A0) DS "Source Applicator Step Size")
+ ((#x300A . #x02A2) IS "Transfer Tube Number")
+ ((#x300A . #x02A4) DS "Transfer Tube Length")
+ ((#x300A . #x02B0) SQ "Channel Shield Sequence")
+ ((#x300A . #x02B2) IS "Channel Shield Number")
+ ((#x300A . #x02B3) SH "Channel Shield ID")
+ ((#x300A . #x02B4) LO "Channel Shield Name")
+ ((#x300A . #x02B8) DS "Channel Shield Nominal Thickness")
+ ((#x300A . #x02BA) DS "Channel Shield Nominal Transmission")
+ ((#x300A . #x02C8) DS "Final Cumulative Time Weight")
+ ((#x300A . #x02D0) SQ "Brachy Control Point Sequence")
+ ((#x300A . #x02D2) DS "Control Point Relative Position")
+ ((#x300A . #x02D4) DS "Control Point 3D Position")
+ ((#x300A . #x02D6) DS "Cumulative Time Weight")
+ ((#x300A . #x02E0) CS "Compensator Divergence")
+ ((#x300A . #x02E1) CS "Compensator Mounting Position")
+ ((#x300A . #x02E2) DS "Source to Compensator Distance")
+
+ ;;---------------------------------------------
+ ;; Group 300C: "Referenced Radiation Treatment Plan"
+ ((#x300C . #x0000) UL "Group Length")
+ ((#x300C . #x0002) SQ "Referenced RT Plan Sequence")
+ ((#x300C . #x0004) SQ "Referenced Beam Sequence")
+ ((#x300C . #x0006) IS "Referenced Beam Number")
+ ((#x300C . #x0007) IS "Referenced Reference Image Number")
+ ((#x300C . #x0008) DS "Start Cumulative Meterset Weight")
+ ((#x300C . #x0009) DS "End Cumulative Meterset Weight")
+ ((#x300C . #x000A) SQ "Referenced Brachy Application Setup Sequence")
+ ((#x300C . #x000C) IS "Referenced Brachy Application Setup Number")
+ ((#x300C . #x000E) IS "Referenced Source Number")
+ ((#x300C . #x0020) SQ "Referenced Fraction Group Sequence")
+ ((#x300C . #x0022) IS "Referenced Fraction Group Number")
+ ((#x300C . #x0040) SQ "Referenced Verification Image Sequence")
+ ((#x300C . #x0042) SQ "Referenced Reference Image Sequence")
+ ((#x300C . #x0050) SQ "Referenced Dose Reference Sequence")
+ ((#x300C . #x0051) IS "Referenced Dose Reference Number")
+ ((#x300C . #x0055) SQ "Brachy Referenced Dose Reference Sequence")
+ ((#x300C . #x0060) SQ "Referenced Structure Set Sequence")
+ ((#x300C . #x006A) IS "Referenced Patient Setup Number")
+ ((#x300C . #x0080) SQ "Referenced Dose Sequence")
+ ((#x300C . #x00A0) IS "Referenced Tolerance Table Number")
+ ((#x300C . #x00B0) SQ "Referenced Bolus Sequence")
+ ((#x300C . #x00C0) IS "Referenced Wedge Number")
+ ((#x300C . #x00D0) IS "Referenced Compensator Number")
+ ((#x300C . #x00E0) IS "Referenced Block Number")
+ ((#x300C . #x00F0) IS "Referenced Control Point Index")
+
+ ;;---------------------------------------------
+ ;; Group 300E: "Review"
+ ((#x300E . #x0000) UL "Group Length")
+ ((#x300E . #x0002) CS "Approval Status")
+ ((#x300E . #x0004) DA "Review Date")
+ ((#x300E . #x0005) TM "Review Time")
+ ((#x300E . #x0008) PN "Reviewer Name")
+
+ ;;---------------------------------------------
+ ;; Group 4000: "Comments"
+ ((#x4000 . #x0000) UL "Group Length")
+ ((#x4000 . #x0010) RET "Arbitrary (RET)")
+ ((#x4000 . #x4000) RET "Comments (RET)")
+
+ ;;---------------------------------------------
+ ;; Group 4008: "Results"
+ ((#x4008 . #x0000) UL "Group Length")
+ ((#x4008 . #x0040) SH "Results ID")
+ ((#x4008 . #x0042) LO "Results ID Issuer")
+ ((#x4008 . #x0050) SQ "Referenced Interpretation Sequence")
+ ((#x4008 . #x0100) DA "Interpretation Recorded Date")
+ ((#x4008 . #x0101) TM "Interpretation Recorded Time")
+ ((#x4008 . #x0102) PN "Interpretation Recorder")
+ ((#x4008 . #x0103) LO "Reference to Recorded Sound")
+ ((#x4008 . #x0108) DA "Interpretation Transcription Date")
+ ((#x4008 . #x0109) TM "Interpretation Transcription Time")
+ ((#x4008 . #x010A) PN "Interpretation Transcriber")
+ ((#x4008 . #x010B) ST "Interpretation Text")
+ ((#x4008 . #x010C) PN "Interpretation Author")
+ ((#x4008 . #x0111) SQ "Interpretation Approver Sequence")
+ ((#x4008 . #x0112) DA "Interpretation Approval Date")
+ ((#x4008 . #x0113) TM "Interpretation Approval Time")
+ ((#x4008 . #x0114) PN "Physician Approving Interpretation")
+ ((#x4008 . #x0115) LT "Interpretation Diagnosis Description")
+ ((#x4008 . #x0117) SQ "Interpretation Diagnosis Code Sequence")
+ ((#x4008 . #x0118) SQ "Results Distribution List Sequence")
+ ((#x4008 . #x0119) PN "Distribution Name")
+ ((#x4008 . #x011A) LO "Distribution Address")
+ ((#x4008 . #x0200) SH "Interpretation ID")
+ ((#x4008 . #x0202) LO "Interpretation ID Issuer")
+ ((#x4008 . #x0210) CS "Interpretation Type ID")
+ ((#x4008 . #x0212) CS "Interpretation Status ID")
+ ((#x4008 . #x0300) ST "Impressions")
+ ((#x4008 . #x4000) ST "Results Comments")
+
+ ;;---------------------------------------------
+ ;; Group 4FFE: "MAC Parameters"
+ ((#x4FFE . #x0000) UL "Group Length")
+ ((#x4FFE . #x0001) SQ "MAC Parameters Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 5000: "Curve"
+ ((#x5000 . #x0000) UL "Group Length")
+ ((#x5000 . #x0005) US "Curve Dimensions")
+ ((#x5000 . #x0010) US "Number of points")
+ ((#x5000 . #x0020) CS "Type of Data")
+ ((#x5000 . #x0022) LO "Curve Description")
+ ((#x5000 . #x0030) SH "Axis Units")
+ ((#x5000 . #x0040) SH "Axis Labels")
+ ((#x5000 . #x0103) US "Data Value Representation")
+ ((#x5000 . #x0104) US "Minimum Coordinate Value")
+ ((#x5000 . #x0105) US "Maximum Coordinate Value")
+ ((#x5000 . #x0106) SH "Curve Range")
+ ((#x5000 . #x0110) US "Data Descriptor")
+ ((#x5000 . #x0112) US "Coordinate Start Value")
+ ((#x5000 . #x0114) US "Coordinate Step Value")
+ ((#x5000 . #x2000) US "Audio Type")
+ ((#x5000 . #x2002) US "Audio Sample Format")
+ ((#x5000 . #x2004) US "Number of Channels")
+ ((#x5000 . #x2006) UL "Number of Samples")
+ ((#x5000 . #x2008) UL "Sample Rate")
+ ((#x5000 . #x200A) UL "Total Time")
+ ((#x5000 . #x200C) OW "Audio Sample Data")
+ ((#x5000 . #x200E) LT "Audio Comments")
+ ((#x5000 . #x2500) LO "Curve Label")
+ ((#x5000 . #x2600) SQ "Referenced Overlay Sequence")
+ ((#x5000 . #x2610) US "Referenced Overlay Group")
+ ((#x5000 . #x3000) OW "Curve Data")
+
+ ;;---------------------------------------------
+ ;; Group 5200: "Functional Groups"
+ ((#x5200 . #x0000) UL "Group Length")
+ ((#x5200 . #x9229) SQ "Shared Functional Groups Sequence")
+ ((#x5200 . #x9230) SQ "Per-frame Functional Groups Sequence")
+
+ ;;---------------------------------------------
+ ;; Group 5400: "Waveform Sequence"
+ ((#x5400 . #x0000) UL "Group Length")
+ ((#x5400 . #x0100) SQ "Waveform Sequence")
+ ((#x5400 . #x0110) OB "Channel Minimum Value")
+ ((#x5400 . #x0112) OB "Channel Maximum Value")
+ ((#x5400 . #x1004) US "Waveform Bits Allocated")
+ ((#x5400 . #x1006) CS "Waveform Sample Interpretation")
+ ((#x5400 . #x100A) OB "Waveform Padding Value")
+ ((#x5400 . #x1010) OB "Waveform Data")
+
+ ;;---------------------------------------------
+ ;; Group 5600: "Spectroscopy"
+ ((#x5600 . #x0000) UL "Group Length")
+ ((#x5600 . #x0010) OF "First Order Phase Correction Angle")
+ ((#x5600 . #x0020) OF "Spectroscopy Data")
+
+ ;;---------------------------------------------
+ ;; Group 6000: "Overlay"
+ ((#x6000 . #x0000) UL "Group Length")
+ ((#x6000 . #x0010) US "Rows")
+ ((#x6000 . #x0011) US "Columns")
+ ((#x6000 . #x0012) US "Planes")
+ ((#x6000 . #x0015) IS "Number of frames in Overlay")
+ ((#x6000 . #x0022) LO "Overlay Description")
+ ((#x6000 . #x0040) CS "Type")
+ ((#x6000 . #x0045) LO "Subtype")
+ ((#x6000 . #x0050) SS "Origin")
+ ((#x6000 . #x0051) US "Image Frame Origin")
+ ((#x6000 . #x0052) US "Overlay Plane Origin")
+ ((#x6000 . #x0060) RET "Compression Code (RET)")
+ ((#x6000 . #x0100) US "Overlay Bits Allocated")
+ ((#x6000 . #x0102) US "Overlay Bit Position")
+ ((#x6000 . #x0110) RET "Overlay Format (RET)")
+ ((#x6000 . #x0200) RET "Overlay Location (RET)")
+ ((#x6000 . #x1100) US "Overlay Descriptor -- Gray")
+ ((#x6000 . #x1101) US "Overlay Descriptor -- Red")
+ ((#x6000 . #x1102) US "Overlay Descriptor -- Green")
+ ((#x6000 . #x1103) US "Overlay Descriptor -- Blue")
+ ((#x6000 . #x1200) US "Overlays -- Gray")
+ ((#x6000 . #x1201) US "Overlays -- Red")
+ ((#x6000 . #x1202) US "Overlays -- Green")
+ ((#x6000 . #x1203) US "Overlays -- Blue")
+ ((#x6000 . #x1301) IS "ROI Area")
+ ((#x6000 . #x1302) DS "ROI Mean")
+ ((#x6000 . #x1303) DS "ROI Standard Deviation")
+ ((#x6000 . #x1500) LO "Overlay Label")
+ ((#x6000 . #x3000) OW "Data")
+ ((#x6000 . #x4000) RET "Comments (RET)")
+
+ ;;---------------------------------------------
+ ;; Group 7FE0: "Pixel"
+ ((#x7FE0 . #x0000) UL "Group Length")
+ ((#x7FE0 . #x0000) UL "Group Length")
+ ((#x7FE0 . #x0010) OB "Pixel Data")
+
+ ;;---------------------------------------------
+ ;; Group FFFA: "Digital Signature"
+ ((#xFFFA . #x0000) UL "Group Length")
+ ((#xFFFA . #xFFFA) SQ "Digital Signatures Sequence")
+
+ ;;---------------------------------------------
+ ;; Group FFFC: "Padding"
+ ((#xFFFC . #x0000) UL "Group Length")
+ ((#xFFFC . #xFFFC) OB "Data Set Trailing Padding")
+
+ ;;---------------------------------------------
+ ;; Group FFFE: "Delimiters"
+ ((#xFFFE . #xE000) IT "Item in Sequence")
+ ((#xFFFE . #xE00D) ITDL "Item Delimiter")
+ ((#xFFFE . #xE0DD) SQDL "Sequence Delimiter")
+ ))
+
+;;; Incomplete specifications:
+;(0008,1200) Studies Containing Other Referenced Instances Sequence
+;(0018,9073) Acquisition
+;(0018,A002) Contribution
+;(0028,1051) Window
+;(0040,0312) X-Ray
+;(0040,A010) Relationship
+;(0054,0080) Slice
+;(0054,1201) Axial
+;(2010,0130) Max
+;(2200,0004) Media
+;(300A,00B0) Beam
+;(300A,00E3) Compensator
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/functions.cl b/dicom/src/functions.cl
new file mode 100644
index 0000000..b11a5d7
--- /dev/null
+++ b/dicom/src/functions.cl
@@ -0,0 +1,163 @@
+;;;
+;;; functions
+;;;
+;;; Message parser/generator and environment lookup utilities.
+;;; Contains functions common to Client and Server.
+;;;
+;;; 26-Dec-2000 BobGian wrap IGNORE-ERRORS around error-prone fcns.
+;;; Include error-recovery options in case those fcns barf.
+;;; Change a few local variable names for consistency.
+;;; 30-Jul-2001 BobGian improve formatting of data sent to log file.
+;;; 04-May-2002 BobGian add TCP buffer overrun check to PARSE-MESSAGE.
+;;; 26-Jun-2002 BobGian PARSE-MESSAGE reports error and does hex dump of
+;;; TCP buffer data in case of failed parse.
+;;; Jul/Aug 2002 BobGian better messages in error-reporting functions.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; Parser for DICOM Messages.
+
+(defun parse-message (env tcp-buffer head tail &aux val-1 val-2)
+
+ "Returns on Success: Message-Type + Environment. Failure: :Fail + NIL."
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum head tail))
+
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%PARSE-MESSAGE [1] Parsing message (~D bytes).~%"
+ (the fixnum (- tail head))))
+
+ (unless (< tail #.TCP-Bufsize)
+ (mishap env tcp-buffer "PARSE-MESSAGE [2] Buffer overrun - TAIL: ~D."
+ tail))
+
+ (dolist (msgtype *Message-Type-List* (setq val-1 :Fail))
+
+ (multiple-value-bind (input-cont new-env)
+ (parse-group (get msgtype :Parser-Rule) env tcp-buffer head tail)
+
+ (declare (type fixnum input-cont)
+ (ignore input-cont))
+
+ ;; PARSE-GROUP returns :Fail [as second value] if parse fails,
+ ;; indicating that this rule does not match the message. Try others.
+ (unless (eq new-env :Fail)
+ (setq val-1 msgtype val-2 new-env)
+ (return))))
+
+ ;; Return values -- First: Symbol naming message or :Fail.
+ ;; Second: Environment structure or NIL.
+ (when (>= (the fixnum *log-level*) 3)
+ (format t "~%PARSE-MESSAGE [3] Returning (val 1): ~S~%" val-1))
+
+ (when (eq val-1 :FAIL)
+ (report-error env nil "PARSE-MESSAGE [4] Failed parse.")
+ (dump-bytestream "Message in TCP buffer" tcp-buffer head tail))
+
+ (values val-1 val-2))
+
+;;;=============================================================
+;;; Performs pattern-matching [sequential recursion, not tree recursion] to
+;;; extract values from ENV but adds nothing to environment, so side-effects
+;;; cannot be passed via environment from one arg to another.
+;;;
+;;; Grammar allows any self-evaluating Lisp atomic object, although only
+;;; FIXNUMs are used in rules so far. Note that symbols here evaluate to
+;;; themselves, not to their value slot. Uses ordinary non-tail recursion
+;;; because recursion depth [length of argument list] is small -- usually
+;;; zero, max of 2 or 3. Uses tree recursion to instantiate args to
+;;; functions embedded inside inside other args.
+
+(defun eval-args (argument-list env &aux object)
+
+ (declare (type list argument-list env))
+
+ (cond
+ ((null argument-list) nil)
+
+ ((atom argument-list)
+ (mishap env nil "EVAL-ARGS [1] Bad argument-list: ~S" argument-list))
+
+ ;; By now, ARGUMENT-LIST guaranteed to be CONSP.
+ ((atom (setq object (car argument-list)))
+ ;; ATOMIC elements of argument list evaluate to themselves.
+ (cons object (eval-args (cdr argument-list) env)))
+
+ ;; By now, OBJECT guaranteed to be CONSP.
+ ((eq (first object) '<lookup-var) ;DICOM Variable
+ ;; DICOM variables evaluate to their values as bound in environment.
+ ;; Presently, access chain is used by Generator but not by Parser.
+ ;; Access chain, if present, is passed to ITEM-LOOKUP.
+ (cons (apply #'item-lookup (second object) env t (cddr (cdddr object)))
+ (eval-args (cdr argument-list) env)))
+
+ ;; Lisp functions called with args as provided explicitly.
+ ((eq (first object) '<funcall)
+ (cons (apply (second object) (eval-args (cddr object) env))
+ (eval-args (cdr argument-list) env)))
+
+ (t (mishap env nil "EVAL-ARGS [2] Bad argument-list: ~S" argument-list))))
+
+;;;-------------------------------------------------------------
+
+(defun item-lookup (varname env punt-if-missing? &rest access-chain)
+
+ (declare (type symbol varname)
+ (type (member nil t) punt-if-missing?)
+ (type list env access-chain))
+
+ (let ((pair (cond ((null access-chain)
+ (assoc varname env :test #'eq))
+ (t (assoc varname (cdr (item-present? access-chain env))
+ :test #'eq)))))
+
+ (declare (type list pair))
+
+ (cond ((consp pair)
+ ;; Binding, whether required or not, was present. Return value.
+ (cdr pair))
+ (punt-if-missing?
+ ;; Spec and proper operation requres variable to be bound
+ ;; in this context. Punt if not.
+ (mishap env nil "ITEM-LOOKUP [1] Variable ~S missing in chain:~%~S"
+ varname access-chain))
+ ;; In this context, binding is optional. If missing, return NIL.
+ (t nil))))
+
+;;;-------------------------------------------------------------
+
+(defun set-lookup (env &rest access-chain &aux tmp)
+
+ (declare (type list env access-chain tmp))
+
+ (unless (consp access-chain)
+ (mishap env nil "SET-LOOKUP [1] Null access-chain."))
+
+ (setq tmp (cdr access-chain))
+
+ (do ((key (car access-chain))
+ (items (cond ((consp tmp)
+ (cdr (item-present? tmp env)))
+ (t env))
+ (cdr items))
+ (output-list '())
+ (item))
+ ((null items)
+ (nreverse output-list))
+
+ (declare (type symbol key)
+ (type list items output-list))
+
+ (cond
+ ((atom (setq item (car items)))
+ (mishap env nil "SET-LOOKUP [2] Bad item ~S in sub-environment." item))
+ ((eq key (car item))
+ (push (cdr item) output-list)))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/generator-rules.cl b/dicom/src/generator-rules.cl
new file mode 100644
index 0000000..ec378dd
--- /dev/null
+++ b/dicom/src/generator-rules.cl
@@ -0,0 +1,936 @@
+;;;
+;;; generator-rules
+;;;
+;;; Rules for DICOM PDU and Message Generation.
+;;; Contains declarations common to Client and Server.
+;;;
+;;; 27-Apr-2001 BobGian change A-Associate-AC rule to echo Called-AE-Title
+;;; used by caller rather than global value from configuration file.
+;;; 23-Apr-2002 BobGian UIDs in A-Assoc-RQ/AC :Null-Pad -> :No-Pad.
+;;; 25-Apr-2002 BobGian change rule for C-Store-RTPlan SOP to send command
+;;; and data PDVs in separate PDUs - needed for fragmentation fix.
+;;; 30-Apr-2002 BobGian replace Presentation Context ID with constant #x01.
+;;; 10-May-2002 BobGian replace call to procedural computation of PDU and
+;;; PDV length fields in rules by :Place-Holder tokens, since computation
+;;; is done in SEND-PDU and would be redundant in rule expansion.
+;;; 30-Jul-2002 BobGian :SOP-Class-Ext-Neg-Item-AC (optional item) removed
+;;; from :A-Associate-AC PDU (already not used in :A-Associate-RQ PDU).
+;;; Jul/Aug 2002 BobGian:
+;;; SOP-Class-Extended-Negotiation-Item removed from Assoc-RP PDU - not
+;;; echoed, even if present in Assoc-RQ.
+;;; Extended-Negotiation documented as "not supported" in conformance report.
+;;; Environment accessor name change: <MCH -> <PDV-MCH.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; Rules for Generating Transmitted PDUs.
+;;;
+;;; Variables commented "Global Env" in <ENCODE-VAR forms have values
+;;; transmitted via arguments to SEND-PDU, by extending environment with
+;;; top-level accessible pairs.
+;;;
+;;; Otherwise, variables get their values from the environment via an access
+;;; chain provided as explicit arguments in <ENCODE-VAR or <LOOKUP-VAR terms.
+
+(defparameter *Generator-Rule-List*
+ `(
+
+ ;;=============================================
+ ;; PDU Generation Rules.
+ ;;=============================================
+
+ ;; A-Associate-RQ PDU rule == COMPLETE PDU.
+
+ (:A-Associate-RQ ;SCU-only
+
+ #x01 ;A-Associate-RQ PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ ;; Protocol Version [2-byte bitstring, val = #x0001]
+ (=fixnum-bytes #x0001 2 :Big-Endian)
+
+ (=constant-bytes #x00 2) ;Reserved field [2 bytes]
+
+ ;; Called AE Title [16-byte string] -- Remote host being called.
+ (<encode-var Called-AE-Title string 16 :Space-Pad) ;Global Env
+
+ ;; Calling AE Title [16-byte string] -- Client name may depend on target.
+ (<encode-var Calling-AE-Title string 16 :Space-Pad) ;Global Env
+
+ (=constant-bytes #x00 32) ;Reserved field [32 bytes]
+
+ :Application-Context-Item
+
+ ;; Single Presentation Context Item -- global env carries proposals.
+ ;; If desired to present more than one, encode them here explicitly.
+ :Presentation-Context-Item-RQ
+
+ :User-Information-Item-RQ)
+
+ ;;---------------------------------------------
+ ;; Presentation Context Item rule for Assoc-RQ PDU.
+
+ (:Presentation-Context-Item-RQ ;SCU-only
+
+ #x20 ;Presentation Context Item type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Field Length [2 bytes -- PC-ID to end of last Transfer Syntax Item]
+ (<item-length 2 :Big-Endian)
+
+ #x01 ;Presentation Context ID [1 byte]
+
+ (=constant-bytes #x00 3) ;Reserved field [3 bytes]
+
+ :Abstract-Syntax-Item-RQ
+
+ ;; 1 or more Transfer Syntax Items allowed. DicomRT uses NEMA default.
+ :Transfer-Syntax-Item)
+
+ ;;---------------------------------------------
+ ;; Abstract Syntax Item rule for Assoc-RQ PDU.
+
+ (:Abstract-Syntax-Item-RQ ;SCU-only
+
+ #x30 ;Abstract Syntax Item type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Abstract Syntax Name [SOP Class UID String] field length [2 bytes]
+ (<encode-var SOP-Class-UID-Len fixnum 2 :Big-Endian) ;Global Env
+
+ ;; Abstract Syntax Name [SOP Class UID String] -- variable-length.
+ (<encode-var SOP-Class-UID-Str ;Global Env
+ string
+ (<lookup-var SOP-Class-UID-Len) ;Global Env
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; User Information Item rule for Assoc-RQ PDU.
+
+ (:User-Information-Item-RQ ;SCU-only
+
+ #x50 ;User Information Item Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ (<item-length 2 :Big-Endian) ;User Data Item Field Length [2 bytes]
+
+ :Max-DataField-Len-Item
+
+ :Implementation-Class-UID-Item
+
+ ;; Optional Asynchronous Operations Item.
+ :Asynchronous-Ops-Item
+
+ ;; Optional SCP/SCU Role Item.
+ :SCP/SCU-Role-Item-RQ
+
+ :Implementation-Version-Name-Item
+
+ ;; Optional SOP Class Extended Negotiation Item.
+ #+ignore
+ :SOP-Class-Ext-Neg-Item-RQ) ;Not currently used.
+
+ ;;---------------------------------------------
+ ;; SCP/SCU Role Item rule for Assoc-RQ PDU.
+
+ (:SCP/SCU-Role-Item-RQ ;SCU-only
+
+ #x54 ;SCP/SCU Role Item tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ (<item-length 2 :Big-Endian) ;SCP/SCU Role Item field length [2 bytes]
+
+ ;; SOP Class UID Item Field Length [2 bytes]
+ (<encode-var Role-SOP-Class-UID-Len fixnum 2 :Big-Endian) ;Global Env
+
+ ;; SOP Class UID String [variable-len byte string]
+ (<encode-var Role-SOP-Class-UID-Str ;Global Env
+ string
+ (<lookup-var Role-SOP-Class-UID-Len) ;Global Env
+ :No-Pad)
+
+ #x01 ;Requester's proposal to be SCU [requested]
+
+ #x00) ;Requester's proposal to be SCP [not-requested]
+
+ ;;---------------------------------------------
+ ;; Optional SOP Class Extended Negotiation Item rule for Assoc-RQ PDU.
+ ;; Values for variable instantiation must be pushed onto environment
+ ;; so as to be available to instantiator functions.
+
+ #+ignore ;SCU-only, but DicomRT doesn't implement this anyway.
+ (:SOP-Class-Ext-Neg-Item-RQ
+
+ #x56 ;SOP Class Extended Negotiation Item tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Extended Negotiation Item Field Length [2 bytes] (not used at present)
+ (<encode-var Ext-Negotiation-Len fixnum 2 :Big-Endian) ;Global Env
+
+ ;; SOP Class UID Item Field Length [2 bytes] (not used at present)
+ (<encode-var EN-SOP-Class-UID-Len fixnum 2 :Big-Endian) ;Global Env
+
+ ;; SOP Class UID String [variable-len byte string] (not used at present)
+ (<encode-var EN-SOP-Class-UID-Str ;Global Env
+ string
+ (<lookup-var EN-SOP-Class-UID-Len) ;Global Env
+ :No-Pad)
+
+ ;; Extended Negotiation data (not used at present)
+ (<encode-var Ext-Negotiation-Str ;Global Env
+ string
+ (<funcall -
+ (<lookup-var Ext-Negotiation-Len) ;Global Env
+ (<lookup-var EN-SOP-Class-UID-Len) ;Global Env
+ 2)
+ :No-Pad))
+
+ ;;=============================================
+ ;; A-Associate-AC PDU rule == COMPLETE PDU.
+
+ (:A-Associate-AC
+
+ #x02 ;A-Associate-AC PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ ;; Protocol Version [2-byte bitstring, val = #x0001]
+ (=fixnum-bytes #x0001 2 :Big-Endian)
+
+ (=constant-bytes #x00 2) ;Reserved field [2 bytes]
+
+ ;; Called AE Title [16-byte string] -- Local host accepting association.
+ (<encode-var Called-AE-Title string 16 :Space-Pad :A-Associate-RQ)
+
+ ;; Calling AE Title [16-byte string] -- Remote host requesting assoc.
+ (<encode-var Calling-AE-Title string 16 :Space-Pad :A-Associate-RQ)
+
+ (=constant-bytes #x00 32) ;Reserved field [32 bytes]
+
+ :Application-Context-Item
+
+ ;; 1 or more Presentation Context Items -- global environment
+ ;; carries proposals.
+ (:Set :Presentation-Context-Item-AC)
+
+ :User-Information-Item-AC)
+
+ ;;---------------------------------------------
+ ;; Presentation Context Item rule for Assoc-AC PDU.
+
+ (:Presentation-Context-Item-AC
+
+ #x21 ;Presentation Context Item type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Field Length [2 bytes -- PC-ID to end of last Transfer Syntax Item]
+ (<item-length 2 :Big-Endian)
+
+ (<encode-var PC-ID fixnum 1) ;Presentation Context ID [1 byte] Global
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Result/Reason slot:
+ ;; 0: Acceptance
+ ;; 1: User-Rejecttion
+ ;; 2: No-Reason-Given (Provider-Rejection)
+ ;; 3: Abstract-Syntax Not Supported (Provider-Rejection)
+ ;; 4: Transfer-Syntax Not Supported (Provider-Rejection)
+ (<encode-var Result/Reason fixnum 1) ;Global Env
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Transfer Syntax Item is significant only if Result/Reason
+ ;; is zero [Acceptance]; it is ignored if Result/Reason is non-zero
+ ;; [indicating Rejection]. If accepting, server selects only the
+ ;; NEMA default transfer syntax.
+ :Transfer-Syntax-Item)
+
+ ;;---------------------------------------------
+ ;; User Information Item rule for Assoc-AC PDU.
+
+ (:User-Information-Item-AC
+
+ #x50 ;User Information Item Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ (<item-length 2 :Big-Endian) ;User Data Item Field Length [2 bytes]
+
+ :Max-DataField-Len-Item
+
+ :Implementation-Class-UID-Item
+
+ ;; Optional Asynchronous Operations Item -- Echo if Assoc-RQ had it.
+ (<if Item-Present?
+ (:Asynchronous-Ops-Item :User-Information-Item-RQ :A-Associate-RQ)
+ :Asynchronous-Ops-Item)
+
+ ;; Optional SCP/SCU Role Item -- Echo if Assoc-RQ included this item.
+ ;; It is legal for Acceptor not to respond to Requestor's item, in
+ ;; which case Requestor defaults to SCU and Acceptor to SCP.
+ #+ignore ;Not currently used.
+ (<if Item-Present?
+ (:SCP/SCU-Role-Item :User-Information-Item-RQ :A-Associate-RQ)
+ :SCP/SCU-Role-Item-AC)
+
+ :Implementation-Version-Name-Item
+
+ ;; Optional SOP Class Extended Negotiation Item -- One per SOP-Class-UID
+ ;; item received in Assoc-RQ PDU. Currently implemented as a single
+ ;; optional item. Correct version would answer one for EACH one received
+ ;; in A-Associate-RQ. Note that Item-Present? answers Yes [non-NIL] if
+ ;; ANY of one or more are present.
+ #+ignore
+ (<if Item-Present?
+ (:SOP-Class-Ext-Neg-Item :User-Information-Item-RQ :A-Associate-RQ)
+ :SOP-Class-Ext-Neg-Item-AC)) ;Not currently used.
+
+ ;;---------------------------------------------
+ ;; SCP/SCU Role Item rule for Assoc-AC PDU.
+
+ (:SCP/SCU-Role-Item-AC
+
+ #x54 ;SCP/SCU Role Item tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ (<item-length 2 :Big-Endian) ;SCP/SCU Role Item field length [2 bytes]
+
+ ;; SOP Class UID Item Field Length [2 bytes]
+ (<encode-var Role-SOP-Class-UID-Len fixnum 2 :Big-Endian
+ :SCP/SCU-Role-Item
+ :User-Information-Item
+ :A-Associate-RQ)
+
+ ;; SOP Class UID String [variable-len byte string]
+ (<encode-var Role-SOP-Class-UID-Str
+ string
+ (<lookup-var Role-SOP-Class-UID-Len
+ :SCP/SCU-Role-Item
+ :User-Information-Item
+ :A-Associate-RQ)
+ :No-Pad
+ :SCP/SCU-Role-Item
+ :User-Information-Item
+ :A-Associate-RQ)
+
+ #x01 ;Requester's proposal to be SCU [accepted]
+
+ #x00) ;Requester's proposal to be SCP [rejected]
+
+ ;;---------------------------------------------
+ ;; Optional SOP Class Extended Negotiation Item rule for Assoc-AC PDU.
+ ;; Currently implemented as a single optional item. Correct version
+ ;; would answer one for EACH one received in RQ. How to differentiate
+ ;; between them?
+
+ #+ignore ;SCU-only, but DicomRT doesn't implement this anyway.
+ (:SOP-Class-Ext-Neg-Item-AC
+
+ #x56 ;SOP Class Extended Negotiation Item tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Extended Negotiation Item Field Length [2 bytes] (not used at present)
+ (<encode-var Ext-Negotiation-Len fixnum 2 :Big-Endian ;Local Env
+ :SOP-Class-Ext-Neg-Item ;Parsed but currently ignored.
+ :User-Information-Item
+ :A-Associate-RQ)
+
+ ;; SOP Class UID Item Field Length [2 bytes] (not used at present)
+ (<encode-var EN-SOP-Class-UID-Len fixnum 2 :Big-Endian ;Local Env
+ :SOP-Class-Ext-Neg-Item ;Parsed but currently ignored.
+ :User-Information-Item
+ :A-Associate-RQ)
+
+ ;; SOP Class UID String [variable-len byte string] (not used at present)
+ (<encode-var EN-SOP-Class-UID-Str ;Local Env
+ string
+ (<lookup-var EN-SOP-Class-UID-Len ;Local Env
+ :SOP-Class-Ext-Neg-Item ;Currently ignored.
+ :User-Information-Item
+ :A-Associate-RQ)
+ :No-Pad
+ :SOP-Class-Ext-Neg-Item ;Currently ignored.
+ :User-Information-Item
+ :A-Associate-RQ)
+
+ ;; Extended Negotiation data -- varies with SOP class (not used)
+ (<encode-var Ext-Negotiation-Str ;Local Env
+ string
+ (<funcall -
+ (<lookup-var Ext-Negotiation-Len ;Local Env
+ :SOP-Class-Ext-Neg-Item ;Ignored.
+ :User-Information-Item
+ :A-Associate-RQ)
+ (<lookup-var EN-SOP-Class-UID-Len ;Local Env
+ :SOP-Class-Ext-Neg-Item ;Ignored.
+ :User-Information-Item
+ :A-Associate-RQ)
+ 2)
+ :No-Pad
+ :SOP-Class-Ext-Neg-Item ;Parsed but currently ignored.
+ :User-Information-Item
+ :A-Associate-RQ))
+
+ ;;=============================================
+ ;; Application Context Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Application-Context-Item
+
+ #x10 ;Application Context Item type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Application Context Name Length [2 bytes]
+ (=fixnum-bytes (length *Application-Context-Name*) 2 :Big-Endian)
+
+ ;; Application Context Name [variable length]
+ (=string-bytes *Application-Context-Name*
+ (length *Application-Context-Name*)
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; Transfer Syntax Item rule for Assoc-RQ and Assoc-AC PDUs.
+ ;; We propose and accept proposals only of the NEMA default.
+
+ (:Transfer-Syntax-Item
+
+ #x40 ;Transfer Syntax Item type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Transfer Syntax Name field length [2 bytes]
+ (=fixnum-bytes (length *Transfer-Syntax-Name*) 2 :Big-Endian)
+
+ ;; Transfer Syntax Name [variable-length byte string]
+ ;; Proposing Implicit Little-Endian Transfer Syntax, NEMA.
+ ;; All systems must support this TSN, and it is only one we support.
+ (=string-bytes *Transfer-Syntax-Name*
+ (length *Transfer-Syntax-Name*)
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; Maximum DataField Length Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Max-DataField-Len-Item
+
+ #x51 ;Maximum Length Sub-Item field tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Maximum Length Received field length [val = 4, 2 bytes]
+ (=fixnum-bytes 4 2 :Big-Endian)
+
+ ;; Maximum PDU Length as 4 byte integer. Zero -> no limit.
+ ;; TCP buffer is statically allocated. Some scanners send weird PDU
+ ;; length when unlimited PDU datalength field option is used.
+ (=fixnum-bytes #.PDU-Bufsize 4 :Big-Endian))
+
+ ;;---------------------------------------------
+ ;; Implementation Class UID Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Implementation-Class-UID-Item
+
+ #x52 ;Implementation Class UID Item tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Implementation Class UID Item Field Length [2 bytes]
+ (=fixnum-bytes (length *Implementation-Class-UID*) 2 :Big-Endian)
+
+ ;; Implementation Class UID [variable-length byte string]
+ (=string-bytes *Implementation-Class-UID*
+ (length *Implementation-Class-UID*)
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; Asynchronous Operations Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Asynchronous-Ops-Item
+
+ #x53 ;Asynchronous Operations Item tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Asynchronous Operations Item field length [val = 4, 2 bytes]
+ (=fixnum-bytes 4 2 :Big-Endian)
+
+ ;; Synchronous operation only supported by our system.
+ ;; Max Num Ops Invoked Asynchronously [val = 1, 0 -> unlimited, 2 bytes]
+ (=fixnum-bytes 1 2 :Big-Endian)
+
+ ;; Synchronous operation only supported.
+ ;; Max Number of Operations Performed Asynchronously
+ ;; [val = 1, 0 -> unlimited, 2 bytes]
+ (=fixnum-bytes 1 2 :Big-Endian))
+
+ ;;---------------------------------------------
+ ;; Implementation Version Name Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Implementation-Version-Name-Item
+
+ #x55 ;Implementation Version Name Item tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; Implementation Version Name Item Field Length [2 bytes]
+ (=fixnum-bytes (length *Implementation-Version-Name*) 2 :Big-Endian)
+
+ ;; Implementation Version Name [variable-len byte string]
+ (=string-bytes *Implementation-Version-Name*
+ (length *Implementation-Version-Name*)
+ :No-Pad))
+
+ ;;=============================================
+ ;; A-Associate-RJ PDU rule == COMPLETE PDU.
+
+ (:A-Associate-RJ
+
+ #x03 ;A-Associate-RJ PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ #x00 ;Reserved field [1 byte]
+
+ ;; 1: Rejection-Permanent
+ ;; 2: Rejection-Transient
+ (<encode-var RJ-Result fixnum 1) ;Global Env
+
+ ;; 1: UL Service-User
+ ;; 2: UL Service-Provider [ACSE]
+ ;; 3: UL Service-Provider [Presentation Layer]
+ (<encode-var RJ-Source fixnum 1) ;Global Env
+
+ ;; If RJ-Source = 1:
+ ;; 1: No-Reason-Given
+ ;; 2: Application-Context-Name-Not-Supported
+ ;; 3: Calling-AE-Title-Not-Recognized
+ ;; 4-6: Reserved
+ ;; 7: Called-AE-Title-Not-Recognized
+ ;; 8-10: Reserved
+ ;;
+ ;; If RJ-Source = 2:
+ ;; 1: No-Reason-Given
+ ;; 2: Protocol-Version-Not-Supported
+ ;;
+ ;; If RJ-Source = 3:
+ ;; 0: Reserved
+ ;; 1: Temporary-Congestion
+ ;; 2: Local-Limit-Exceeded
+ ;; 3-7: Reserved
+ (<encode-var RJ-Diagnostic fixnum 1)) ;Global Env
+
+ ;;=============================================
+ ;; A-Release-RQ PDU rule == COMPLETE PDU.
+
+ (:A-Release-RQ
+
+ #x05 ;A-Release-RQ PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ (=constant-bytes #x00 4)) ;Reserved field [4 bytes]
+
+ ;;=============================================
+ ;; A-Release-RSP PDU rule == COMPLETE PDU.
+
+ (:A-Release-RSP
+
+ #x06 ;A-Release-RSP PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ (=constant-bytes #x00 4)) ;Reserved field [4 bytes]
+
+ ;;=============================================
+ ;; A-Abort PDU rule == COMPLETE PDU.
+
+ (:A-Abort
+
+ #x07 ;A-Abort PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ (=constant-bytes #x00 2) ;Reserved field [2 bytes]
+
+ ;; 0: UL Service-User-initiated
+ ;; 1: Reserved
+ ;; 2: UL Service-Provider-initiated
+ (<encode-var Abort-Source fixnum 1) ;Global Env
+
+ ;; If Abort-Source = 0:
+ ;; Not Significant [ignored when received]
+ ;;
+ ;; If Abort-Source = 2:
+ ;; 0: Reason Not Specified
+ ;; 1: Unrecognized PDU
+ ;; 2: Unexpected PDU
+ ;; 3: Reserved
+ ;; 4: Unrecognized PDU Parameter
+ ;; 5: Unexpected PDU Parameter
+ ;; 6: Invalid PDU Parameter Value
+ (<encode-var Abort-Diagnostic fixnum 1)) ;Global Env
+
+ ;;=============================================
+ ;; DICOM Message Generation Rules.
+ ;;=============================================
+
+ ;; C-Echo-RQ PDU Command/Message rule == COMPLETE PDU.
+
+ (:C-Echo-RQ
+
+ #x04 ;P-Data-TF PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ ;; PDV Length [4 bytes]
+ ;; Length is that of PC-ID byte + Control-Header byte + Message length.
+ :Place-Holder ;PDV-Message length + 2 bytes
+
+ #x01 ;Presentation Context ID [1 byte]
+
+ (<pdv-mch :Command) ;Message Control Header [1 byte]
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+ ;;
+ (<item-length 4 :Little-Endian) ;Value
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ ;; Echo-Verification SOP Class UID Item Field Length [2 bytes]
+ (=fixnum-bytes
+ (even-length *Echo-Verification-Service*) 4 :Little-Endian)
+
+ ;; Echo-Verification SOP Class UID [variable-length byte string]
+ (=string-bytes *Echo-Verification-Service*
+ (even-length *Echo-Verification-Service*)
+ :Null-Pad)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0030 2 :Little-Endian) ;Code for C-Echo-RQ
+
+ ;;--------- Element 4: Message ID [message being responded to]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0110)
+ (=fixnum-bytes #x0110 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes 1 2 :Little-Endian) ;Message ID
+
+ ;;--------- Element 5: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0101 2 :Little-Endian)) ;Code for No-Data
+
+ ;;=============================================
+ ;; C-Echo-RSP PDU Command/Message rule == COMPLETE PDU.
+
+ (:C-Echo-RSP
+
+ #x04 ;P-Data-TF PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ ;; PDV Length [4 bytes]
+ ;; Length is that of PC-ID byte + Control-Header byte + Message length.
+ :Place-Holder ;PDV-Message length + 2 bytes
+
+ (<encode-var PC-ID fixnum 1) ;Presentation Context ID [1 byte] Global
+
+ (<pdv-mch :Command) ;Message Control Header [1 byte]
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+ ;;
+ (<item-length 4 :Little-Endian) ;Value
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ (<encode-var Echo-SOP-Class-UID-Len fixnum 4 :Little-Endian ;Length
+ :C-Echo-RQ)
+
+ (<encode-var Echo-SOP-Class-UID-Str ;Value
+ string
+ (<lookup-var Echo-SOP-Class-UID-Len :C-Echo-RQ)
+ :Null-Pad
+ :C-Echo-RQ)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x8030 2 :Little-Endian) ;Code for C-Echo-RSP
+
+ ;;--------- Element 4: Message ID [message being responded to]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0120)
+ (=fixnum-bytes #x0120 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (<encode-var Echo-Msg-ID fixnum 2 :Little-Endian :C-Echo-RQ) ;Value
+
+ ;;--------- Element 5: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0101 2 :Little-Endian) ;Code for No-Data
+
+ ;;--------- Element 6: Response Status
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0900)
+ (=fixnum-bytes #x0900 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0000 2 :Little-Endian)) ;Code for Success
+
+ ;;=============================================
+ ;; C-Store-RQ PDU for RTPlan Command == COMPLETE PDU.
+
+ (:C-Store-RTPlan-Command
+
+ #x04 ;P-Data-TF PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ :Place-Holder ;PDV-Message length + 2 bytes
+
+ #x01 ;Presentation Context ID [1 byte]
+
+ (<pdv-mch :Command) ;Message Control Header [1 byte]
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+
+ (<item-length 4 :Little-Endian) ;Value
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ ;; RTPlan SOP Class UID Item Field Length [2 bytes]
+ (=fixnum-bytes (even-length *RTPlan-Storage-Service*) 4 :Little-Endian)
+
+ ;; RTPlan SOP Class UID [variable-length byte string]
+ (=string-bytes *RTPlan-Storage-Service*
+ (even-length *RTPlan-Storage-Service*)
+ :Null-Pad)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0001 2 :Little-Endian) ;Code for C-Store-RQ
+
+ ;;--------- Element 4: Message ID [message being sent]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0110)
+ (=fixnum-bytes #x0110 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes 1 2 :Little-Endian) ;Value
+
+ ;;--------- Element 5: Priority
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0700)
+ (=fixnum-bytes #x0700 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ ;; #x0002 -> LOW, #x0000 -> MEDIUM, #x0001 -> HIGH
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Value
+
+ ;;--------- Element 6: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Code for Data-Present
+
+ ;;--------- Element 7: Affected SOP Instance UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,1000)
+ (=fixnum-bytes #x1000 2 :Little-Endian)
+
+ (<encode-var Store-SOP-Instance-UID-Len fixnum 4 :Little-Endian) ;Length
+
+ (<encode-var Store-SOP-Instance-UID-Str ;Value
+ string
+ (<lookup-var Store-SOP-Instance-UID-Len) ;Global Env
+ :Null-Pad))
+
+ ;;---------------------------------------------
+ ;; C-Store-RQ PDU for RTPlan Data == COMPLETE PDU.
+ ;; Since fragmentation likely will be required, we send each
+ ;; data fragment in a PDU containing but a single PDV .
+
+ (:C-Store-RTPlan-Data
+
+ #x04 ;P-Data-TF PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ :Place-Holder ;PDV-Message length + 2 bytes
+
+ #x01 ;Presentation Context ID [1 byte]
+
+ (<pdv-mch :Data) ;Message Control Header [1 byte]
+
+ (<encode-data RTPlan-DataSet)) ;Dataset for entire RTPlan
+
+ ;;=============================================
+ ;; C-Store-RSP PDU Command/Message rule == COMPLETE PDU.
+
+ (:C-Store-RSP
+
+ #x04 ;P-Data-TF PDU Type tag [1 byte]
+
+ #x00 ;Reserved field [1 byte]
+
+ :Place-Holder ;PDU Length [4 bytes]
+
+ ;; PDV Length [4 bytes]
+ ;; Length is that of PC-ID byte + Control-Header byte + Message length.
+ :Place-Holder ;PDV-Message length + 2 bytes
+
+ (<encode-var PC-ID fixnum 1) ;Presentation Context ID [1 byte] Global
+
+ (<pdv-mch :Command) ;Message Control Header [1 byte]
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+
+ (<item-length 4 :Little-Endian) ;Value
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ (<encode-var Store-SOP-Class-UID-Len fixnum 4 :Little-Endian ;Length
+ :C-Store-RQ)
+
+ (<encode-var Store-SOP-Class-UID-Str ;Value
+ string
+ (<lookup-var Store-SOP-Class-UID-Len :C-Store-RQ)
+ :Null-Pad
+ :C-Store-RQ)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x8001 2 :Little-Endian) ;Code for C-Store-RSP
+
+ ;;--------- Element 4: Message ID [message being responded to]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0120)
+ (=fixnum-bytes #x0120 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (<encode-var Store-Msg-ID fixnum 2 :Little-Endian ;Length
+ :C-Store-RQ)
+
+ ;;--------- Element 5: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0101 2 :Little-Endian) ;Code for No-Data
+
+ ;;--------- Element 6: Response Status
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0900)
+ (=fixnum-bytes #x0900 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Code for Success
+
+ ;;--------- Element 7: Affected SOP Instance UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,1000)
+ (=fixnum-bytes #x1000 2 :Little-Endian)
+
+ (<encode-var Store-SOP-Instance-UID-Len fixnum 4 :Little-Endian ;Length
+ :C-Store-RQ)
+
+ (<encode-var Store-SOP-Instance-UID-Str ;Value
+ string
+ (<lookup-var Store-SOP-Instance-UID-Len :A-Associate-RQ)
+ :Null-Pad
+ :C-Store-RQ))
+
+ ;;=============================================
+
+ ))
+
+;;;=============================================================
+
+(eval-when (EVAL LOAD)
+ (compile-rules *Generator-Rule-List* :Generator-Rule)
+ (setq *Generator-Rule-List* nil))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/generator.cl b/dicom/src/generator.cl
new file mode 100644
index 0000000..3fedba9
--- /dev/null
+++ b/dicom/src/generator.cl
@@ -0,0 +1,657 @@
+;;;
+;;; generator
+;;;
+;;; Rule-based PDU Instantiation for DICOM Message Generation.
+;;; Contains functions common to Client and Server.
+;;;
+;;; 11-Apr-2001 BobGian convert TCP stream reading/writing code to work
+;;; in ACL Version 6.0 (READ-SEQUENCE, WRITE-SEQUENCE slightly buggy).
+;;; 30-Jul-2001 BobGian improve formatting of data sent to log file.
+;;; 18-Aug-2001 BobGian WRITE-VECTOR -> WRITE-SEQUENCE. More portable.
+;;; 24-Jan-2002 BobGian full PDU dump only at log level 4 [full debug mode].
+;;; 16-Apr-2002 BobGian MISHAP called in any generator function prints
+;;; list-structure representation of output generated so far.
+;;; 16-Apr-2002 BobGian convert GENERATE-GROUP, GENERATE-ITEM, GENERATE-TERM,
+;;; and GENERATE-PDU to return list structure which SEND-PDU then fragments
+;;; [if needed] and packs into TCP-Buffer for transmission.
+;;; 16-Apr-2002 BobGian PUT-FIXNUM-{LE,BE}{1,2,4} inlined into INSTANTIATE-PDU.
+;;; 24-Apr-2002 BobGian move OBJECT-LENGTH here to fix dependency.
+;;; Needed in both Client and Server.
+;;; 30-Apr-2002 BobGian fix bug in <PDV-MCH implementation.
+;;; 05-May-2002 BobGian enforce constraint that P-Data-TF fragmentation
+;;; can occur only on an even byte boundary.
+;;; 10-May-2002 BobGian *MAX-DATAFIELD-LEN* checked once when association
+;;; accepted rather than in every PDU sent.
+;;; 10-May-2002 BobGian modify SEND-PDU to compute PDU and PDV lengths and
+;;; substitute values in appropriate fields rather than doing expansion in
+;;; rules. :Place-Holder token is used to mark field in rules. This change
+;;; is required to make fragmentation work correctly.
+;;; Jul/Aug 2002 BobGian accessor name change: <MCH -> <PDV-MCH .
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; Use 16384 as a max PDU size during association negotiation process,
+;;; ie, for A-Assoc-RQ/AC PDUs. After that, *MAX-DATAFIELD-LEN* holds
+;;; negotiated value to be used for rest of association.
+
+(defun send-pdu (pdutype env tcp-buffer tcp-strm &rest args
+ &aux (limit (or *max-datafield-len* 16384))
+ (log-level *log-level*))
+
+ "ARGS is sequence of alternating KEY/VALUE pairs.
+A key can be a Dicom variable or the tag :Set"
+
+ (declare (type symbol pdutype)
+ (type list env args)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum limit log-level))
+
+ (when (>= log-level 2)
+ (format t "~%SEND-PDU: Sending ~A PDU, ~A."
+ (get pdutype 'documentation) (date/time))
+ (when (and (consp args)
+ (>= log-level 3))
+ (format t " Args (dec):~%")
+ (do ((args2 args (cddr args2))
+ (key) (val))
+ ((null args2))
+ (setq key (first args2) val (second args2))
+ (cond ((eq key :Set)
+ (unless (consp val)
+ (mishap env nil "SEND-PDU [1] Bad :Set args: ~S" args))
+ (format t "~% Multiple-Valued Environment values:")
+ (do ((items val (cdr items))
+ (cnt 1 (the fixnum (1+ cnt))))
+ ((null items))
+ (declare (type list items)
+ (type fixnum cnt))
+ (format t "~% Set ~D:" cnt)
+ (dolist (pair (car items))
+ (format t "~% Arg: ~A~38TValue: ~S"
+ (car pair) (cdr pair)))))
+ (t (format t "~% Arg: ~S~38TValue: ~S" key val)))))
+ (terpri))
+
+ (do ((args2 args (cddr args2)))
+ ((null args2))
+ ;; BINDING rather than UPDATING environment because change is temporary.
+ ;; If structured value is being used as environmental value, argument
+ ;; value passed to SEND-PDU must be appropriately structured.
+ (push (cons (first args2) (second args2)) env))
+
+ ;; GENERATE-PDU returns list-structure for the entire unfragmented PDU.
+ ;; This loop fragments it into separate PDVs [if necessary], adding the
+ ;; appropriate PDU header terms in front of each PDV.
+ (do ((pdulist (generate-pdu pdutype env nil)))
+ ((null pdulist))
+
+ (declare (type list pdulist))
+
+ (when (>= log-level 4)
+ (format t "~%PDU to be fragmented and transmitted [decimal]:~% ~S~%"
+ pdulist))
+
+ (do ((ptr pdulist) (instantiated-length 0) (term-val) (tag) (term-len 0)
+ (termlist '()) (pc-id) (mch) (bytes-transmitted 0) (odd-separator?))
+ ((null ptr)
+ (setq termlist (nreverse termlist)) ;Put back in forward order.
+
+ ;; All PDUs get their length instantiated here.
+ ;; Decrement BYTES-TRANSMITTED by 6 for the 6 PDU header bytes not
+ ;; counted in PDU length field. Result is number of message/data
+ ;; bytes to be transmitted in the current [last or only] PDU.
+ (unless (eq (third termlist) :Place-Holder)
+ (mishap env nil "SEND-PDU [2] Bad termlist: ~S" termlist))
+ (setq bytes-transmitted (the fixnum (- bytes-transmitted 6)))
+ (setf (third termlist) ;PDU Length field.
+ (list 'fixnum 4 :Big-Endian bytes-transmitted))
+ ;Only P-Data-TF PDUs can be fragmented.
+ (when (eq (first termlist) #x04)
+ ;; In addition, P-Data-TF PDUs get additional terms instantiated.
+ ;; If MCH term is a list (<PDV-MCH :Command) or (<PDV-MCH :Data)
+ ;; then it is a Message Control Header to be expanded here.
+ ;; #b******XY [* is don't-care bit, X and Y are 2 low-order bits]
+ ;; Bit X = 0 -> Message is NOT last fragment.
+ ;; Bit X = 1 -> Message IS last fragment.
+ ;; Bit Y = 0 -> Message is Data-Set.
+ ;; Bit Y = 1 -> Message is a Command.
+ (unless (and (eq (second termlist) #x00)
+ (eq (fourth termlist) :Place-Holder)
+ (typep (fifth termlist) 'fixnum) ;Pres Context ID.
+ (consp (setq mch (sixth termlist)))
+ (eq (first mch) '<pdv-mch))
+ (mishap env nil "SEND-PDU [3] Bad termlist: ~S" termlist))
+ (setf (fourth termlist)
+ (list 'fixnum 4 :Big-Endian
+ (the fixnum (- bytes-transmitted 4)))) ;PDV Len field.
+ (setf (sixth termlist) ;Update MCH - LAST fragment.
+ (cond ((eq (second mch) :Command) #b00000011)
+ (t #b00000010))))
+
+ ;; And transmit the PDU.
+ (setq instantiated-length (instantiate-pdu termlist tcp-buffer limit))
+ (when (>= log-level 2)
+ (format t "~%SEND-PDU: Sending All or Last Fragment, ~D bytes.~%"
+ instantiated-length)
+ (when (>= log-level 4)
+ (dump-bytestream "Outgoing PDU [All or Last Fragment]"
+ tcp-buffer 0 instantiated-length)))
+ (write-sequence tcp-buffer tcp-strm :start 0 :end instantiated-length)
+ (force-output tcp-strm)
+
+ (setq pdulist nil))
+
+ (declare (type list ptr termlist)
+ (type (or list (integer #x00 #xFF)) mch)
+ (type (member nil t) odd-separator?)
+ (type fixnum term-len bytes-transmitted instantiated-length))
+
+ (setq term-len
+ (cond ((consp (setq term-val (car ptr)))
+ (cond ((or (eq (setq tag (first term-val)) 'fixnum)
+ (eq tag 'string))
+ ;; For FIXNUM or STRING terms, second element is
+ ;; length field [including padding for strings].
+ (second term-val))
+ ((eq tag '<pdv-mch)
+ 1)
+ (t (mishap env nil "SEND-PDU [4] Bad term: ~S"
+ term-val))))
+ ;;
+ ;; :Place-Holder is used to expand 4-byte Big-Endian
+ ;; length field in PDU or PDV.
+ ((eq term-val :Place-Holder)
+ 4)
+ ;;
+ ;; Otherwise term must be a single-byte fixnum
+ ;; [checked previously].
+ ((typep term-val 'fixnum)
+ 1)
+ ;;
+ ;; Otherwise we forgot something.
+ (t (mishap env nil "SEND-PDU [5] Bad term: ~S" term-val))))
+
+ ;; BYTES-TRANSMITTED is total number of bytes [including header terms]
+ ;; to be transmitted in next PDU. Spec requires fragmentation to be on
+ ;; an even byte boundary. If a string ending on an odd boundary has just
+ ;; been transmitted, it will be followed by a separator or padding byte.
+ ;; If the string fits, so does the separator/padding byte [since LIMIT
+ ;; is even]. If a string ending on an even boundary has just been
+ ;; transmitted, it will NOT be followed by a padding byte but it MIGHT
+ ;; be followed by a separator byte. If so, and the separator byte fits
+ ;; but the next item does not, the fragment would end on an odd boundary
+ ;; unless we move the separator byte from the last to the next fragment.
+ ;;
+ ;; For PDUs other than P-Data-TF the even-length constraint does not
+ ;; apply, but such PDUs will not get fragmented anyway and so this
+ ;; branch will never be triggered.
+ (cond
+ ((<= (setq bytes-transmitted
+ (the fixnum (+ bytes-transmitted term-len)))
+ limit)
+ (push term-val termlist) ;Accumulate all terms that fit.
+ (setq ptr (cdr ptr)))
+
+ ;; Must modify PDU template for transmission of current fragment and
+ ;; defer rest of terms in original input list to next fragment [with
+ ;; appropriate header terms prepended]. Decrement BYTES-TRANSMITTED
+ ;; by size of current term NOT transmitted in upcoming PDU. Note that
+ ;; fragmentation only works if the PDU being fragmented was constructed
+ ;; via a rule specifying it to contain a single PDV. After sending
+ ;; each accumulated fragment, we construct and prepend to the remaining
+ ;; data terms the header terms for a new single-PDV-containing PDU.
+ (t (setq bytes-transmitted (the fixnum (- bytes-transmitted term-len)))
+ (setq odd-separator? nil)
+
+ ;; If after splitting the fragments we discover the last was of odd
+ ;; length, the only way that could happen was that a separator byte
+ ;; just fit, bringing the length to odd, and the next string did not
+ ;; fit. ; Any other situation is an error condition. Move separator
+ ;; byte from the pre-split fragment to the post-split fragment.
+ (unless (evenp bytes-transmitted)
+ (cond ((eq (car termlist) #.(char-code #\\))
+ (setq termlist (cdr termlist))
+ (setq bytes-transmitted
+ (the fixnum (1- bytes-transmitted)))
+ (setq odd-separator? t))
+ (t (mishap
+ env nil
+ "Send-PDU [6] Odd-length frag ends on weird byte."))))
+
+ (setq termlist (nreverse termlist)) ;Put back in forward order.
+
+ ;; Only P-Data-TF PDUs can be fragmented.
+ (unless (and (eq (first termlist) #x04)
+ (eq (second termlist) #x00)
+ (eq (third termlist) :Place-Holder)
+ (eq (fourth termlist) :Place-Holder)
+ (typep (setq pc-id (fifth termlist)) 'fixnum)
+ (consp (setq mch (sixth termlist)))
+ (eq (first mch) '<pdv-mch))
+ (mishap env nil "SEND-PDU [7] Bad termlist: ~S" termlist))
+
+ ;; Decrement BYTES-TRANSMITTED by 6 for the 6 PDU header bytes not
+ ;; counted in PDU length field. Result is number of message/data
+ ;; bytes to be transmitted in the current [fragmented] PDU.
+ (setq bytes-transmitted (the fixnum (- bytes-transmitted 6)))
+ (setf (third termlist) ;PDU Length field.
+ (list 'fixnum 4 :Big-Endian bytes-transmitted))
+ (setf (fourth termlist) ;PDV Length field.
+ (list 'fixnum 4 :Big-Endian
+ (the fixnum (- bytes-transmitted 4))))
+ (setf (sixth termlist) ;MCH for current [NOT-LAST] fragment.
+ (cond ((eq (second mch) :Command) #b00000001)
+ (t #b00000000)))
+
+ ;; And transmit the PDU.
+ (setq instantiated-length
+ (instantiate-pdu termlist tcp-buffer limit))
+ (when (>= log-level 2)
+ (format t "~%SEND-PDU: Sending Non-Last Fragment, ~D bytes.~%"
+ instantiated-length)
+ (when (>= log-level 4)
+ (dump-bytestream "Outgoing PDU [Non-Last Fragment]"
+ tcp-buffer 0 instantiated-length)))
+ (write-sequence tcp-buffer tcp-strm
+ :start 0 :end instantiated-length)
+ (force-output tcp-strm)
+ (setq pdulist
+ (list* #x04
+ #x00
+ ;; PDU Length field for next PDU [fragment].
+ ;; Placeholder for length value which will be filled in
+ ;; before PDU is instantiated - when length is known.
+ :Place-Holder
+ ;; Ditto but PDV Length field.
+ :Place-Holder
+ pc-id ;Presentation Context ID.
+ mch ;Restore MCH term for next fragment.
+ (cond (odd-separator?
+ ;; If separator byte was moved from last to
+ ;; next fragment [due to last fragment ending
+ ;; on odd boundary], stick it back in as first
+ ;; data byte in next fragment.
+ (cons #.(char-code #\\) ptr))
+ (t ptr))))
+ ;; Reset PTR to beginning of newly-inserted header terms.
+ (setq ptr pdulist)
+ ;; Reset count of bytes to be sent in next PDU.
+ (setq bytes-transmitted 0)
+ ;; Reset TERMLIST to begin accumulation anew.
+ (setq termlist nil))))))
+
+;;;-------------------------------------------------------------
+;;; INSTANTIATE-PDU transfers list-structure representing [an already
+;;; fragmented, if necessary] PDU to the TCP buffer. LIMIT must be EVEN
+;;; [ie, fragmentation can only be done on an even byte boundary].
+
+(defun instantiate-pdu (output-itemlist tcp-buffer limit &aux code (tail 0))
+
+ (declare (type list output-itemlist)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum tail limit))
+
+ (dolist (term output-itemlist)
+ (cond
+ ((atom term)
+ (unless (and (typep term 'fixnum)
+ (<= 0 (the fixnum term) #xFF))
+ (setq *PDU-tail* tail)
+ (mishap nil tcp-buffer
+ "INSTANTIATE-PDU [1] Bad atomic fixnum term: ~S" term))
+ (unless (< tail limit)
+ (setq *PDU-tail* tail)
+ (mishap nil tcp-buffer
+ "INSTANTIATE-PDU [2] Buffer overrun on atomic term: ~S" term))
+ (setf (aref tcp-buffer tail) term)
+ (setq tail (the fixnum (1+ tail))))
+
+ ((eq (setq code (first term)) 'fixnum)
+ (let ((size (second term))
+ (endian (third term))
+ (val (fourth term)))
+ (declare (type (member :Big-Endian :Little-Endian) endian)
+ (type fixnum size val))
+ (cond
+ ((> (the fixnum (+ size tail)) limit)
+ (setq *PDU-tail* tail)
+ (mishap nil tcp-buffer
+ "INSTANTIATE-PDU [3] Buffer overrun on fixnum term: ~S"
+ term))
+ ((= size 1)
+ (setf (aref tcp-buffer tail) val)
+ (setq tail (the fixnum (1+ tail))))
+ ((= size 2)
+ (cond ((eq endian :Little-Endian)
+ (setf (aref tcp-buffer tail) (logand #x00FF val))
+ (setf (aref tcp-buffer (the fixnum (1+ tail)))
+ (ash (logand #xFF00 val) -8)))
+ (t (setf (aref tcp-buffer tail) (ash (logand #xFF00 val) -8))
+ (setf (aref tcp-buffer (the fixnum (1+ tail)))
+ (logand #x00FF val))))
+ (setq tail (the fixnum (+ tail 2))))
+ ((= size 4)
+ ;; Largest mask should be #xFF000000, but using smaller value
+ ;; keeps it POSITIVE FIXNUM, and no value will exceed 536870911.
+ (cond ((eq endian :Little-Endian)
+ (setf (aref tcp-buffer tail) (logand #x000000FF val))
+ (setf (aref tcp-buffer (the fixnum (1+ tail)))
+ (ash (logand #x0000FF00 val) -8))
+ (setf (aref tcp-buffer (the fixnum (+ tail 2)))
+ (ash (logand #x00FF0000 val) -16))
+ (setf (aref tcp-buffer (the fixnum (+ tail 3)))
+ (ash (logand #x1F000000 val) -24)))
+ (t (setf (aref tcp-buffer tail)
+ (ash (logand #x1F000000 val) -24))
+ (setf (aref tcp-buffer (the fixnum (1+ tail)))
+ (ash (logand #x00FF0000 val) -16))
+ (setf (aref tcp-buffer (the fixnum (+ tail 2)))
+ (ash (logand #x0000FF00 val) -8))
+ (setf (aref tcp-buffer (the fixnum (+ tail 3)))
+ (logand #x000000FF val))))
+ (setq tail (the fixnum (+ tail 4))))
+ (t (setq *PDU-tail* tail)
+ (mishap nil tcp-buffer "INSTANTIATE-PDU [4] Bad fixnum term: ~S"
+ term)))))
+
+ ((eq code 'string)
+ (let* ((strval (fourth term))
+ (strlen (length strval))
+ (strpad (third term))
+ (varlen (second term)))
+ (declare (type simple-base-string strval)
+ (type (member :No-Pad :Space-Pad :Null-Pad) strpad)
+ (type fixnum strlen varlen))
+ (when (> (the fixnum (+ varlen tail)) limit)
+ (setq *PDU-tail* tail)
+ (mishap nil tcp-buffer
+ "INSTANTIATE-PDU [5] Buffer overrun on string term: ~S"
+ term))
+ (do ((from-idx 0 (the fixnum (1+ from-idx)))
+ (to-idx tail (the fixnum (1+ to-idx))))
+ ((= from-idx strlen)
+ (cond
+ ((= strlen varlen)
+ ;; If :No-Pad string length [STRLEN] did not match
+ ;; required length [VARLEN], GENERATE-TERM triggers
+ ;; an error and we never get this far.
+ (setq tail to-idx))
+ ((eq strpad :Null-Pad)
+ (setf (aref tcp-buffer to-idx) 0)
+ (setq tail (the fixnum (1+ to-idx))))
+ ((eq strpad :Space-Pad)
+ (do ((idx to-idx (the fixnum (1+ idx)))
+ (cnt strlen (the fixnum (1+ cnt))))
+ ((= cnt varlen)
+ (setq tail idx))
+ (declare (type fixnum idx cnt))
+ (setf (aref tcp-buffer idx) #.(char-code #\Space))))
+ (t (mishap nil tcp-buffer
+ "INSTANTIATE-PDU [6] Bad length/padding in term: ~S"
+ term))))
+ (declare (type fixnum from-idx to-idx))
+ (setf (aref tcp-buffer to-idx)
+ (char-code (aref strval from-idx))))))
+
+ (t (setq *PDU-tail* tail)
+ (mishap nil tcp-buffer "INSTANTIATE-PDU [7] Bad unknown term: ~S"
+ term))))
+
+ tail)
+
+;;;-------------------------------------------------------------
+;;; GENERATE-PDU returns list-structure for the entire unfragmented PDU.
+;;; SEND-PDU fragments it [if necessary] into separate PDUs, each containing
+;;; header terms plus a single PDV.
+
+(defun generate-pdu (pdutype env output-itemlist)
+
+ (declare (type symbol pdutype)
+ (type list env output-itemlist))
+
+ (let ((rulebody (get pdutype :Generator-Rule)))
+ (cond ((consp rulebody)
+ ;; All generator functions up to now have CONSed new items onto
+ ;; front of output list. Here we reverse it to present final PDU
+ ;; in forward order.
+ (nreverse (generate-group rulebody env output-itemlist)))
+ (t (mishap env nil "GENERATE-PDU [1] Missing PDU definition: ~S"
+ pdutype)))))
+
+;;;-------------------------------------------------------------
+
+(defun generate-group (termlist env output-itemlist
+ &aux (backpatch-stack '()) slotlen dataend)
+
+ (declare (type list termlist env output-itemlist backpatch-stack))
+
+ (dolist (term termlist)
+ (cond
+ ((and (consp term)
+ (eq (first term) '<item-length))
+ ;; An <ITEM-LENGTH element causes insertion at that point in the list
+ ;; representing an item [as defined by a clause in a rule] of the
+ ;; length-to-end as a list of 2 or 4 bytes, big or little endian, where
+ ;; "length" means the number of bytes from the END of the <ITEM-LENGTH
+ ;; element [ie, the beginning of the NEXT field] to the end of the
+ ;; entire item. An <ITEM-LENGTH can be any element of an item AFTER
+ ;; the first, and an item can contain multiple <ITEM-LENGTH elements.
+ (cond
+ ((and (typep (setq slotlen (second term)) 'fixnum)
+ (or (= (the fixnum slotlen) 2)
+ (= (the fixnum slotlen) 4))
+ (keywordp (setq dataend (third term)))
+ (or (eq dataend :Big-Endian)
+ (eq dataend :Little-Endian)))
+ ;; Push a backpatch-target token with information indicating
+ ;; how to perform backpatch substitution later when length is known.
+ (push (list 'fixnum slotlen dataend nil) output-itemlist)
+ (push output-itemlist backpatch-stack))
+
+ (t (mishap env output-itemlist "GENERATE-GROUP [1] Bad term: ~S"
+ term))))
+
+ (t (setq output-itemlist (generate-term term env output-itemlist)))))
+
+ ;; Backpatch any deferred <ITEM-LENGTH fields.
+ (do ((items backpatch-stack (cdr items))
+ (backpatch-pointer))
+ ((null items))
+ (declare (type list items backpatch-pointer))
+ (setq backpatch-pointer (car items))
+ (setf (fourth (car backpatch-pointer))
+ (object-length output-itemlist backpatch-pointer)))
+
+ output-itemlist)
+
+;;;-------------------------------------------------------------
+
+(defun object-length (output-itemlist object-start)
+
+ (declare (type list output-itemlist object-start))
+
+ (do ((ptr output-itemlist (cdr ptr))
+ (term) (tag)
+ (byte-count 0))
+ ((eq ptr object-start)
+ byte-count)
+
+ (declare (type list ptr)
+ (type fixnum byte-count))
+
+ (cond
+ ((consp (setq term (car ptr)))
+ (cond ((eq (setq tag (first term)) '<pdv-mch)
+ (setq byte-count (the fixnum (1+ byte-count))))
+ ((or (eq tag 'fixnum)
+ (eq tag 'string))
+ ;; For FIXNUM or STRING terms, second element is length field
+ ;; [including padding for strings].
+ (setq byte-count
+ (the fixnum (+ byte-count (the fixnum (second term))))))
+ (t (mishap nil nil "OBJECT-LENGTH [1] Bad term: ~S" term))))
+
+ #+ignore
+ ;; OBJECT-LENGTH should never see this term, since only length fields
+ ;; of PDUs are expanded procedurally via this term. OBJECT-LENGTH is
+ ;; only used on structure internal to the data in a PDU.
+ ((eq term :Place-Holder)
+ ;; :Place-Holder is used to expand 4-byte Big-Endian
+ ;; length field in PDU or PDV.
+ (setq byte-count (the fixnum (+ byte-count 4))))
+
+ ((typep term 'fixnum)
+ (setq byte-count (the fixnum (1+ byte-count))))
+
+ ;; If we mistakenly run off end [missing OBJECT-START], PTR will be NIL,
+ ;; thus so will TERM, and this branch will catch the error.
+ (t (mishap nil nil "OBJECT-LENGTH [2] Bad term: ~S" term)))))
+
+;;;-------------------------------------------------------------
+
+(defun generate-term (term env output-itemlist &aux tag varname varval vartype
+ varlen varend-pad access-chain term-2 term-3)
+
+ (declare (type list env output-itemlist)
+ (type symbol varname vartype varend-pad))
+
+ (cond
+ ((or (eq term :Place-Holder) ;Filled in by procedural expansion later.
+ (typep term 'fixnum)) ;Value expanded at rule-compilation time.
+ (push term output-itemlist)) ;Direct pass-through.
+
+ ((keywordp term) ;Invoke sub-rule for expansion.
+ (setq output-itemlist (generate-item term env output-itemlist)))
+
+ ((atom term) ;Oops!
+ (mishap env output-itemlist "GENERATE-TERM [1] Bad atomic term: ~S" term))
+
+ ;; All terms from this point onward are known to be non-empty LISTs.
+ ;; Must set all locals to subterms here, whether used immediately or not.
+ ((eq (setq term-2 (second term) ;Preset to be used as local
+ term-3 (third term) ;Preset to be used as local
+ tag (first term)) ;Preset as local and do comparison
+ :Set)
+ ;; The :Set operator causes the instantiation of a set of items, each
+ ;; with its own local environment in which its "global" variable values
+ ;; are dereferenced. Used to instantiate multiple Presentation Contexts.
+ ;; NB: There can exist only one :Set-valued item in the environment;
+ ;; if more than one needed, will have to implement different tags to
+ ;; distinguish them.
+ (dolist (local-env (item-lookup :Set env t))
+ (setq output-itemlist
+ (generate-item term-2 local-env output-itemlist))))
+
+ ((eq tag '<if) ;DICOM Conditional
+ ;; Predicate function [second element] is applied to two arguments --
+ ;; an arbitrary unevaluated argument passed as third element of the term,
+ ;; and the environment. If predicate returns TRUE, then expand fourth
+ ;; element of the term as a rule item.
+ (when (funcall term-2 term-3 env)
+ (setq output-itemlist
+ (generate-item (fourth term) env output-itemlist))))
+
+ ((eq tag '<encode-var) ;DICOM Variable as term instantiation
+
+ (setq varname term-2 ;All variables have names
+ vartype term-3 ;All variables have types
+ varlen (fourth term) ;All objects have lengths
+ access-chain (cddr (cdddr term)) ;Starts with SIXTH element
+ varval (apply #'item-lookup varname env t access-chain))
+
+ (cond
+ ((typep varlen 'fixnum))
+
+ ((consp varlen)
+ (cond
+ ((eq (first varlen) '<lookup-var)
+ ;; DICOM Variable environmental lookup.
+ (setq varlen
+ (apply #'item-lookup (second varlen) env t access-chain)))
+
+ ((eq (first varlen) '<funcall) ;Lisp Function
+ (setq varlen (apply (second varlen) (eval-args (cddr varlen) env))))
+
+ (t (mishap env output-itemlist
+ "GENERATE-TERM [2] Bad length ~S in:~%~S" varlen term)))
+
+ (unless (and (typep varlen 'fixnum)
+ (<= 0 (the fixnum varlen) 10240))
+ (mishap env output-itemlist "GENERATE-TERM [3] Bad length ~S in:~%~S"
+ varlen term)))
+
+ (t (mishap env output-itemlist "GENERATE-TERM [4] Bad length ~S in:~%~S"
+ varlen term)))
+
+ ;; :Big-Endian or :Little-Endian for FIXNUMs.
+ ;; :No-Pad, :Space-Pad, or :Null-Pad for STRINGs.
+ ;; Can be left off [ie, NIL] for 1-byte fixnums.
+ (setq varend-pad (fifth term))
+
+ (cond
+ ((eq vartype 'fixnum)
+ (unless (typep varval 'fixnum)
+ (mishap env output-itemlist "GENERATE-TERM [5] Bad value ~S in:~%~S"
+ varval term))
+ (cond ((= (the fixnum varlen) 1)
+ (push varval output-itemlist))
+ ((and (or (= (the fixnum varlen) 2)
+ (= (the fixnum varlen) 4))
+ (or (eq varend-pad :Big-Endian)
+ (eq varend-pad :Little-Endian)))
+ (push (list 'fixnum varlen varend-pad varval) output-itemlist))
+ (t (mishap env output-itemlist
+ "GENERATE-TERM [6] Bad Length/Endian in:~%~S" term))))
+
+ ((eq vartype 'string)
+ (let ((strlen 0))
+ (declare (type fixnum strlen))
+ (unless (and (typep varval 'simple-base-string)
+ (setq strlen (length (the simple-base-string varval)))
+ (or (and (eq varend-pad :No-Pad)
+ (= strlen (the fixnum varlen)))
+ (and (eq varend-pad :Space-Pad)
+ (<= 1 strlen (the fixnum varlen)))
+ (and (eq varend-pad :Null-Pad)
+ (<= (the fixnum (1- varlen))
+ strlen
+ (the fixnum varlen)))))
+ (mishap env output-itemlist "GENERATE-TERM [7] Bad term: ~S" term))
+ (push (list 'string varlen varend-pad varval) output-itemlist)))
+
+ (t (mishap env output-itemlist "GENERATE-TERM [8] Bad type ~S in:~%~S"
+ vartype term))))
+
+ ((eq tag '<encode-data)
+ (setq output-itemlist
+ (generate-object (item-lookup (second term) env t)
+ env output-itemlist)))
+
+ ;; <PDV-MCH terms will be expanded by SEND-PDU after fragmentation
+ ;; needs are established.
+ ((eq tag '<pdv-mch)
+ (push term output-itemlist))
+
+ (t (mishap env output-itemlist "GENERATE-TERM [9] Bad compound term: ~S"
+ term)))
+
+ output-itemlist)
+
+;;;-------------------------------------------------------------
+
+(defun generate-item (item env output-itemlist)
+
+ (declare (type symbol item)
+ (type list env output-itemlist))
+
+ (let ((rulebody (get item :Generator-Rule)))
+ (cond
+ ((consp rulebody)
+ (generate-group rulebody env output-itemlist))
+ (t (mishap env output-itemlist "GENERATE-ITEM [1] Bad item: ~S" item)))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/mainloop.cl b/dicom/src/mainloop.cl
new file mode 100644
index 0000000..b40698d
--- /dev/null
+++ b/dicom/src/mainloop.cl
@@ -0,0 +1,375 @@
+;;;
+;;; mainloop
+;;;
+;;; Main Driver Loop for DICOM Message Interpretation and Protocol Actions.
+;;; Contains functions common to Client and Server.
+;;;
+;;; 11-Apr-2001 BobGian convert TCP stream reading/writing code to work
+;;; in ACL Version 6.0 (READ-SEQUENCE, WRITE-SEQUENCE slightly buggy).
+;;; 15-Apr-2001 BobGian further hacks to get READ-VECTOR to work correctly.
+;;; Does non-blocking READ. Code previously assumed blocking READ.
+;;; 25-Apr-2001 BobGian fix DUL-MAINLOOP to parse PDUs when multiple PDUs
+;;; come in on a single non-blocking READ with possible read-ahead.
+;;; 30-Jul-2001 BobGian improve formatting of data sent to log file.
+;;; 18-Aug-2001 BobGian READ-VECTOR -> READ-SEQUENCE. More portable.
+;;; 09-Jan-2001 BobGian modularize system allowing subsystems to be built
+;;; from common code. DICOM-MAINLOOP takes mode argment to indicate
+;;; :Client or :Server role on per-association basis, and thus it can
+;;; stack role functionality [server can invoke client temporarily].
+;;; 24-Jan-2002 BobGian full PDU dump only at log level 4 [full debug mode].
+;;; 15-Mar-2002 BobGian TCP stream closed at end of transaction is
+;;; no longer logged as an error.
+;;; 16-Mar-2002 BobGian convert READ-SEQUENCE to use blocking READ.
+;;; Non-blocking READ and byte-shifting is too error-prone.
+;;; DUL-MAINLOOP reads and parses incoming PDUs starting at offset zero.
+;;; 21-Mar-2002 BobGian SOCKET-RESET error intercepted and interpreted as
+;;; Stream-Closed-by-Remote-Host [some, but not all, clients terminate
+;;; TCP connection this way]. DUL handles this as ordinary Stream-Closed.
+;;; 24-Apr-2002 BobGian triggering EVENT-15 sets *STATUS-MESSAGE* rather
+;;; than action function invoked - finer discrimination this way.
+;;; 04-May-2002 BobGian implement byte-shifting scheme to allow fragmentation
+;;; on arbitrary [as long as it is EVEN] byte borders within objects and
+;;; Group/Element tag and Length-field headers. This is done by checking
+;;; continuation from PARSE-OBJECT for length of stored shifted bytes and
+;;; skipping over them in next READ, resetting HEAD pointer to compensate.
+;;; 04-May-2002 BobGian add TCP buffer overrun check when reading TCP stream.
+;;; 05-May-2002 BobGian if dumping incoming PDU, included leftover bytes
+;;; downshifted by previous PARSE-OBJECT call with bytes in new PDU read.
+;;; 06-May-2002 BobGian add error message arg to REPORT-ERROR calls.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+(defun dicom-mainloop (tcp-buffer tcp-strm new-environment
+ *mode* ;Role: :Client or :Server.
+ ;; Client: Signal to contact a Server - EVENT-01.
+ ;; Server: Signal that connection accepted - EVENT-05.
+ *event*
+ &aux
+ (*state* 'state-01) ;Client or Server start state
+ ;; All internal state variables are bound to initial
+ ;; values on establishment of a new connection [server
+ ;; role] or invocation [client role].
+ (*SOP-class-name* nil) (*parser-state* nil)
+ (*args* nil))
+
+ ;; DICOM-MAINLOOP runs as an infinite loop, terminating when a Next-State
+ ;; of NIL is selected by the state-transition table, causing DUL-MAINLOOP
+ ;; to return :Return as first value.
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type list new-environment)
+ (type (member :Client :Server) *mode*)
+ (type symbol *event* *state*))
+
+ (do ((iteration 0 (the fixnum (1+ iteration)))
+ (pdutype-alist *Code/PDUtype-Alist*)
+ (old-environment nil))
+ ((eq new-environment :Return))
+
+ (declare (type list pdutype-alist old-environment)
+ (type fixnum iteration))
+
+ (when (>= (the fixnum *log-level*) 2)
+ (format t "~%PDS Iteration ~D, State ~A: ~A.~%"
+ iteration *state* (get *state* 'documentation))
+ (when (>= (the fixnum *log-level*) 3)
+ (unless (eq old-environment new-environment)
+ (setq old-environment new-environment)
+ (print-environment new-environment))))
+
+ (when (eq *mode* :Client)
+ (setq tcp-strm *connection-strm*))
+
+ (setq new-environment (dul-mainloop new-environment ; Environment
+ tcp-buffer ; TCP buffer
+ tcp-strm ; TCP stream
+ pdutype-alist)))) ; Parser data
+
+;;;-------------------------------------------------------------
+
+(defun dul-mainloop (env tcp-buffer tcp-strm pdutype-alist &aux (head 0)
+ (tail 6) (pdu-end 0) timeout? eof? connection-reset?
+ (log-level *log-level*) (continuation *parser-state*))
+
+ (declare (type list env pdutype-alist)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type (member nil t) timeout? eof? connection-reset?)
+ (type (or null (simple-array t (10))) continuation)
+ (type fixnum head tail pdu-end log-level))
+
+ (when (>= log-level 3)
+ (format t "~%Enter DUL-MAINLOOP (~A)~%" *mode*))
+
+ ;; If an event is already signaled on loop entry or by the previous
+ ;; action-function, we proceed at once to the State interpreter.
+ ;; Otherwise, parse next PDU, reading more TCP input if necessary.
+ (unless *event*
+ (mp:with-timeout (*artim-timeout* (setq timeout? t))
+ ;; Read and decode an incoming PDU. If PARSE-OBJECT moved unread bytes
+ ;; to beginning of TCP buffer, the continuation tells us how many bytes
+ ;; to skip over to begin new reading.
+ (when (arrayp continuation)
+ (setq head (aref (the (simple-array t (10)) continuation) 0))
+ (setq tail (the fixnum (+ head 6))))
+ (when (>= log-level 3)
+ (format t "~%Read PDU bytes ~D -> ~D~%" head tail))
+ (unless (< tail #.TCP-Bufsize)
+ (mishap env nil "DUL-MAINLOOP [1] Buffer overrun - TAIL: ~S" tail))
+ ;; Get first six bytes of PDU. PDU Type-Code is first byte at HEAD
+ ;; [normally zero, but may be greater if unread bytes from prior
+ ;; instantiation of PARSE-OBJECT were shifted to front of TCP buffer].
+ ;; PDU Length is stored in bytes 2 - 5 [after HEAD], Big-Endian.
+ ;; Must parse length before attempting to read rest of PDU because
+ ;; we don't yet know how many more bytes to read.
+ (unless
+ (ignore-errors
+ (cond
+ ((= (read-sequence tcp-buffer tcp-strm :start head :end tail) tail)
+ ;; Masks should be #xFF, but using smaller value keeps everything
+ ;; POSITIVE FIXNUM, and no value will exceed 536870911. Value
+ ;; stored PDU length field is length of rest of PDU -- add 6 bytes
+ ;; for type-code and length field to get total length.
+ ;; PDU-END points to end of PDU, including offset for any shifted
+ ;; left-over bytes and 6-byte code/length field.
+ (setq pdu-end
+ (the fixnum
+ (+ (logior ;PDU length not counting code/length field.
+ (ash (the (integer #x00 #x1F)
+ (logand #x1F
+ (the (integer #x00 #xFF)
+ (aref tcp-buffer
+ (the fixnum (+ head 2))))))
+ 24)
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (+ head 3))))
+ 16)
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (+ head 4)))) 8)
+ (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (+ head 5)))))
+ ;; TAIL points just past 6 bytes for code/length field.
+ tail)))
+ (unless (< pdu-end #.TCP-Bufsize)
+ (mishap env nil "DUL-MAINLOOP [2] Buffer overrun - PDU-END: ~S"
+ pdu-end))
+ (when (>= log-level 3)
+ (format t "~%Read PDU bytes ~D ->" tail))
+ (setq tail (read-sequence tcp-buffer tcp-strm
+ :start tail :end pdu-end))
+ (when (>= log-level 3)
+ (format t " ~D~%" tail))
+ t)
+ ;; Read of less than 6 bytes indicates End-of-File.
+ (t (when (>= log-level 3)
+ (format t "~%EOF on TCP stream signaled.~%"))
+ (setq eof? t))))
+ ;; Be sure to return non-NIL on success. NULL return indicates
+ ;; SOCKET-RESET error [ie, stream closed].
+ (setq connection-reset? t)))
+
+ ;; After the READ is done we test for errors, Connection-Closed, or EOF.
+ ;; If error happens in either READ-SEQUENCE call, it most likely is a
+ ;; SOCKET-RESET error. This indicates Stream-Closed by Remote Host,
+ ;; which DUL handles the same as End-of-File.
+ (cond
+ (connection-reset? ;Error case: Stream-Closed exit signals event 17.
+ (setq *event* 'event-17)
+ (when (>= log-level 1)
+ (format t "~%TCP connection closed (reset) or other error.~%")))
+
+ (timeout? ;Timeout during hung READ signals event 18.
+ (setq *event* 'event-18)
+ (format t "~%~A~%"
+ (setq *status-message*
+ (format nil "Timeout after ~D seconds."
+ *artim-timeout*)))
+ (report-error env nil))
+
+ ((or eof? (< tail pdu-end)) ;EOF conveyed from above.
+ (when (>= log-level 1)
+ (format t "~%End-of-file on TCP input stream.~%"))
+ (setq *event* 'event-17))
+
+ ;; If input is available [TAIL = PDU-END], parse incoming PDU.
+ ;; Save TCP buffer bounds for error reporting.
+ (t (setq *PDU-tail* pdu-end)
+ (multiple-value-bind (pdutype input-cont new-env)
+ (parse-pdu pdutype-alist env tcp-buffer head pdu-end)
+ (declare (type symbol pdutype)
+ (type list new-env)
+ (type fixnum input-cont))
+
+ (cond
+ ;; Unrecognized or Invalid PDU or bad PDU length.
+ ((eq pdutype :Fail)
+ (setq *event* 'event-19)
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 1: Unrecognized/Invalid PDU
+ (setq *args* '(Abort-Source 2 Abort-Diagnostic 1))
+ (format t "~%DUL-MAINLOOP [3] ~A~%"
+ (setq *status-message* "Received malformed PDU."))
+ (report-error env tcp-buffer))
+
+ ((= input-cont pdu-end) ;Successful PDU parse
+ (setq env new-env) ;Update environment
+ (when (>= log-level 2)
+ (format t "~%Decoded PDU type ~A (~D bytes total).~%"
+ (get pdutype 'documentation)
+ (the fixnum (- pdu-end head))))
+ (cond
+ ((eq pdutype :A-Associate-AC)
+ ;; A-Associate-AC PDU received on transport connection.
+ (setq *event* 'event-03))
+
+ ((eq pdutype :A-Associate-RJ)
+ ;; A-Associate-RJ PDU received on transport connection.
+ (setq *event* 'event-04))
+
+ ((eq pdutype :A-Associate-RQ)
+ ;; A-Associate-RQ PDU received on transport connection.
+ (setq *event* 'event-06))
+
+ ((eq pdutype :P-Data-TF)
+ ;; P-Data-TF DICOM Message [Command or Data-Set] received.
+ ;; PDV-Message environment variable contains structure as:
+ ;; ( :Message <Start-Idx> <End-Idx> ) with indices refering
+ ;; to TCP-Buffer -- both must be within current PDV.
+ ;; NB: More than one PDV-Item can arrive in a single PDU.
+ ;; Use :Set retrieval to access them.
+ (setq *event* 'event-10))
+
+ ((eq pdutype :A-Release-RQ)
+ ;; A-Release-RQ PDU received on open connection.
+ ;; SCU signals EVENT-12A and SCP signals EVENT-12B.
+ (setq *event* (cond ((eq *mode* :Client) 'event-12A)
+ (t 'event-12B))))
+
+ ((eq pdutype :A-Release-RSP)
+ ;; A-Release-RSP PDU received on open connection.
+ (setq *event* 'event-13))
+
+ ((eq pdutype :A-Abort)
+ ;; A-Abort PDU received on open connection.
+ (setq *event* 'event-16)
+ (format t "~%DUL-MAINLOOP [4] ~A~%"
+ (setq *status-message* "Received A-Abort PDU."))
+ (report-error env tcp-buffer))
+
+ (t (mishap env tcp-buffer "DUL-MAINLOOP [5] Bad PDU type: ~S"
+ pdutype))))
+
+ ;; Inconsistent length PDU
+ ;; Abort-Source = 2: UL Service-Provider-initiated
+ ;; Abort-Diagnostic = 1: Unrecognized/Invalid PDU
+ (t (setq *args* '(Abort-Source 2 Abort-Diagnostic 1)
+ *event* 'event-15)
+ (format t "~%DUL-MAINLOOP [6] ~A~%"
+ (setq *status-message*
+ "Received PDU with bad length."))
+ (report-error env tcp-buffer "Bad PDU length: ~S ~S"
+ input-cont pdu-end)))))))
+
+ ;; Now run the DUL protocol state machine.
+ (let ((actions (get *state* *event*))
+ (action-fcn) (next-state))
+
+ (unless (consp actions)
+ (mishap env nil "DUL-MAINLOOP [7] No entry for event ~S, state ~S"
+ *event* *state*))
+
+ (setq action-fcn (first actions)
+ next-state (second actions))
+
+ (when (>= log-level 2)
+ (format t "~%Event ~A: ~A.~% Action ~A: ~A.~% Next-state ~A: ~A.~%"
+ *event*
+ (get *event* 'documentation)
+ (or action-fcn "None")
+ (or (get action-fcn 'excl::%fun-documentation) "Loop exit")
+ (or next-state "None")
+ (cond (next-state (get next-state 'documentation))
+ (t "Leave DUL main loop"))))
+
+ (setq *event* nil)
+ ;; Must reset to NIL so it can be tested [and found to be NIL] on next
+ ;; cycle UNLESS some action function sets it to a non-NIL value.
+
+ (when action-fcn
+ ;; Null ACTION-FCN happens only when NEXT-STATE is also NIL
+ ;; and immanent action is termination of DUL-MAINLOOP.
+ (let ((new-env (funcall action-fcn env tcp-buffer tcp-strm)))
+ ;; If updated environment is passed back from command parser
+ ;; embedded in action function, update ENV. Otherwise [NIL is
+ ;; returned if no update] do NOT bash ENV.
+ (when (consp new-env)
+ (setq env new-env))))
+
+ (when (>= log-level 3)
+ (format t "~%Leave DUL-MAINLOOP (~A)~%" *mode*))
+
+ ;; Non-null next state -> go to it.
+ ;; First return value: ENV, to continue with next iteration.
+ ;; NULL next state -> done with this connection.
+ ;; Return value: :Return -> signal for caller to return
+ ;; or Environment if continuing.
+ (cond (next-state
+ (setq *state* next-state)
+ env)
+ (t :Return))))
+
+;;;=============================================================
+
+(defun parse-pdu (pdutype-alist env tcp-buffer head tail
+ &aux (pducode 0) pdutype val-1 (val-2 0) (val-3 nil))
+
+ ;; VAL-1 always set; VAL-2 and VAL-3 have default values.
+
+ "Success Returns: PDU-Type Input-Stream-Continuation-Pointer Environment.
+Failure Returns: :Fail Zero NIL."
+
+ (declare (type list pdutype-alist env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type symbol val-1)
+ (type fixnum head tail pducode val-2))
+
+ (when (>= (the fixnum *log-level*) 4)
+ (when (> head 0)
+ (dump-bytestream "Shifted Unread Bytes" tcp-buffer 0 head))
+ (dump-bytestream "Incoming PDU" tcp-buffer head tail))
+
+ (setq pducode (aref tcp-buffer head) ;First byte [at HEAD] is PDU type code.
+ pdutype (assoc pducode pdutype-alist :test #'=))
+
+ (cond ((consp pdutype)
+ (setq pdutype (cdr pdutype))
+ ;; Each PDUTYPE value a PDU-naming symbol which has a :Parser-Rule
+ ;; property which is the rule for parsing that PDU type.
+ (multiple-value-bind (input-cont new-env)
+ (parse-group (get pdutype :Parser-Rule)
+ env tcp-buffer (the fixnum (+ head 6)) tail)
+ ;; PDU type keyword, PDU code byte, don't-care byte, and
+ ;; PDU-Length fields have already been elided by rule compiler.
+ ;; Skip first 6 input bytes already parsed procedurally.
+ (declare (type fixnum input-cont))
+ ;; PARSE-GROUP returns :Fail [as second value] if parse fails,
+ ;; indicating an improperly formatted PDU was received or that
+ ;; parse rules contain errors. If parse succeeds, assign all
+ ;; return values here. If not, return :Fail.
+ (cond ((eq new-env :Fail)
+ (setq val-1 :Fail))
+ (t (setq val-1 pdutype val-2 input-cont val-3 new-env)))))
+
+ (t (setq val-1 :Fail)))
+
+ ;; Return values -- First: Symbol naming PDU or :Fail.
+ ;; Second: Continuation pointer in input buffer.
+ ;; Should point to byte just after PDU end.
+ ;; Third: NIL or environment alist.
+ (values val-1 val-2 val-3))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/object-generator.cl b/dicom/src/object-generator.cl
new file mode 100644
index 0000000..c4ae46d
--- /dev/null
+++ b/dicom/src/object-generator.cl
@@ -0,0 +1,199 @@
+;;;
+;;; object-generator
+;;;
+;;; Generator for DICOM Objects.
+;;; Contains functions used in Client only.
+;;;
+;;; 27-Dec-2000 BobGian change args to GENERATE-OBJECT - globals supplied
+;;; locally rather than passed as parameters.
+;;; Improve logging of lists/strings and object descriptors.
+;;; 16-Apr-2002 BobGian MISHAP called in GENERATE-OBJECT prints
+;;; list-structure representation of output generated so far.
+;;; 16-Apr-2002 BobGian convert GENERATE-OBJECT to return list structure
+;;; which is passed back to SEND-PDU for fragmentation [if needed]
+;;; and packaging into TCP-Buffer for transmission.
+;;; 19-Jun-2002 BobGian float->string conversions round to one digit after
+;;; decimal place.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 21-Nov-2003 Bobgian: Encoding variable-length strings with fixed min/max
+;;; lengths - string padded to min or truncated to max length rather than
+;;; invoking error call (MISHAP).
+;;; 27-Apr-2004 BobGian: Rounding of float values [was to 2 decimal places,
+;;; to avoid Elekta rounding problem] changed to 4 decimal places, to allow
+;;; greater accuracy in dose values in Gray [2-decimal-place conversion was
+;;; causing inconsistent rounding of dose for Dose-Monitoring points].
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+(defun generate-object (object env output-itemlist &aux object-start)
+
+ (declare (type list object output-itemlist object-start))
+
+ (do ((groupnum 0) (elemnum 0) (elemdata) (itemlen 0)
+ (VR-symbol) (VR-descriptor) (datatype) (string-padding)
+ (lisptype) (data-item) (data-values)
+ (g/e-alist *group/elemname-alist*)
+ (datatype-alist *datatype-alist*)
+ (input-itemlist object (cdr input-itemlist))
+ (tag object)) ;Binding for declaration only.
+ ((null input-itemlist)
+ output-itemlist)
+
+ (declare (type symbol VR-symbol string-padding)
+ (type list input-itemlist g/e-alist datatype-alist data-values
+ elemdata VR-descriptor datatype)
+ (type cons tag)
+ (type fixnum groupnum elemnum itemlen))
+
+ (setq data-item (car input-itemlist)
+ tag (car data-item)
+ data-values (cdr data-item)
+ groupnum (car tag)
+ elemnum (cdr tag))
+
+ (cond ((oddp groupnum)
+ (mishap env output-itemlist "GENERATE-OBJECT [1] Private group: ~S"
+ data-item))
+
+ ((consp (setq elemdata (assoc tag g/e-alist :test #'equal)))
+ ;; Item/Sequence delimiters handled here.
+ (setq VR-symbol (second elemdata)))
+
+ (t (mishap env output-itemlist
+ "GENERATE-OBJECT [2] Missing data definition: ~S"
+ data-item)))
+
+ (unless (consp (setq VR-descriptor
+ (assoc VR-symbol datatype-alist :test #'eq)))
+ ;; Missing data type definition in Data Dictionary.
+ (mishap env output-itemlist "GENERATE-OBJECT [3] Bad type: ~S"
+ data-item))
+
+ (push (list 'fixnum 2 :Little-Endian groupnum) output-itemlist)
+ (push (list 'fixnum 2 :Little-Endian elemnum) output-itemlist)
+ ;; Save starting index of the object so Value-Length slot can be
+ ;; backpatched after representation of object is generated. Length value
+ ;; is always encoded [in default Transfer Syntax] as a 4-byte Little-Endian
+ ;; fixnum. It is stored 4 bytes before Object itself.
+ ;; This is a token representing the length field whose value will be
+ ;; filled in later by measuring the length of the object representation
+ ;; back to [but not including] this length field.
+ (push (list 'fixnum 4 :Little-Endian nil) output-itemlist)
+ ;; OBJECT-START servers as pointer to start of object for length
+ ;; computation as well as pointer to token just pushed above which
+ ;; is the token to be filled in with length value later.
+ (setq object-start output-itemlist)
+
+ (cond
+ ((cddr (the cons VR-descriptor)) ;List-Length is at least 3
+ (setq string-padding (fourth VR-descriptor)
+ datatype (third VR-descriptor)
+ lisptype (first datatype))
+
+ (cond
+ ((eq lisptype 'fixnum) ;Could be single fixnum or list of them
+ (setq itemlen (second datatype))
+ (dolist (itemval data-values)
+ (unless (typep itemval 'fixnum)
+ (mishap env output-itemlist "GENERATE-OBJECT [4] Bad value: ~S"
+ data-item))
+ (unless (or (= itemlen 2)
+ (= itemlen 4))
+ (mishap env output-itemlist "GENERATE-OBJECT [5] Bad length: ~S"
+ data-item))
+ (push (list 'fixnum itemlen :Little-Endian itemval)
+ output-itemlist)))
+
+ ((eq lisptype 'string) ;Could be single string or list of them
+
+ (do ((items data-values (cdr items))
+ (strlen-low (second datatype))
+ (strlen-high (or (third datatype) (second datatype)))
+ (itemval) (totlen 0))
+ ((null items)
+ ;; After constructing the entire string [concatenation of all
+ ;; components, if more than one] pad the composite string if
+ ;; needed. Spec requires all slots in C-Store command and data
+ ;; PDVs to be of even length.
+ (cond ((evenp totlen))
+ ((eq string-padding :Null-Pad)
+ (push 0 output-itemlist))
+ (t (push #.(char-code #\Space) output-itemlist))))
+ (declare (type list items)
+ (type fixnum totlen strlen-low strlen-high))
+ (setq itemval (car items))
+ ;; "String" items may be presented as other datatypes,
+ ;; with generator expected to convert them to appropriate string.
+ (cond
+ ((typep itemval 'simple-base-string)) ;Already string.
+ ((typep itemval 'fixnum) ;Integer -> string.
+ (setq itemval (format nil "~D" itemval)))
+ ((typep itemval 'single-float) ;Float -> string.
+ ;; Round float->string conversions to four digits after decimal.
+ ;; Needed due to Elekta rounding problem.
+ (setq itemval (format nil "~,4F" itemval)))
+ (t (mishap env output-itemlist
+ "GENERATE-OBJECT [6] Bad string: ~S" data-item)))
+ ;; After conversion to string, we can check component lengths.
+ ;; ITEMLEN is len of each component, not of entire composite str.
+ (setq itemlen (length (the simple-base-string itemval)))
+ (cond ((> itemlen strlen-high)
+ (setq itemval (subseq itemval 0 strlen-high))
+ (setq itemlen strlen-high))
+ ((< itemlen strlen-low)
+ (setq itemval (concatenate
+ 'string
+ itemval
+ (make-string
+ (the fixnum (- strlen-low itemlen))
+ :initial-element #\Space)))
+ (setq itemlen strlen-low)))
+ (setq totlen (the fixnum (+ totlen itemlen)))
+ ;; Non-padded components had better already be even length.
+ (when (eq string-padding :No-Pad)
+ (unless (evenp itemlen)
+ (mishap env output-itemlist
+ "GENERATE-OBJECT [7] Bad len/pad: ~S" data-item)))
+ (push (list 'string itemlen :No-Pad itemval) output-itemlist)
+ (when (cdr items)
+ ;; If value multiplicity > 1, separate strings by #\\ delimiter.
+ (push #.(char-code #\\) output-itemlist)
+ (setq totlen (the fixnum (1+ totlen))))))
+
+ ;; Missing implementation of data type defined in Data Dictionary.
+ (t (mishap env output-itemlist
+ "GENERATE-OBJECT [8] Non-implemented datatype: ~S"
+ data-item))))
+
+ ;; Sequence markers initiate generation of contained sub-objects.
+ ;; Sequences are represented with Implicit VR = SQ of items, each an
+ ;; item of explicit length [in Implicit VR default transfer syntax].
+ ((eq VR-symbol 'SQ)
+ (dolist (itemval data-values)
+ ;;Tag for Item in Sequence.
+ (push (list 'fixnum 2 :Little-Endian #xFFFE) output-itemlist)
+ (push (list 'fixnum 2 :Little-Endian #xE000) output-itemlist)
+ ;;Item Length field to be backpatched.
+ (push (list 'fixnum 4 :Little-Endian nil) output-itemlist)
+ ;;Save length-field token for later backpatching.
+ (let ((item-start output-itemlist))
+ (declare (type list item-start))
+ (setq output-itemlist (generate-object itemval env output-itemlist))
+ ;; Backpatch deferred item length field.
+ (setf (fourth (car item-start))
+ (object-length output-itemlist item-start)))))
+
+ ;; Unrecognized situation.
+ (t (mishap env output-itemlist
+ "GENERATE-OBJECT [9] Unrecognized object: ~S" data-item)))
+
+ ;; Backpatch deferred Value-Length slot for entire object [or sub-object,
+ ;; if this is a recursive call to generate a component in a sequence].
+ (setf (fourth (car object-start))
+ (object-length output-itemlist object-start))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/object-parser.cl b/dicom/src/object-parser.cl
new file mode 100644
index 0000000..9226c90
--- /dev/null
+++ b/dicom/src/object-parser.cl
@@ -0,0 +1,917 @@
+;;;
+;;; object-parser
+;;;
+;;; Parser for DICOM Objects.
+;;; Contains functions used in Server only.
+;;;
+;;; 27-Dec-2000 BobGian add Group-name to Element-name logging printout.
+;;; Improve logging of lists/strings and object descriptors.
+;;; 23-Apr-2001 BobGian update PDU de-fragmentation to work when multiple
+;;; PDUs can be read into TCP buffer in single iteration.
+;;; 09-May-2001 BobGian update PARSE-OBJECT to parse any object, not just
+;;; a PDV containing images. Extension is to handle RTPlans for now.
+;;; 30-Jul-2001 BobGian improve formatting of data sent to log file.
+;;; 16-Mar-2002 BobGian remove overflow-byte-shifting kludge.
+;;; 15-Apr-2002 BobGian remove SOP class (element 0) from continuation.
+;;; PARSE-OBJECT will now parse any object. Caller must check SOP classes.
+;;; 02-May-2002 Bobgian fix PARSE-OBJECT: Assoc tags for objects of type
+;;; SEQUENCE and ITEM-IN-SEQUENCE were not being pushed onto the alist
+;;; representing slot value.
+;;; 02-May-2002 Bobgian fix GET-TEXT to preserve all characters in string
+;;; and to strip non-significant leading/trailing spaces depending on
+;;; datatype. If stripping, do so on each string when multiplicity > 1.
+;;; Also strings of type ST, LT must have multiplicity 1, and character
+;;; #\\ is not used as delimiter and thus may be contained in string.
+;;; 03-May-2002 BobGian push onto output alist the SQ [Sequence] token
+;;; but not the IT [Item in Sequence] or delimiter tokens ITDL or SQDL.
+;;; 04-May-2002 BobGian DICOM spec allows fragmentation border anywhere
+;;; within objects or inside Group/Element/Length fields, subject only
+;;; to being on an even byte boundary. Implemented byte-shifting scheme
+;;; to down-shift interrupted header or object bytes to low region of TCP
+;;; buffer [portion already parsed] and passing length of shifted bytes back
+;;; via continuation so READ of next fragment offsets over shifted bytes.
+;;; This also requires left-over bytes from previous instantiation to be
+;;; up-shifted on next instantiation to region continguous with continuation
+;;; of the interrupted object, overlying no-longer-needed bytes from
+;;; PDU and PDV header.
+;;; 04-May-2002 BobGian add TCP buffer overrun check to PARSE-OBJECT.
+;;; 26-Jun-2002 BobGian PARSE-OBJECT does hex dump of tag/length/data-field
+;;; in case of data definition missing in dictionary.
+;;; 18-Aug-2002 BobGian temp fix to object parser loosening standard to accept
+;;; null-padding on nominally space-padded strings (as sent by possibly
+;;; non-conformant clients). Marked ";Null-Padding Fix here." in code.
+;;; 17-Sep-2002 BobGian DICOM-ALIST passed to REPORT-ERROR and MISHAP for dump.
+;;; Done in functions PARSE-OBJECT, GET-FIXNUM-LE-VM, GET-FIXNUM-LE, and
+;;; GET-TEXT (passed to last three for error-reporting purposes).
+;;; 24-Sep-2002 BobGian:
+;;; Remove 3rd arg (DICOM-ALIST) to REPORT-ERROR and MISHAP and passage
+;;; to them via intermediate functions. Same functionality is now obtainable
+;;; via special variable set when data is available.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 21-Dec-2003 BobGian: Add arg to PARSE-OBJECT which passes value of global
+;;; variable *IGNORABLE-GROUPS-LIST*. Value is a [possibly-empty] list of
+;;; CONS pairs, each representing a range of group numbers to ignore. CAR
+;;; of each is lower limit [inclusive], and CDR is upper limit [exclusive].
+;;; Any object slots containing values with group numbers in such a range
+;;; will have that fact logged but will otherwise be ignored [precisely,
+;;; will be treated exactly as a PRIVATE ELEMENT - will be decoded as an
+;;; uninterpreted string by object parser and dumped when logging level is
+;;; sufficiently high but otherwise will be skipped].
+;;; 03-Nov-2004 BobGian flushed symbol naming group from *GROUPNAME-ALIST*
+;;; while preserving group tag and string name. Symbol was used only
+;;; in error messages.
+;;; 1-Dec-2008 I. Kalet new CT scanner sends floating-poinit data,
+;;; not needed but was treated as a mishap. Now just ignored. See
+;;; call to mishap [22] below in parse-object
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+(defun parse-object (env tcp-buffer head tail last-frag? continuation
+ ignorable-groups-list &aux (log-level *log-level*)
+ (virt-idx head) (context-list '()) (output-stack '())
+ (dicom-alist '()) (conttype :New) (pixel-padder 0))
+
+ ;; HEAD [and PDV-IDX, which increments starting from HEAD] is index in
+ ;; current TCP buffer of start of an object's Group-Number slot. 8 bytes
+ ;; later object itself starts. If HEAD shifts due to fragmentation-fixup
+ ;; [unread bytes from previous instantiation], the moved unread bytes to
+ ;; which HEAD is reset will always start with an object's Group-Number slot.
+ ;;
+ ;; VIRT-IDX is index of current byte in de-fragmented virtual PDV dataset,
+ ;; considered to be concatenation of all P-Data-TF PDUs that make up the
+ ;; data, and as referenced to zero at beginning of PDU in first fragment.
+ ;; First PDV in PDU starts 12 bytes into P-Data-TF PDU -- that is value of
+ ;; HEAD when PARSE-OBJECT is first called on a new PDU. If called on
+ ;; multiple PDVs in same PDU, later values of HEAD will be larger.
+ ;;
+ ;; If unread-bytes were down-shifted on the prior instantiation and moved
+ ;; to contiguity with rest of object in current fragment, VIRT-IDX is NOT
+ ;; changed - only HEAD [the local TCP buffer index] is.
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type (or null (simple-array t (10))) continuation)
+ (type list ignorable-groups-list context-list dicom-alist
+ output-stack env)
+ (type (integer #x0000 #xFFFF) pixel-padder)
+ (type fixnum head tail virt-idx log-level))
+
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate 'string
+ "~%PARSE-OBJECT [1] Entering, PDV-Head:"
+ " ~D, PDV-Tail: ~D, ~A fragment.~%")
+ head tail (if last-frag? "Last" "Internal")))
+
+ (unless (< tail #.TCP-Bufsize)
+ (mishap env tcp-buffer "PARSE-OBJECT [2] Buffer overrun - TAIL: ~D." tail))
+
+ (when (arrayp continuation)
+ (let ((unread-byte-len (aref (the (simple-array t (10)) continuation) 0)))
+ (declare (type fixnum unread-byte-len))
+ (when (> unread-byte-len 0)
+ ;; Unread bytes from the previous instantiation of this function were
+ ;; moved to the beginning of the TCP buffer. Next TCP READ started
+ ;; after them, placing bytes that have already been parsed as PDU
+ ;; header and initial contents of current PDV. Now move "left-over"
+ ;; bytes up to be contiguous with rest of bytes of the data portion
+ ;; of current PDV, reset the HEAD pointer to beginning of moved bytes,
+ ;; and continue parsing where we left off in previous instantiation.
+ ;; This hack is necessary to handle fragmented messags. Note that the
+ ;; bytes being overwritten in this move [PDU/PDV header, etc] have
+ ;; already been parsed and so are no longer needed. Bytes shifted
+ ;; up -> move in descending order.
+ (when (>= log-level 3)
+ (format
+ t "~%PARSE-OBJECT [3] Shift ~D unread bytes 0 -> ~D to ~D -> ~D.~%"
+ unread-byte-len unread-byte-len
+ (the fixnum (- head unread-byte-len)) head))
+ (do ((in-ptr (the fixnum (1- head)) (the fixnum (1- in-ptr)))
+ (out-ptr (the fixnum (1- unread-byte-len))
+ (the fixnum (1- out-ptr))))
+ ((< out-ptr 0)
+ (setq head (the fixnum (1+ in-ptr))))
+ (declare (type fixnum in-ptr out-ptr))
+ (setf (aref tcp-buffer in-ptr) (aref tcp-buffer out-ptr)))))
+ (setq dicom-alist (aref (the (simple-array t (10)) continuation) 1))
+ (setq output-stack (aref (the (simple-array t (10)) continuation) 2))
+ (setq context-list (aref (the (simple-array t (10)) continuation) 3))
+ (setq virt-idx (aref (the (simple-array t (10)) continuation) 4))
+ (setq conttype (aref (the (simple-array t (10)) continuation) 5))
+ (setq pixel-padder (aref (the (simple-array t (10)) continuation) 6))
+ (when (>= log-level 3)
+ (format t "~%PARSE-OBJECT [4] Continuation type ~A at ~D/~D.~%"
+ conttype head virt-idx)))
+
+ (do ((pdv-idx head) ;Start of GroupNum field
+ (val-idx 0) ;Start of object value field [= PDV-IDX + 8]
+ (groupnum 0) (elemnum 0) (itemlen) (elemdata) (VR-symbol)
+ (VR-descriptor) (datatype) (string-padding) (lisptype) (elemname "")
+ (gn-alist *groupname-alist*) (groupdata) (groupname "")
+ (g/e-alist *group/elemname-alist*) (datatype-alist *datatype-alist*)
+ (itemvalue nil nil))
+ ((>= pdv-idx tail)
+ (unless (= pdv-idx tail)
+ (mishap env tcp-buffer "PARSE-OBJECT [5] Index overrun at ~D/~D."
+ pdv-idx virt-idx))
+ (cond
+ (last-frag?
+ (when (or (consp output-stack)
+ (consp context-list))
+ (mishap env tcp-buffer "PARSE-OBJECT [6] Bad context at ~D/~D."
+ pdv-idx virt-idx))
+ (when (>= log-level 3)
+ (format t "~%PARSE-OBJECT [7] Done at ~D/~D.~%" pdv-idx virt-idx))
+ (setq *parser-state* nil)
+ ;; Return Alist representing parsed object.
+ ;; Non-NIL value signals that parsing has completed.
+ (nreverse dicom-alist))
+ (t (setq *parser-state*
+ (vector 0 dicom-alist output-stack context-list virt-idx
+ :New pixel-padder nil 0 0))
+ (when (>= log-level 3)
+ (format t "~%PARSE-OBJECT [8] EOB on object end at ~D/~D.~%"
+ pdv-idx virt-idx))
+ nil)))
+
+ (declare (type list groupdata gn-alist g/e-alist datatype-alist elemdata
+ VR-descriptor datatype)
+ (type simple-base-string groupname elemname)
+ (type symbol VR-symbol string-padding)
+ (type fixnum pdv-idx val-idx groupnum elemnum))
+
+ (when (eq conttype :Pixel-Array)
+ (do ((tcp-idx pdv-idx (the fixnum (+ tcp-idx 2)))
+ (pixel-array (aref (the (simple-array t (10)) continuation) 7))
+ (pix-idx (aref (the (simple-array t (10)) continuation) 8)
+ (the fixnum (+ pix-idx 2)))
+ (pixarray-len (aref (the (simple-array t (10)) continuation) 9))
+ (low-byte 0) (high-byte 0)
+ (pixel-padder-lo (logand #x00FF pixel-padder))
+ (pixel-padder-hi (ash pixel-padder -8)))
+ (( ))
+
+ (declare (type (integer #x00 #xFF) pixel-padder-lo pixel-padder-hi)
+ (type (simple-array (unsigned-byte 8) 1) pixel-array)
+ (type fixnum tcp-idx pix-idx pixarray-len low-byte high-byte))
+
+ (cond
+ ((= pix-idx pixarray-len)
+ ;; Check for scan done first, in case scan-done and reaching
+ ;; TCP buffer end both happen at same time. If so, we will
+ ;; handle end-of-buffer at start of next iteration.
+ (setq virt-idx
+ (the fixnum (+ virt-idx (the fixnum (- tcp-idx pdv-idx)))))
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [9] PixArray done "
+ "[~D bytes] at ~D/~D.~%")
+ pixarray-len tcp-idx virt-idx))
+ ;; Completed Pixel Array -- prepare to scan next object.
+ ;; Value multiplicity is explicitly one here.
+ (push (list (cons #x7FE0 #x0010) pixel-array) dicom-alist)
+ (setq pdv-idx tcp-idx conttype :New)
+ (go NEXT-CYCLE))
+ ((= tcp-idx tail)
+ (setq virt-idx
+ (the fixnum (+ virt-idx (the fixnum (- tcp-idx pdv-idx)))))
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [10] PixArray EOB "
+ "[~D of ~D bytes] at ~D/~D.~%")
+ pix-idx pixarray-len tcp-idx virt-idx))
+ ;; Encountered end of TCP buffer before completing Pixel Array.
+ (cond (last-frag?
+ ;; Byte count wrong -- last fragment should contain
+ ;; complete Pixel Array.
+ (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [11] PixArray buffer overrun."
+ "~% ~D bytes at ~D/~D.")
+ (the fixnum (- pixarray-len pix-idx))
+ tcp-idx virt-idx))
+ (t (setq *parser-state*
+ (vector 0 dicom-alist output-stack context-list
+ virt-idx :Pixel-Array pixel-padder
+ pixel-array pix-idx pixarray-len))
+ ;; Set continuation and return to await next fragment.
+ (return-from parse-object nil)))))
+
+ ;; Terms "low" and "high" refer to packet byte order or TCP buffer
+ ;; addressing order -- ie, network byte order [little endian] --
+ ;; which is same as fixnum byte significance but not necessarily the
+ ;; same as machine byte order [same on Little-Endian machine only].
+ (setq low-byte (aref tcp-buffer tcp-idx)
+ high-byte (aref tcp-buffer (the fixnum (1+ tcp-idx))))
+
+ ;; Detect Pixel-Padding-Value and convert to Zero.
+ (when (or (and (= low-byte pixel-padder-lo)
+ (= high-byte pixel-padder-hi))
+ ;; Fix to avoid pixel-value overflow.
+ ;; HIGH-BYTE >= 16 -> pixel value > 4095.
+ (>= high-byte 16))
+ (setq high-byte #x00 low-byte #x00))
+
+ ;; Possible conversion Network (Little) to Machine Endianism.
+ #+little-endian ;No need for byte-swapping
+ (setf (aref pixel-array pix-idx) low-byte)
+ #+little-endian
+ (setf (aref pixel-array (the fixnum (1+ pix-idx))) high-byte)
+ #+big-endian ;Must do byte-swapping
+ (setf (aref pixel-array pix-idx) high-byte)
+ #+big-endian
+ (setf (aref pixel-array (the fixnum (1+ pix-idx))) low-byte)))
+
+ (when (> (the fixnum (+ pdv-idx 8)) tail)
+ ;; TCP buffer does not contain entire Group/Element Number and Length
+ ;; fields, which are necessary for parsing the next object. Shift
+ ;; remainder of bytes, set continuation, and return to await next
+ ;; fragment. Bytes shifted down -> move in ascending order.
+ (do ((in-ptr 0 (the fixnum (1+ in-ptr)))
+ (out-ptr pdv-idx (the fixnum (1+ out-ptr))))
+ ((= out-ptr tail)
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [12] Buffer overrun"
+ " before G/E decode at ~D/~D.~%"
+ "Shifting ~D unread bytes ~D -> ~D to 0 -> ~D.~%")
+ pdv-idx virt-idx in-ptr pdv-idx tail in-ptr))
+ (setq *parser-state*
+ (vector in-ptr dicom-alist output-stack context-list virt-idx
+ :New pixel-padder nil 0 0)))
+ (declare (type fixnum in-ptr out-ptr))
+ (setf (aref tcp-buffer in-ptr) (aref tcp-buffer out-ptr)))
+ (return-from parse-object nil))
+
+ (setq groupnum (get-fixnum-LE tcp-buffer pdv-idx 2)
+ elemnum (get-fixnum-LE tcp-buffer (the fixnum (+ pdv-idx 2)) 2)
+ ;; ITEMLEN is either a FIXNUM [required by spec to be EVEN]
+ ;; or the symbol :Undefined for indeterminate-length sequences
+ ;; or objects of value-representation OB or OW.
+ itemlen (get-fixnum-LE tcp-buffer (the fixnum (+ pdv-idx 4)) 4))
+
+ (cond
+ ((oddp groupnum)
+ (setq groupname "*")
+ (cond ((= elemnum #x0000)
+ (setq VR-symbol 'UL elemname "Group Length"))
+ (t (setq VR-symbol 'PE elemname "Private Element"))))
+
+ ((and (consp (setq groupdata (assoc groupnum gn-alist :test #'=)))
+ (consp (setq elemdata (assoc (cons groupnum elemnum)
+ g/e-alist :test #'equal))))
+ ;; Item/Sequence delimiters handled here.
+ (setq groupname (second groupdata)
+ VR-symbol (second elemdata)
+ elemname (third elemdata)))
+
+ ((dolist (group ignorable-groups-list nil)
+ (when (and (<= (the fixnum (car group)) groupnum)
+ (< groupnum (the fixnum (cdr group))))
+ (return t)))
+ (setq groupname "*")
+ (cond ((= elemnum #x0000)
+ (setq VR-symbol 'UL elemname "Group Length"))
+ (t (setq VR-symbol 'IE elemname "Ignorable Element")))
+ (format t "~%PARSE-OBJECT [13] Ignorable slot: (~4,'0X:~4,'0X)~%"
+ groupnum elemnum))
+
+ (t (setq groupname "*")
+ (setq VR-symbol 'MD elemname "Missing Definition")
+ ;; Missing Group/Element definition in Data Dictionary. Log
+ ;; message but otherwise situation is harmless, unless value
+ ;; of that slot is needed later, in which case accessor will
+ ;; call MISHAP. This is a programming error rather than a
+ ;; run-time error.
+ (report-error env nil
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [14] Missing data definition."
+ "~% 8+~S bytes at ~D/~D~%"
+ " Group: ~4,'0X, Element: ~4,'0X")
+ itemlen pdv-idx virt-idx groupnum elemnum)
+ (dump-bytestream "Object in TCP buffer"
+ tcp-buffer pdv-idx
+ (the fixnum (+ pdv-idx itemlen 8)))))
+
+ (cond
+ ((null (setq VR-descriptor (assoc VR-symbol datatype-alist :test #'eq)))
+ ;; Missing data type definition in Data Dictionary.
+ (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [15] Bad type: ~S~%"
+ " 8+~S bytes at ~D/~D~%"
+ " Group: ~4,'0X, Element: ~4,'0X, Name: ~S ~S")
+ VR-symbol itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname))
+
+ ((cddr (the cons VR-descriptor)) ;List-Length is at least 3
+
+ (when (and (eq itemlen :Undefined) ;Legal, but should be rare
+ (or (eq VR-symbol 'OB) ;Lisptype: (unsigned-byte 8)
+ (eq VR-symbol 'OW))) ;Lisptype: (unsigned-byte 16)
+ (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [16] Indeterminate-length OB or OW data.~%"
+ " This case is legal but not implemented in PDS.~%"
+ " Object at ~D/~D~% Group: ~4,'0X,"
+ " Element: ~4,'0X, Name: ~S ~S~% ~S")
+ pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor))
+
+ (unless (and (typep itemlen 'fixnum)
+ (evenp (the fixnum itemlen)))
+ ;; Bad value length in Element Length slot.
+ ;; DICOM spec requires ITEMLEN to be an EVEN FIXNUM for explicit
+ ;; length objects. Can be :Undefined only for SQ, OB, OW data.
+ (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [17] Bad itemlen: ~S~%"
+ " Object at ~D/~D~% Group: ~4,'0X,"
+ " Element: ~4,'0X, Name: ~S ~S~% ~S")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor))
+
+ (setq string-padding (fourth VR-descriptor)
+ datatype (third VR-descriptor)
+ lisptype (first datatype)
+ val-idx (the fixnum (+ pdv-idx 8)))
+
+ (cond
+ ;; First encounter with Pixel Array -- allocate it and start copy.
+ ((and (= groupnum #x7FE0)
+ (= elemnum #x0010))
+
+ (when (>= log-level 2)
+ (format
+ t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [18] 8+~S bytes at ~D/~D~% Group: ~4,'0X, "
+ "Element: ~4,'0X, Name: ~S ~S~% ~S: Pixel-Array~%")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor))
+
+ (do ((tcp-idx val-idx (the fixnum (+ tcp-idx 2)))
+ (pix-idx 0 (the fixnum (+ pix-idx 2)))
+ (pixel-array
+ (make-array (the fixnum itemlen)
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (low-byte 0) (high-byte 0)
+ (pixel-padder-lo (logand #x00FF pixel-padder))
+ (pixel-padder-hi (ash pixel-padder -8)))
+ (( ))
+
+ (declare (type fixnum tcp-idx pix-idx low-byte high-byte)
+ (type (integer #x00 #xFF) pixel-padder-lo pixel-padder-hi)
+ (type (simple-array (unsigned-byte 8) 1) pixel-array))
+
+ (cond
+ ((= pix-idx (the fixnum itemlen))
+ ;; Check for scan-done first, in case scan-done and reaching
+ ;; end-of-buffer condition both happen at same time. If so, we
+ ;; handle end-of-buffer condition at start of next iteration.
+ (setq virt-idx
+ (the fixnum
+ (+ virt-idx (the fixnum (- tcp-idx pdv-idx)))))
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [19] PixArray done "
+ "[~D bytes] at ~D/~D.~%")
+ itemlen tcp-idx virt-idx))
+ ;; Value multiplicity is explicitly one here.
+ (push (list (cons #x7FE0 #x0010) pixel-array) dicom-alist)
+ ;; Completed Pixel Array -- prepare to scan next object.
+ (setq pdv-idx tcp-idx conttype :New)
+ (go NEXT-CYCLE))
+
+ ((= tcp-idx tail)
+ ;; Encountered end of TCP buffer before completing
+ ;; Pixel Array -- set continuation and return.
+ (setq virt-idx
+ (the fixnum
+ (+ virt-idx (the fixnum (- tcp-idx pdv-idx)))))
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [20] PixArray EOB "
+ "[~D of ~D bytes] at ~D/~D.~%")
+ pix-idx itemlen tcp-idx virt-idx))
+ (setq *parser-state*
+ (vector 0 dicom-alist output-stack context-list virt-idx
+ :Pixel-Array pixel-padder pixel-array pix-idx
+ itemlen))
+ (return-from parse-object nil)))
+
+ ;; Terms "low" and "high" refer to packet byte order or TCP buffer
+ ;; which is same as fixnum byte significance but not necessarily
+ ;; the same as machine byte order [same on Little-Endian machine].
+ (setq low-byte (aref tcp-buffer tcp-idx)
+ high-byte (aref tcp-buffer (the fixnum (1+ tcp-idx))))
+
+ ;; Detect Pixel-Padding-Value and convert to Zero.
+ (when (or (and (= low-byte pixel-padder-lo)
+ (= high-byte pixel-padder-hi))
+ ;; Fix to avoid pixel-value overflow.
+ ;; HIGH-BYTE >= 16 -> pixel value > 4095.
+ (>= high-byte 16))
+ (setq high-byte #x00 low-byte #x00))
+
+ ;; Possible conversion Network (Little) to Machine Endianism.
+ #+little-endian ;No need for byte-swapping
+ (setf (aref pixel-array pix-idx) low-byte)
+ #+little-endian
+ (setf (aref pixel-array (the fixnum (1+ pix-idx))) high-byte)
+ #+big-endian ;Must do byte-swapping
+ (setf (aref pixel-array pix-idx) high-byte)
+ #+big-endian
+ (setf (aref pixel-array (the fixnum (1+ pix-idx))) low-byte)))
+
+ ;; All other slot types -- check whether TCP buffer contains entire
+ ;; object. If not, set continuation and return for next fragment.
+ ;; Bytes shifted down -> move in ascending order.
+ ;; Shift starting with the Group/Element tag so that on next
+ ;; instantiation parsing will start synchronously with object's
+ ;; header rather than with random bits of object itself.
+ ((> (the fixnum (+ val-idx (the fixnum itemlen))) tail)
+ (do ((in-ptr 0 (the fixnum (1+ in-ptr)))
+ (out-ptr pdv-idx (the fixnum (1+ out-ptr))))
+ ((= out-ptr tail)
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [21] Object overrun at ~D/~D.~%"
+ "Shifting ~D unread bytes ~D -> ~D to 0 -> ~D.~%")
+ pdv-idx virt-idx in-ptr pdv-idx tail in-ptr))
+ (setq *parser-state*
+ (vector in-ptr dicom-alist output-stack context-list
+ virt-idx :New pixel-padder nil 0 0)))
+ (declare (type fixnum in-ptr out-ptr))
+ (setf (aref tcp-buffer in-ptr) (aref tcp-buffer out-ptr)))
+ (return-from parse-object nil)))
+
+ ;; Now process all slot type objects other than Pixel Array.
+ ;; All objects are known to be contained in full in TCP buffer.
+ ;; Private elements are logged but not passed through, treated as
+ ;; datatype PE [ie, arbitrary uninterpreted Long Text strings].
+ (cond
+ ((eq lisptype 'fixnum) ;ITEMVALUE is a list of one or more fixnums
+ (setq itemvalue (get-fixnum-LE-VM
+ tcp-buffer val-idx (second datatype) itemlen))
+ ;; Don't transmit Group Length fields.
+ (unless (= elemnum #x0000)
+ ;; Remember "Pixel Padding Value" for later use.
+ (when (and (= groupnum #x0028)
+ (= elemnum #x0120))
+ (setq pixel-padder (car itemvalue)))
+ ;; Value multiplicity is arbitrary here.
+ ;; ITEMVALUE is a list of fixnums.
+ (push (cons (cons groupnum elemnum) itemvalue) dicom-alist)))
+
+ ((or (eq lisptype 'single-float)
+ (eq lisptype 'double-float)) ;; ignore floats for now IK 1-Dec-08
+ )
+ #|
+ (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [22] Non-implemented flonum.~%"
+ " 8+~S bytes at ~D/~D~% Group: "
+ "~4,'0X, Element: ~4,'0X, Name: ~S ~S~% ~S")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor))
+ |#
+ ((eq VR-symbol 'PE)) ;Don't transmit Private Element
+ ((eq VR-symbol 'MD)) ;or Missing Definition fields.
+
+ ((eq lisptype 'string)
+ ;; ITEMVALUE is a list of zero or more strings [NIL for NO-VALUE].
+ (setq itemvalue (get-text tcp-buffer val-idx itemlen tail
+ string-padding VR-symbol))
+ ;; Value multiplicity is arbitrary here.
+ ;; ITEMVALUE is a list of strings.
+ (push (cons (cons groupnum elemnum) itemvalue) dicom-alist))
+
+ ;; Don't transmit Byte or Word strings, other than Pixel Data
+ ;; which is tranmitted specially by :Pixel-Array code above.
+ ;; These are the datatypes which are allowed to have :Undefined
+ ;; lengths [as value of ITEMLEN] other than type SQ.
+ ((eq VR-symbol 'OB)) ;Lisptype: (unsigned-byte 8)
+ ((eq VR-symbol 'OW)) ;Lisptype: (unsigned-byte 16)
+
+ ;; Missing implementation of data type defined in Data Dictionary.
+ (t (mishap env tcp-buffer
+ #.(concatenate 'string
+ "PARSE-OBJECT [23] Type not implemented.~%"
+ " 8+~S bytes at ~D/~D~%"
+ " Group: ~4,'0X, Element: ~4,'0X,"
+ " Name: ~S ~S~% ~S")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor)))
+
+ (when (>= log-level 2)
+ (format
+ t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [24] 8+~S bytes at ~D/~D~% Group: ~4,'0X, "
+ "Element: ~4,'0X, Name: ~S ~S~% ~S: ~S~%")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor
+ (cond ((eq lisptype 'fixnum)
+ itemvalue) ;List of one or more fixnums
+ ((eq lisptype 'string) ;Character strings
+ itemvalue) ;String list - length equals value multiplicity.
+ (t "[Unknown type]"))))
+
+ (let ((increment (the fixnum (+ 8 (the fixnum itemlen)))))
+ (declare (type fixnum increment))
+ (setq pdv-idx (the fixnum (+ pdv-idx increment)))
+ (setq virt-idx (the fixnum (+ virt-idx increment)))))
+
+ ;; Sequence and Item markers initiate parse of contained sub-objects
+ ;; but do not themselves constitute an "object" that must fit in buffer.
+ ;; They cause stacking and clearing of DICOM-ALIST so that it can
+ ;; accumulate the interior objects.
+ ;; ITEMLEN is allowed to be :Undefined from here to end.
+ ((or (eq VR-symbol 'IT)
+ (eq VR-symbol 'SQ))
+ (when (>= log-level 3)
+ (format t "~%PARSE-OBJECT [25] Open delimiter at ~D/~D: ~S~%"
+ pdv-idx virt-idx VR-symbol))
+ (push dicom-alist output-stack)
+ ;; Push the SQ [Sequence] token but not the IT [Item in Sequence]
+ ;; token or the delimiter tokens ITDL [Item Delimiter] or SQDL
+ ;; [Sequence Delimiter].
+ (setq dicom-alist (cond ((eq VR-symbol 'SQ)
+ (list (cons groupnum elemnum)))
+ (t '())))
+ (push (cons VR-symbol
+ (cond ((typep itemlen 'fixnum)
+ (the fixnum (+ (the fixnum (+ virt-idx 8))
+ (the fixnum itemlen))))
+ (t itemlen)))
+ context-list)
+ (setq pdv-idx (the fixnum (+ pdv-idx 8)))
+ (setq virt-idx (the fixnum (+ virt-idx 8))))
+
+ ;; Ditto for end-markers for Sequences or Items of :Undefined length.
+ ((or (eq VR-symbol 'ITDL)
+ (eq VR-symbol 'SQDL))
+ ;;
+ (when (>= log-level 3)
+ (format t "~%PARSE-OBJECT [26] Close delimiter at ~D/~D: ~S~%"
+ pdv-idx virt-idx VR-symbol))
+ (unless (and (typep itemlen 'fixnum)
+ (= (the fixnum itemlen) 0))
+ ;; Delimiters must contain value field length of zero.
+ (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [27] Bad delimiter field.~%"
+ " 8+~S bytes at ~D/~D~% Group: "
+ "~4,'0X, Element: ~4,'0X, Name: ~S ~S~% ~S")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor))
+
+ (unless (consp context-list)
+ ;; Context/delimiter asymmetry problem.
+ (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [28] Context asymmetry.~%"
+ " 8+~S bytes at ~D/~D~% Group: "
+ "~4,'0X, Element: ~4,'0X, Name: ~S ~S~% ~S")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor))
+
+ (let ((context (pop context-list)))
+ (declare (type cons context))
+ (let ((objtype (car context))
+ (objend (cdr context)))
+ (unless (and (or (and (eq objtype 'IT)
+ (eq VR-symbol 'ITDL))
+ (and (eq objtype 'SQ)
+ (eq VR-symbol 'SQDL)))
+ (eq objend :Undefined))
+ ;; Item/Sequence delimiters used only on :Undefined
+ ;; length sequences or items.
+ (mishap env tcp-buffer
+ #.(concatenate 'string
+ "PARSE-OBJECT [29] Bad delimiter.~%"
+ " 8+~S bytes at ~D/~D~%"
+ " Group: ~4,'0X, Element: ~4,'0X,"
+ " Name: ~S ~S~% ~S")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor))))
+
+ ;; End of composite-object -- DICOM-ALIST contains reversed list
+ ;; of the sub-objects. Insert that list [reversed to forward order]
+ ;; as the object of the sequence being accumulated.
+ (let ((itemdata (nreverse dicom-alist)))
+ (declare (type cons itemdata))
+ (setq dicom-alist (pop output-stack)) ;Restore state
+ (push itemdata dicom-alist)) ;Put composite object on list
+ (setq pdv-idx (the fixnum (+ pdv-idx 8)))
+ (setq virt-idx (the fixnum (+ virt-idx 8))))
+
+ ;; Unrecognized situation.
+ (t (mishap env tcp-buffer
+ #.(concatenate
+ 'string
+ "PARSE-OBJECT [30] Unrecognized situation.~%"
+ " 8+~S bytes at ~D/~D~% Group: "
+ "~4,'0X, Element: ~4,'0X, Name: ~S ~S~% ~S")
+ itemlen pdv-idx virt-idx groupnum elemnum
+ groupname elemname VR-descriptor)))
+
+ NEXT-CYCLE
+
+ (tagbody
+ ;; Must iterate end condition test because several nested structures
+ ;; (items/sequences) might be terminating at same index.
+ END-CONDITION
+ (when (consp context-list)
+ ;; Check for end of sequence or item of explicit length.
+
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [31] Composite-object end"
+ " check at ~D/~D.~%")
+ pdv-idx virt-idx))
+
+ (let ((context (car context-list)))
+ (declare (type cons context))
+ (let ((objend (cdr context)))
+ (when (and (typep objend 'fixnum)
+ (>= virt-idx (the fixnum objend)))
+ ;; Same end-of-sequence actions as when composite object
+ ;; is terminated by an explicit delimiter.
+ (let ((itemdata (nreverse dicom-alist)))
+ (declare (type cons itemdata))
+ (setq dicom-alist (pop output-stack)) ;Restore state
+ (push itemdata dicom-alist)) ;Put composite object on list
+
+ (when (>= log-level 3)
+ (format t
+ #.(concatenate
+ 'string
+ "~%PARSE-OBJECT [32] Composite object"
+ " end at ~D/~D: ~S~%")
+ pdv-idx virt-idx context))
+
+ (setq context-list (cdr context-list))
+ (go END-CONDITION))))))))
+
+;;;=============================================================
+;;; Utilities for Object Parsing.
+;;; Reads Little-Endian fixnums of Variable-Multiplicity from buffer.
+
+(defun get-fixnum-LE-VM (tcp-buffer idx fixnum-length field-length)
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum idx fixnum-length field-length))
+
+ (cond
+ ;; Value multiplicity greater than one -- return list of fixnums.
+ ((< fixnum-length field-length)
+ (do ((idx2 idx (the fixnum (+ idx2 fixnum-length)))
+ (limit (the fixnum (+ idx field-length)))
+ (accumulator '()))
+ ((>= idx2 limit)
+ (unless (= idx2 limit)
+ (mishap nil tcp-buffer
+ #.(concatenate
+ 'string
+ "GET-FIXNUM-LE-VM [1] Bad field/item lengths."
+ " Object in TCP-Buffer~% "
+ "at idx ~D (~D byte fixnum, ~D byte field).")
+ idx fixnum-length field-length))
+ (nreverse accumulator))
+ (declare (type list accumulator)
+ (type fixnum idx2 limit))
+ (push (get-fixnum-LE tcp-buffer idx2 fixnum-length) accumulator)))
+
+ ;; Invalid field-width/value-multiplicity combination.
+ ((> fixnum-length field-length)
+ (mishap nil tcp-buffer
+ #.(concatenate 'string
+ "GET-FIXNUM-LE-VM [2] Bad field/item lengths."
+ " Object in TCP-Buffer~% "
+ "at idx ~D (~D byte fixnum, ~D byte field).")
+ idx fixnum-length field-length))
+
+ ;; Value multiplicity = one -- return list of the single fixnum.
+ (t (list (get-fixnum-LE tcp-buffer idx fixnum-length)))))
+
+;;;-------------------------------------------------------------
+;;; Reads a single Little-Endian fixnum of fixed length from buffer;
+;;; ie, value multiplicity is ONE.
+
+(defun get-fixnum-LE (tcp-buffer idx fixnum-length &aux (byte-0 0)
+ (byte-1 0) (byte-2 0) (byte-3 0))
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type (integer #x00 #xFF) byte-0 byte-1 byte-2 byte-3)
+ (type fixnum idx fixnum-length))
+
+ (cond
+
+ #+ignore ;1-byte fixnums not used, but may be useful someday.
+ ((= fixnum-length 1)
+ (the (integer #x0000 #x00FF) (aref tcp-buffer idx)))
+
+ ((= fixnum-length 2)
+ (logior (the (integer #x0000 #xFF00)
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (1+ idx)))) 8))
+ (the (integer #x0000 #x00FF) (aref tcp-buffer idx))))
+
+ ;; Largest mask really should be #xFF000000, but using smaller value
+ ;; keeps it a POSITIVE FIXNUM, and no value will exceed 536870911.
+ ((= fixnum-length 4)
+ (setq byte-0 (aref tcp-buffer idx)
+ byte-1 (aref tcp-buffer (the fixnum (1+ idx)))
+ byte-2 (aref tcp-buffer (the fixnum (+ idx 2)))
+ byte-3 (aref tcp-buffer (the fixnum (+ idx 3))))
+ (cond ((and (= byte-0 #xFF)
+ (= byte-1 #xFF)
+ (= byte-2 #xFF)
+ (= byte-3 #xFF))
+ ;; This code used for undefined-length itemlists and sequences.
+ :Undefined)
+ ;; Largest mask really should be #xFF000000, but smaller value
+ ;; keeps everything a POSITIVE FIXNUM, and no value will exceed
+ ;; 536870911.
+ (t (logior (the (integer #x00000000 #x1F000000)
+ (ash (the (integer #x00 #x1F) (logand #x1F byte-3))
+ 24))
+ (the (integer #x00000000 #x00FF0000) (ash byte-2 16))
+ (the (integer #x00000000 #x0000FF00) (ash byte-1 8))
+ byte-0))))
+
+ ;; Fixnum value out of range and not :Undefined.
+ (t (mishap nil tcp-buffer
+ #.(concatenate
+ 'string
+ "GET-FIXNUM-LE [1] Fixnum out of range.~%"
+ " Object in TCP-Buffer at idx ~D (~D byte fixnum).")
+ idx fixnum-length))))
+
+;;;-------------------------------------------------------------
+;;; For strings, value multiplicity is determined by presence of delimiter
+;;; characters. If present, multiplicity is greater than one and GET-TEXT
+;;; returns a list of substrings. If not present, multiplicity is equal to
+;;; one and GET-TEXT returns singleton list of the string. If FIELD-LENGTH
+;;; is zero, GET-TEXT returns an empty list.
+
+(defun get-text (tcp-buffer idx field-length tail string-padding VR-symbol)
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type symbol string-padding VR-symbol)
+ (type fixnum idx field-length tail))
+
+ (when (> field-length 0)
+ ;; For empty strings, return NIL so value can be skipped over by OR when
+ ;; scrounging DICOM slots for data to stuff into Prism object slots.
+ (do ((ptr idx (the fixnum (1+ ptr)))
+ (output-charlist '())
+ (limit (min tail (the fixnum (+ idx field-length)))))
+ ((>= ptr limit)
+ (cond
+ ((eq string-padding :No-Pad)
+ (setq output-charlist (nreverse output-charlist)))
+ ((eq string-padding :Space-Pad)
+ ;; Trim off trailing #\Space chars [at front of backwards list].
+ (do ((charlist output-charlist (cdr charlist))
+ (ch #\*))
+ ((or (null charlist)
+ ;Null-Padding Fix here.
+ (not (or (eq (setq ch (car charlist)) #\Space)
+ (eq ch #\Null))))
+ (setq output-charlist charlist)))
+ (setq output-charlist (nreverse output-charlist))
+ ;; Trim off leading #\Space chars [at front of forwards list].
+ (when (and (eq (car output-charlist) #\Space)
+ (not (eq VR-symbol 'LT))
+ (not (eq VR-symbol 'ST)))
+ (do ((charlist output-charlist (cdr charlist)))
+ ((or (null charlist)
+ (not (eq (car charlist) #\Space)))
+ (setq output-charlist charlist)))))
+ ((eq string-padding :Null-Pad)
+ (when (eq (car output-charlist) #\Null)
+ (setq output-charlist (cdr output-charlist)))
+ (setq output-charlist (nreverse output-charlist)))
+ (t (mishap nil tcp-buffer
+ "GET-TEXT [1] Bad padding: ~D bytes at TCP-Buf: ~D"
+ field-length idx)))
+ ;; If output string contains delimiters [Value Multiplicity > 1]
+ ;; divide string into fragments and return LIST of the fragments.
+ ;; If VM = 1 [no delimiters], return singleton list of the string.
+ (let ((output-string
+ (make-array (length output-charlist)
+ :element-type 'base-char
+ :initial-contents output-charlist)))
+ (declare (type simple-base-string output-string))
+ (cond
+ ((or (eq VR-symbol 'LT)
+ (eq VR-symbol 'ST))
+ (list output-string))
+ (t (do ((delimiter
+ (position #\\ output-string :test #'char=)
+ (position #\\ output-string :test #'char=))
+ (char-bag '(#\Space #\Null))
+ (multiple-strings '()))
+ ((null delimiter)
+ (cond ((consp multiple-strings)
+ ;; VM > 1: return list of substrings.
+ (cond
+ ((> (length output-string) 0)
+ ;Null-Padding Fix here.
+ (nreverse
+ (cons (string-trim char-bag output-string)
+ multiple-strings)))
+ (t (nreverse multiple-strings))))
+ ((> (length output-string) 0)
+ ;; VM = 1: return singleton list. Was already
+ ;; STRING-TRIMed when still a char list.
+ (list output-string))
+ ;; No value: return NIL.
+ (t nil)))
+ (declare (type list char-bag multiple-strings))
+ (when (> (the fixnum delimiter) 0)
+ ;Null-Padding Fix here.
+ (push (string-trim char-bag
+ (subseq output-string 0 delimiter))
+ multiple-strings))
+ (setq output-string
+ (subseq output-string
+ (the fixnum (1+ (the fixnum delimiter))))))))))
+
+ (declare (type list output-charlist)
+ (type fixnum ptr limit))
+
+ (push (code-char (aref tcp-buffer ptr)) output-charlist))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/parser-rules.cl b/dicom/src/parser-rules.cl
new file mode 100644
index 0000000..96ecc64
--- /dev/null
+++ b/dicom/src/parser-rules.cl
@@ -0,0 +1,826 @@
+;;;
+;;; parser-rules
+;;;
+;;; Rules for DICOM PDU and Message Interpretation.
+;;; Contains declarations common to Client and Server.
+;;;
+;;; 01-Mar-2002 BobGian change rule for User Information Item in Assoc-RQ
+;;; and Assoc-AC PDUs: :SCP/SCU-Role-Item and :SOP-Class-Ext-Neg-Item
+;;; [optional items] upper limit changed from :No-Limit -> 1.
+;;; 23-Apr-2002 BobGian UIDs in A-Assoc-RQ/AC :Null-Pad -> :No-Pad.
+;;; 29-Jul-2002 BobGian change rule for User Information Item in Assoc-RQ
+;;; and Assoc-AC PDUs: :SCP/SCU-Role-Item and :SOP-Class-Ext-Neg-Item
+;;; [optional items] upper limit changed from 1 -> :No-Limit.
+;;; :SOP-Class-Ext-Neg-Item is parsed but currently ignored.
+;;; Jul/Aug 2002 BobGian comments indicate whether environmental values
+;;; decoded in rules are actually used at present or not.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; Rules for Parsing Received PDUs.
+;;;
+;;; Variables commented "Local Env" in <LOOKUP-VAR forms get values from
+;;; lookup in local environment of structure being parsed.
+;;;
+;;; Otherwise, variables get their values from the environment via an access
+;;; chain provided as explicit arguments in <LOOKUP-VAR terms.
+;;;
+;;; The access chain mechanism is implemented but so far all parsing rules
+;;; use "Local Env" access only.
+
+(defparameter *Parser-Rule-List*
+ `(
+
+ ;;=============================================
+ ;; PDU Interpretation Rules.
+ ;;=============================================
+
+ ;; A-Associate-RQ PDU rule == COMPLETE PDU.
+
+ (:A-Associate-RQ
+
+ #x01 ;A-Associate-RQ PDU Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ (=ignored-bytes 4) ;PDU Length [4 bytes] parsed procedurally
+
+ ;; Protocol Version [2-byte bitstring]
+ (>decode-var Protocol-Version fixnum 2 :Big-Endian)
+
+ (=ignored-bytes 2) ;Reserved field -- not tested [2 bytes]
+
+ ;; Called AE Title [16-byte string] -- Local host accepting association.
+ (>decode-var Called-AE-Title string 16 :Space-Pad)
+
+ ;; Calling AE Title [16-byte string] -- Remote host requesting assoc.
+ (>decode-var Calling-AE-Title string 16 :Space-Pad)
+
+ (=ignored-bytes 32) ;Reserved field -- not tested [32 bytes]
+
+ :Application-Context-Item
+
+ ;; 1 or more Presentation Context Items
+ (:Repeat (1 :No-Limit) :Presentation-Context-Item-RQ)
+
+ :User-Information-Item)
+
+ ;;---------------------------------------------
+ ;; Presentation Context Item rule for Assoc-RQ PDU.
+
+ (:Presentation-Context-Item-RQ
+
+ #x20 ;Presentation Context Item type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Field Length [2 bytes -- PC-ID to end of last Transfer Syntax Item]
+ (>decode-var PCI-Len fixnum 2 :Big-Endian) ;Not used at present.
+
+ (>decode-var PC-ID fixnum 1) ;Presentation Context ID [1 byte]
+
+ (=ignored-bytes 3) ;Reserved field -- not tested [3 bytes]
+
+ :Abstract-Syntax-Item-RQ
+
+ (:Repeat (1 :No-Limit) :Transfer-Syntax-Item))
+
+ ;;---------------------------------------------
+ ;; Abstract Syntax Item rule for Assoc-RQ PDU.
+
+ (:Abstract-Syntax-Item-RQ
+
+ #x30 ;Abstract Syntax Item type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Abstract Syntax Name field length [2 bytes]
+ (>decode-var ASN-Len fixnum 2 :Big-Endian)
+
+ ;; Abstract Syntax Name [variable-length byte string]
+ (>decode-var ASN-Str
+ string
+ (<lookup-var ASN-Len) ;Local Env
+ :No-Pad))
+
+ ;;=============================================
+ ;; A-Associate-AC PDU rule == COMPLETE PDU.
+
+ (:A-Associate-AC ;SCU-only normally, SCP in error conditions
+
+ #x02 ;A-Associate-AC PDU Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ (=ignored-bytes 4) ;PDU Length [4 bytes] parsed procedurally
+
+ ;; Protocol Version [2-byte bitstring]
+ (>decode-var Protocol-Version fixnum 2 :Big-Endian)
+
+ (=ignored-bytes 2) ;Reserved field -- not tested [2 bytes]
+
+ ;; Called AE Title [16-byte string] -- Remote host being called.
+ (>decode-var Called-AE-Title string 16 :Space-Pad)
+
+ ;; Calling AE Title [16-byte string] -- Local host requesting assoc.
+ (>decode-var Calling-AE-Title string 16 :Space-Pad)
+
+ (=ignored-bytes 32) ;Reserved field -- not tested [32 bytes]
+
+ :Application-Context-Item
+
+ ;; 1 or more Presentation Context Items
+ (:Repeat (1 :No-Limit) :Presentation-Context-Item-AC)
+
+ :User-Information-Item)
+
+ ;;---------------------------------------------
+ ;; Presentation Context Item rule for Assoc-AC PDU.
+
+ (:Presentation-Context-Item-AC ;SCU-only normally, SCP in error conditions
+
+ #x21 ;Presentation Context Item type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Field Length [2 bytes -- PC-ID to end of last Transfer Syntax Item]
+ (>decode-var PCI-Len fixnum 2 :Big-Endian) ;Not used at present.
+
+ (>decode-var PC-ID fixnum 1) ;Presentation Context ID [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; 0: Accept
+ ;; 1: User-Reject
+ ;; 2: Provider-Reject
+ ;; 3: Abstract-Syntax Not Supported
+ ;; 4: Transfer-Syntax Not Supported
+ (>decode-var Result/Reason fixnum 1)
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Transfer Syntax Item is significant only if Result/Reason
+ ;; is zero [Acceptance]; it is ignored if Result/Reason is non-zero
+ ;; [indicating Rejection].
+ :Transfer-Syntax-Item)
+
+ ;;=============================================
+ ;; Application Context Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Application-Context-Item
+
+ #x10 ;Application Context Item type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Application Context Name Length [2 bytes]
+ (>decode-var ACN-Len fixnum 2 :Big-Endian)
+
+ ;; Application Context Name [variable length]
+ (>decode-var ACN-Str
+ string
+ (<lookup-var ACN-Len) ;Local Env
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; Transfer Syntax Item rule for Assoc-RQ and Assoc-AC PDUs.
+ ;; May be more than one for Assoc-RQ.
+
+ (:Transfer-Syntax-Item
+
+ #x40 ;Transfer Syntax Item type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Transfer Syntax Name field length [2 bytes]
+ (>decode-var TSN-Len fixnum 2 :Big-Endian)
+
+ ;; Transfer Syntax Name [variable-length byte string]
+ (>decode-var TSN-Str
+ string
+ (<lookup-var TSN-Len) ;Local Env
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; User Information Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:User-Information-Item
+
+ #x50 ;User Information Item Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; User Data Item Field Length [2 bytes]
+ (>decode-var UII-Len fixnum 2 :Big-Endian) ;Not used at present.
+
+ :Max-DataField-Len-Item
+
+ :Implementation-Class-UID-Item
+
+ ;; Order of elements here is ambiguous in spec, and various clients
+ ;; seem to do it differently. I list some elements redundantly so
+ ;; parse will succeed for several different possible orders.
+
+ ;; Spec says required, but CTN and other clients do this optionally.
+ (:Repeat (0 1) :Implementation-Version-Name-Item) ;Optional
+
+ (:Repeat (0 1) :Asynchronous-Ops-Item) ;Optional
+
+ ;; One per SOP-Class-UID at most.
+ ;; Optional in Assoc-RQ -- sent in Assoc-AC only if in Assoc-RQ.
+ (:Repeat (0 :No-Limit) :SCP/SCU-Role-Item)
+
+ ;; Spec says required, but CTN and other clients do this optionally.
+ (:Repeat (0 1) :Implementation-Version-Name-Item) ;Optional
+
+ ;; One per SOP-Class-UID at most.
+ (:Repeat (0 :No-Limit) :SOP-Class-Ext-Neg-Item)) ;Currently ignored.
+
+ ;;---------------------------------------------
+ ;; Maximum DataField Length Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Max-DataField-Len-Item
+
+ #x51 ;Maximum Length Sub-Item field tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Maximum Length Received field length [val = 4, 2 bytes]
+ (=fixnum-bytes 4 2 :Big-Endian)
+
+ ;; Maximum Length Received variable. Zero -> no limit.
+ (>decode-var Max-DataField-Len fixnum 4 :Big-Endian))
+
+ ;;---------------------------------------------
+ ;; Implementation Class UID Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Implementation-Class-UID-Item
+
+ #x52 ;Implementation Class UID Item tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Implementation Class UID Item Field Length [2 bytes]
+ (>decode-var IC-UID-Len fixnum 2 :Big-Endian) ;Not used, except below.
+
+ ;; Implementation Class UID [variable-len byte string]
+ (>decode-var IC-UID-Str ;Not used at present.
+ string
+ (<lookup-var IC-UID-Len) ;Local Env
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; Asynchronous Operations Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Asynchronous-Ops-Item
+
+ #x53 ;Asynchronous Operations Item tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Asynchronous Operations Item field length [val = 4, 2 bytes]
+ (=fixnum-bytes 4 2 :Big-Endian)
+
+ ;; Max Num Ops Invoked Asynchronously [0 -> unlimited]
+ (>decode-var Max-Ops-Invoked fixnum 2 :Big-Endian) ;Not used at present.
+
+ ;; Max Num Ops Performed Asynchronously [0 -> unlimited]
+ (>decode-var Max-Ops-Performed fixnum 2 :Big-Endian)) ;Not used.
+
+ ;;---------------------------------------------
+ ;; SCP/SCU Role Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:SCP/SCU-Role-Item
+
+ #x54 ;SCP/SCU Role Item tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; SCP/SCU Role Item field length [2 bytes]
+ (=ignored-bytes 2) ;Redundant -- subsumed by Role-SOP-Class-UID-Len
+
+ ;; SOP Class UID Item Field Length [2 bytes]
+ (>decode-var Role-SOP-Class-UID-Len fixnum 2 :Big-Endian)
+
+ ;; SOP Class UID String [variable-len byte string]
+ (>decode-var Role-SOP-Class-UID-Str
+ string
+ (<lookup-var Role-SOP-Class-UID-Len) ;Local Env
+ :No-Pad)
+
+ ;; 0 -> RQ: no SCU, AC: Reject; 1 -> RQ: SCU, AC: Accept
+ (>decode-var SCU-Role-Flag fixnum 1) ;Not used at present.
+
+ ;; 0 -> RQ: no SCP, AC: Reject; 1 -> RQ: SCP, AC: Accept
+ (>decode-var SCP-Role-Flag fixnum 1)) ;Not used at present.
+
+ ;;---------------------------------------------
+ ;; Implementation Version Name Item rule for Assoc-RQ and Assoc-AC PDUs.
+
+ (:Implementation-Version-Name-Item
+
+ #x55 ;Implementation Version Name Item tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Implementation Version Name Item Field Length [2 bytes]
+ (>decode-var IV-Name-Len fixnum 2 :Big-Endian) ;Not used, except below.
+
+ ;; Implementation Version Name [variable-len byte string]
+ (>decode-var IV-Name-Str ;Not used at present.
+ string
+ (<lookup-var IV-Name-Len) ;Local Env
+ :No-Pad))
+
+ ;;---------------------------------------------
+ ;; SOP Class Extended Negotiation Item rule -- Assoc-RQ and Assoc-AC PDUs.
+
+ (:SOP-Class-Ext-Neg-Item ;Parsed but currently ignored.
+
+ #x56 ;SOP Class Extended Negotiation Item tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; Extended Negotiation Item Field Length [2 bytes]
+ ;; Not used, except below.
+ (>decode-var Ext-Negotiation-Len fixnum 2 :Big-Endian)
+
+ ;; SOP Class UID Item Field Length [2 bytes] Not used, except below.
+ (>decode-var EN-SOP-Class-UID-Len fixnum 2 :Big-Endian)
+
+ ;; SOP Class UID String [variable-len byte string]
+ (>decode-var EN-SOP-Class-UID-Str ;Not used at present.
+ string
+ (<lookup-var EN-SOP-Class-UID-Len) ;Local Env
+ :No-Pad)
+
+ ;; Extended Negotiation data -- varies with SOP class
+ (>decode-var Ext-Negotiation-Str ;Not used at present.
+ string
+ (<funcall -
+ (<lookup-var Ext-Negotiation-Len) ;Local Env
+ (<lookup-var EN-SOP-Class-UID-Len) ;Local Env
+ 2)
+ :No-Pad))
+
+ ;;=============================================
+ ;; A-Associate-RJ PDU rule == COMPLETE PDU.
+
+ (:A-Associate-RJ ;SCU-only normally, SCP in error conditions
+
+ #x03 ;A-Associate-RJ PDU Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ (=ignored-bytes 4) ;PDU Length [4 bytes] parsed procedurally
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ ;; 1: Rejection-Permanent
+ ;; 2: Rejection-Transient
+ (>decode-var RJ-Result fixnum 1)
+
+ ;; 1: UL Service-User
+ ;; 2: UL Service-Provider [ACSE]
+ ;; 3: UL Service-Provider [Presentation Layer]
+ (>decode-var RJ-Source fixnum 1)
+
+ ;; If RJ-Source = 1:
+ ;; 1: No-Reason-Given
+ ;; 2: Application-Context-Name-Not-Supported
+ ;; 3: Calling-AE-Title-Not-Recognized
+ ;; 4-6: Reserved
+ ;; 7: Called-AE-Title-Not-Recognized
+ ;; 8-10: Reserved
+ ;;
+ ;; If RJ-Source = 2:
+ ;; 1: No-Reason-Given
+ ;; 2: Protocol-Version-Not-Supported
+ ;;
+ ;; If RJ-Source = 3:
+ ;; 0: Reserved
+ ;; 1: Temporary-Congestion
+ ;; 2: Local-Limit-Exceeded
+ ;; 3-7: Reserved
+ (>decode-var RJ-Diagnostic fixnum 1))
+
+ ;;=============================================
+ ;; P-Data-TF PDU Command/Data-Set DICOM Message rule == COMPLETE PDU.
+
+ (:P-Data-TF
+
+ #x04 ;P-Data-TF PDU Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ (=ignored-bytes 4) ;PDU Length [4 bytes] parsed procedurally
+
+ ;; 1 or more Presentation-Data-Value Items.
+ ;; Our system only sends 1 PDV-Item per PDU, but it must be able to parse
+ ;; messages from other clients who might send more than one per PDU.
+ (:Repeat (1 :No-Limit) :PDV-Item))
+
+ ;;---------------------------------------------
+ ;; PDV-Item rule for P-Data-TF PDUs.
+ ;; Multiple instances of a :PDV-Item in a single incoming :P-Data-TF PDU
+ ;; will result in multiple instances of PDV-Len [used only for parsing],
+ ;; PC-ID, and PDV-Message being pushed onto the environment. Since
+ ;; multiple :PDV-Item(s) can appear in a PDU, access with SET retrieval.
+
+ (:PDV-Item
+
+ ;; PDV Length [4 bytes]
+ ;; Length is that of PC-ID byte + Control-Header byte + Message length.
+ (>decode-var PDV-Len fixnum 4 :Big-Endian)
+
+ (>decode-var PC-ID fixnum 1) ;Presentation Context ID [1 byte]
+
+ ;; Message Control Header [1 byte]:
+ ;; #b******XY [* is don't-care bit, X and Y are 2 lowest-order bits]
+ ;; Bit X = 0 -> Message is NOT LAST fragment.
+ ;; Bit X = 1 -> Message is LAST fragment.
+ ;; Bit Y = 0 -> Message is Data-Set.
+ ;; Bit Y = 1 -> Message is a Command.
+ (>decode-var PDV-MCH fixnum 1)
+
+ ;; ======================
+ ;; DICOM Message: Data-Set
+ ;; Variable gets bound to content of message in form
+ ;; of a structure: ( :Message <Start-Idx> <End-Idx> )
+ ;; Indices refer to TCP-Buffer -- both must be within current PDV.
+ (>decode-var PDV-Message
+ :Message
+ (<funcall -
+ (<lookup-var PDV-Len) ;Local Env
+ 2)))
+
+ ;;=============================================
+ ;; A-Release-RQ PDU rule == COMPLETE PDU.
+
+ (:A-Release-RQ
+
+ #x05 ;A-Release-RQ PDU Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ (=ignored-bytes 4) ;PDU Length [4 bytes] parsed procedurally
+
+ (=ignored-bytes 4)) ;Reserved field -- not tested [4 bytes]
+
+ ;;=============================================
+ ;; A-Release-RSP PDU rule == COMPLETE PDU.
+
+ (:A-Release-RSP
+
+ #x06 ;A-Release-RSP PDU Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ (=ignored-bytes 4) ;PDU Length [4 bytes] parsed procedurally
+
+ (=ignored-bytes 4)) ;Reserved field -- not tested [4 bytes]
+
+ ;;=============================================
+ ;; A-Abort PDU rule == COMPLETE PDU.
+
+ (:A-Abort
+
+ #x07 ;A-Abort PDU Type tag [1 byte]
+
+ =ignored-byte ;Reserved field -- not tested [1 byte]
+
+ (=ignored-bytes 4) ;PDU Length [4 bytes] parsed procedurally
+
+ (=ignored-bytes 2) ;Reserved field -- not tested [2 bytes]
+
+ ;; 0: UL Service-User-initiated
+ ;; 1: Reserved
+ ;; 2: UL Service-Provider-initiated
+ (>decode-var Abort-Source fixnum 1)
+
+ ;; If Abort-Source = 0:
+ ;; Not Significant [ignored when received]
+ ;;
+ ;; If Abort-Source = 2:
+ ;; 0: Reason Not Specified
+ ;; 1: Unrecognized PDU
+ ;; 2: Unexpected PDU
+ ;; 3: Reserved
+ ;; 4: Unrecognized PDU Parameter
+ ;; 5: Unexpected PDU Parameter
+ ;; 6: Invalid PDU Parameter Value
+ (>decode-var Abort-Diagnostic fixnum 1))
+
+ ;;=============================================
+ ;; DICOM Message Interpretation Rules.
+ ;;=============================================
+
+ ;; C-Echo-RQ PDV Command/Message rule == MESSAGE ONLY.
+
+ (:C-Echo-RQ
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+
+ (>decode-var Group-Len fixnum 4 :Little-Endian) ;Value (not used)
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ ;; Length Slot
+ (>decode-var Echo-SOP-Class-UID-Len fixnum 4 :Little-Endian)
+
+ ;; Value Slot
+ (>decode-var Echo-SOP-Class-UID-Str
+ string
+ (<lookup-var Echo-SOP-Class-UID-Len) ;Local Env
+ :Null-Pad)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0030 2 :Little-Endian) ;Value
+
+ ;;--------- Element 4: Message ID [message being sent]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0110)
+ (=fixnum-bytes #x0110 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (>decode-var Echo-Msg-ID fixnum 2 :Little-Endian) ;Value
+
+ ;;--------- Element 5: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0101 2 :Little-Endian)) ;Code for No-Data
+
+ ;;=============================================
+ ;; C-Echo-RSP PDV Command/Message rule == MESSAGE ONLY.
+
+ (:C-Echo-RSP
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+
+ (>decode-var Group-Len fixnum 4 :Little-Endian) ;Value (not used)
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ ;; Length Slot
+ (>decode-var Echo-SOP-Class-UID-Len fixnum 4 :Little-Endian)
+
+ ;; Value Slot
+ (>decode-var Echo-SOP-Class-UID-Str
+ string
+ (<lookup-var Echo-SOP-Class-UID-Len) ;Local Env
+ :Null-Pad)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x8030 2 :Little-Endian) ;Value
+
+ ;;--------- Element 4: Message ID [message being sent]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0120)
+ (=fixnum-bytes #x0120 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (>decode-var Echo-Msg-ID fixnum 2 :Little-Endian) ;Value
+
+ ;;--------- Element 5: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0101 2 :Little-Endian) ;Code for No-Data
+
+ ;;--------- Element 6: Response Status
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0900)
+ (=fixnum-bytes #x0900 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ ;; Status Value: Code for Success is #x0000.
+ (>decode-var Echo-Msg-Status fixnum 2 :Little-Endian))
+
+ ;;=============================================
+ ;; C-Store-RQ PDV Command/Message rule == MESSAGE ONLY.
+
+ (:C-Store-RQ
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+
+ (>decode-var Group-Len fixnum 4 :Little-Endian) ;Value (not used)
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ (>decode-var Store-SOP-Class-UID-Len fixnum 4 :Little-Endian) ;Length
+
+ (>decode-var Store-SOP-Class-UID-Str ;Value
+ string
+ (<lookup-var Store-SOP-Class-UID-Len) ;Local Env
+ :Null-Pad)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0001 2 :Little-Endian) ;Value
+
+ ;;--------- Element 4: Message ID [message being sent]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0110)
+ (=fixnum-bytes #x0110 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (>decode-var Store-Msg-ID fixnum 2 :Little-Endian) ;Value
+
+ ;;--------- Element 5: Priority
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0700)
+ (=fixnum-bytes #x0700 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ ;; #x0002 -> LOW, #x0000 -> MEDIUM, #x0001 -> HIGH
+ (>decode-var Store-Priority fixnum 2 :Little-Endian) ;Value (not used)
+
+ ;;--------- Element 6: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ ;; Value Slot
+ ;; Anything not equal to #x0101 -> Data-Present
+ (>decode-var DataSet-Type fixnum 2 :Little-Endian)
+
+ ;;--------- Element 7: Affected SOP Instance UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,1000)
+ (=fixnum-bytes #x1000 2 :Little-Endian)
+
+ (>decode-var Store-SOP-Instance-UID-Len fixnum 4 :Little-Endian) ;Length
+
+ ;; Value
+ (>decode-var Store-SOP-Instance-UID-Str
+ string
+ (<lookup-var Store-SOP-Instance-UID-Len) ;Local Env
+ :Null-Pad)
+
+ ;;--------- Element 8: Move Originator AE Title
+ ;; Optional -- required only if C-Store is subservient to a C-Move.
+ (:Repeat (0 1) :Move-Originator-AE)
+
+ ;;--------- Element 9: Move Originator Message ID
+ ;; Optional -- required only if C-Store is subservient to a C-Move.
+ (:Repeat (0 1) :Move-Originator-ID))
+
+ ;;---------------------------------------------
+ ;; Move-Originator AE Title subitem rule for C-Store-RQ Message.
+ ;; Optional -- required only if C-Store is subservient to a C-Move.
+
+ (:Move-Originator-AE
+
+ ;;--------- Element 8: Move Originator AE Title
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,1030)
+ (=fixnum-bytes #x1030 2 :Little-Endian)
+
+ ;; Length (not used at present, except below).
+ (>decode-var Move-Orig-AE-Len fixnum 4 :Little-Endian)
+
+ ;; Value
+ (>decode-var Move-Orig-AE-Str ;Not used at present.
+ string
+ (<lookup-var Move-Orig-AE-Len) ;Local Env (used only here).
+ :Space-Pad))
+
+ ;;---------------------------------------------
+ ;; Move-Originator Message ID subitem rule for C-Store-RQ Message.
+ ;; Optional -- required only if C-Store is subservient to a C-Move.
+
+ (:Move-Originator-ID
+
+ ;;--------- Element 9: Move Originator Message ID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,1031)
+ (=fixnum-bytes #x1031 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (>decode-var Move-Orig-Msg-ID fixnum 2 :Little-Endian)) ;Val (not used).
+
+ ;;=============================================
+ ;; C-Store-RSP PDV Command/Message rule == MESSAGE ONLY.
+
+ (:C-Store-RSP
+
+ ;;--------- Element 1: Group Length
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0000)
+ (=fixnum-bytes #x0000 2 :Little-Endian)
+
+ (=fixnum-bytes 4 4 :Little-Endian) ;Length
+
+ (>decode-var Group-Len fixnum 4 :Little-Endian) ;Value (not used)
+
+ ;;--------- Element 2: Affected SOP Class UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0002)
+ (=fixnum-bytes #x0002 2 :Little-Endian)
+
+ (>decode-var Store-SOP-Class-UID-Len fixnum 4 :Little-Endian) ;Length
+
+ (>decode-var Store-SOP-Class-UID-Str ;Value
+ string
+ (<lookup-var Store-SOP-Class-UID-Len) ;Local Env
+ :Null-Pad)
+
+ ;;--------- Element 3: Command Field
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0100)
+ (=fixnum-bytes #x0100 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x8001 2 :Little-Endian) ;Value
+
+ ;;--------- Element 4: Message ID [message being responded to]
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0120)
+ (=fixnum-bytes #x0120 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (>decode-var Store-Msg-ID fixnum 2 :Little-Endian) ;Value
+
+ ;;--------- Element 5: Data-Set Type
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0800)
+ (=fixnum-bytes #x0800 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ (=fixnum-bytes #x0101 2 :Little-Endian) ;Code for No-Data
+
+ ;;--------- Element 6: Response Status
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,0900)
+ (=fixnum-bytes #x0900 2 :Little-Endian)
+
+ (=fixnum-bytes 2 4 :Little-Endian) ;Length
+
+ ;; Status Value: Code for Success is #x0000.
+ (>decode-var Store-Msg-Status fixnum 2 :Little-Endian)
+
+ ;;--------- Element 7: Affected SOP Instance UID
+ (=fixnum-bytes #x0000 2 :Little-Endian) ;Tag (0000,1000)
+ (=fixnum-bytes #x1000 2 :Little-Endian)
+
+ (>decode-var Store-SOP-Instance-UID-Len fixnum 4 :Little-Endian) ;Length
+
+ (>decode-var Store-SOP-Instance-UID-Str ;Value
+ string
+ (<lookup-var Store-SOP-Instance-UID-Len) ;Local Env
+ :Null-Pad))
+
+ ;;=============================================
+
+ ))
+
+;;;-------------------------------------------------------------
+;;; List of all Message types that our system can recognize.
+
+(defparameter *Message-Type-List*
+ '(:C-Echo-RQ :C-Echo-RSP :C-Store-RQ :C-Store-RSP))
+
+;;;=============================================================
+
+(eval-when (EVAL LOAD)
+ (compile-rules *Parser-Rule-List* :Parser-Rule)
+ (setq *Parser-Rule-List* nil))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/parser.cl b/dicom/src/parser.cl
new file mode 100644
index 0000000..69f5a4e
--- /dev/null
+++ b/dicom/src/parser.cl
@@ -0,0 +1,339 @@
+;;;
+;;; parser
+;;;
+;;; Rule-based Recursive-Descent Parser for DICOM Message Interpretation.
+;;; Contains functions common to Client and Server.
+;;;
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 09-Nov-2003 BobGian - remove debugging printout code from parsing routines.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; In parser, TAIL never changes [set during TCP read operation] and simply
+;;; keeps track of the end of the PDU [point in buffer beyond which one
+;;; should not read]. This assumes that all PDUs fit within the buffer, so
+;;; no buffered reading is necessary.
+;;;
+;;; In parser, HEAD advances over input stream bytes as they are parsed,
+;;; always pointing to the next byte to be parsed ["continuation pointer".
+;;; HEAD is reset on backtracking to the "backtrack pointer" returned by
+;;; parser functions on parse failure.
+
+(defun parse-group (rule env tcp-buffer head tail
+ &aux (init-head head) (init-env env))
+
+ "Success Returns: Buffer-Head [continuation pointer] Environment
+Failure Returns: Buffer-Head [backtrack pointer] :Fail"
+
+ (declare (type list rule env init-env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum head tail init-head))
+
+ (dolist
+ (term
+ (cdr rule)
+ (progn
+ ;; If nothing added to environment, return it unchanged.
+ ;; If anything added, package items added during parse of this
+ ;; group into a tagged structure and add it at front.
+ (unless (eq env init-env)
+ (do ((item env (cdr item))
+ (next (cdr env) (cdr next)))
+ ((eq next init-env)
+ (setf (cdr item) nil)
+ (setq env (cons (car rule) (nreverse env)))
+ (setq env (cond ((equal env (first init-env))
+ ;; If environment additions duplicate items
+ ;; already there, ignore them.
+ init-env)
+ ;; Otherwise prepend new material.
+ (t (cons env init-env)))))
+ (declare (type list item next))))
+ (values head env)))
+
+ (multiple-value-bind (input-cont new-env)
+ (parse-term term env tcp-buffer head tail)
+ (declare (type fixnum input-cont))
+ (cond ((eq new-env :Fail)
+ (return (values init-head :Fail)))
+ (t (setq head input-cont env new-env))))))
+
+;;;-------------------------------------------------------------
+
+(defun parse-term (term env tcp-buffer head tail &aux tag varname
+ varval vartype varlen varend-pad (init-head head))
+
+ "Success Returns: Buffer-Head [continuation pointer] Environment
+Failure Returns: Buffer-Head [backtrack pointer] :Fail"
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type symbol varname vartype varend-pad)
+ (type fixnum head tail init-head))
+
+ (cond
+ ((typep term 'fixnum)
+ (cond ((>= head tail)
+ (setq env :Fail))
+ ((= (the fixnum term) (the fixnum (aref tcp-buffer head)))
+ (setq head (the fixnum (1+ head))))
+ (t (setq env :Fail))))
+
+ ((eq term '=ignored-byte)
+ (when (> (setq head (the fixnum (1+ head))) tail)
+ (setq head init-head env :Fail)))
+
+ ((keywordp term)
+ (cond ((>= head tail)
+ (setq env :Fail))
+ (t (multiple-value-setq (head env)
+ (parse-item term env tcp-buffer head tail)))))
+
+ ((atom term)
+ (mishap env tcp-buffer "PARSE-TERM [1] Bad atomic term: ~S" term))
+
+ ;; All terms from this point onward are known to be non-empty LISTs.
+ ((eq (setq tag (first term)) '=ignored-bytes)
+ (when (> (setq head (the fixnum (+ head (the fixnum (second term)))))
+ tail)
+ (setq head init-head env :Fail)))
+
+ ((eq tag '>decode-var) ;DICOM Variable.
+ (cond
+ ((>= head tail)
+ (setq env :Fail))
+
+ (t (setq varname (second term)
+ vartype (third term)
+ varlen (fourth term))
+
+ (cond
+ ((typep varlen 'fixnum))
+
+ ((consp varlen)
+ ;; These are references to a variables or functions embedded in
+ ;; function calls -- not TERMs as defined above.
+ (cond
+ ((eq (first varlen) '<lookup-var)
+ ;; DICOM Variable environmental lookup.
+ (setq varlen (item-lookup (second varlen) env t)))
+
+ ((eq (first varlen) '<funcall) ;Lisp Function
+ (setq varlen (apply (second varlen)
+ (eval-args (cddr varlen) env))))
+
+ (t (mishap env tcp-buffer "PARSE-TERM [2] Bad VARLEN ~S in:~%~S"
+ varlen term))))
+
+ (t (mishap env tcp-buffer "PARSE-TERM [3] Bad VARLEN ~S in:~%~S"
+ varlen term)))
+
+ (unless (and (typep varlen 'fixnum)
+ (>= (the fixnum varlen) 0))
+ (mishap env tcp-buffer "PARSE-TERM [4] Bad VARLEN ~S in:~%~S"
+ varlen term))
+
+ (cond
+ ((> (the fixnum (+ head varlen)) tail)
+ (mishap env tcp-buffer
+ "PARSE-TERM [5] VARLEN ~S beyond buffer in:~%~S"
+ varlen term))
+
+ (t (setq varend-pad (fifth term))
+ ;; :Big-Endian or :Little-Endian for FIXNUMs.
+ ;; :No-Pad, :Space-Pad, or :Null-Pad for STRINGs.
+ ;; May be NIL for 1-byte fixnums or :Message structures.
+ (cond
+ ((eq vartype 'fixnum)
+
+ (cond
+ ((= (the fixnum varlen) 1)
+ ;; VAREND-PAD not required and not checked since Endian
+ ;; status is irrelevant for single-byte FIXNUMs. Must
+ ;; use NIL as placeholder in term's expression if there
+ ;; are additional arguments.
+ (setq varval (aref tcp-buffer head))
+ (setq head (the fixnum (1+ head))))
+
+ ((and (= (the fixnum varlen) 2)
+ (eq varend-pad :Big-Endian))
+ (setq varval
+ (logior (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer head)) 8)
+ (the (integer #x00 #xFF)
+ (aref tcp-buffer
+ (the fixnum (1+ head))))))
+ (setq head (the fixnum (+ head 2))))
+
+ ((and (= (the fixnum varlen) 2)
+ (eq varend-pad :Little-Endian))
+ (setq varval
+ (logior
+ (the (integer #x00 #xFF) (aref tcp-buffer head))
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer
+ (the fixnum (1+ head)))) 8)))
+ (setq head (the fixnum (+ head 2))))
+
+ ((and (= (the fixnum varlen) 4)
+ (eq varend-pad :Big-Endian))
+ ;; Masks should be #xFF, but using smaller value keeps
+ ;; everything POSITIVE FIXNUM, and no value will exceed
+ ;; 536870911.
+ (setq varval
+ (logior
+ (ash (the (integer #x00 #x1F)
+ (logand #x1F
+ (the (integer #x00 #xFF)
+ (aref tcp-buffer head))))
+ 24)
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (1+ head))))
+ 16)
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (+ head 2))))
+ 8)
+ (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (+ head 3))))))
+ (setq head (the fixnum (+ head 4))))
+
+ ((and (= (the fixnum varlen) 4)
+ (eq varend-pad :Little-Endian))
+ ;; Masks should be #xFF, but using smaller value keeps
+ ;; everything POSITIVE FIXNUM, and no value will exceed
+ ;; 536870911.
+ (setq varval
+ (logior
+ (ash (the (integer #x00 #x1F)
+ (logand
+ #x1F
+ (the (integer #x00 #xFF)
+ (aref tcp-buffer
+ (the fixnum (+ head 3))))))
+ 24)
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (+ head 2))))
+ 16)
+ (ash (the (integer #x00 #xFF)
+ (aref tcp-buffer (the fixnum (1+ head))))
+ 8)
+ (the (integer #x00 #xFF) (aref tcp-buffer head))))
+ (setq head (the fixnum (+ head 4))))
+
+ (t (mishap env tcp-buffer
+ "PARSE-TERM [6] Bad Length/Endian in:~%~S"
+ term))))
+
+ ((and (eq vartype 'string)
+ (or (eq varend-pad :No-Pad)
+ (eq varend-pad :Space-Pad)
+ (eq varend-pad :Null-Pad)))
+ (setq varval (make-string varlen))
+ (do ((idx 0 (the fixnum (1+ idx))))
+ ((= idx (the fixnum varlen)))
+ (declare (type fixnum idx))
+ (setf (aref (the simple-base-string varval) idx)
+ (code-char (aref tcp-buffer head)))
+ (setq head (the fixnum (1+ head))))
+ ;; VARLEN is number of bytes to read from input stream and
+ ;; includes any padding bytes. Must trim strings AFTER
+ ;; copying bytes and incrementing HEAD VARLEN times.
+ (cond ((eq varend-pad :Null-Pad)
+ (setq varval (string-right-trim '(#\Null) varval)))
+ ((eq varend-pad :Space-Pad)
+ (setq varval (string-right-trim '(#\Space) varval)))))
+
+ ;; Structure: ( :Message <Start-Idx> <End-Idx> )
+ ;; Both indices must be within current PDV.
+ ((eq vartype :Message)
+ (setq varval (list :Message
+ head
+ (setq head (the fixnum
+ (+ head varlen))))))
+
+ (t (mishap env tcp-buffer
+ "PARSE-TERM [7] Bad type ~S in:~%~S"
+ vartype term)))
+
+ (push (cons varname varval) env))))))
+
+ ((eq tag :Repeat)
+ (multiple-value-setq (head env)
+ (parse-repeats (cdr term) env tcp-buffer head tail)))
+
+ (t (mishap env tcp-buffer "PARSE-TERM [8] Bad compound term: ~S" term)))
+
+ (values head env))
+
+;;;-------------------------------------------------------------
+
+(defun parse-item (item env tcp-buffer head tail)
+
+ "Success Returns: Buffer-Head [continuation pointer] Environment
+Failure Returns: Buffer-Head [backtrack pointer] :Fail"
+
+ (declare (type list env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum head tail))
+
+ (let ((rule (get item :Parser-Rule)))
+ (cond ((consp rule)
+ (multiple-value-bind (input-cont new-env)
+ (parse-group rule env tcp-buffer head tail)
+ (declare (type fixnum input-cont))
+ (values input-cont new-env)))
+ (t (mishap env tcp-buffer "PARSE-ITEM [1] Bad item: ~S" item)))))
+
+;;;-------------------------------------------------------------
+
+(defun parse-repeats (repeater env tcp-buffer head tail &aux (init-head head)
+ lowlimit highlimit (repeat-code (first repeater))
+ (repeat-item (second repeater)))
+
+ "Success Returns: Buffer-Head [continuation pointer] Environment
+Failure Returns: Buffer-Head [backtrack pointer] :Fail"
+
+ (declare (type list repeater env)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum head tail init-head))
+
+ (cond ((typep repeat-code 'fixnum)
+ (setq lowlimit repeat-code highlimit repeat-code))
+
+ ((and (consp repeat-code)
+ (typep (setq lowlimit (first repeat-code)) 'fixnum)
+ (or (typep (setq highlimit (second repeat-code)) 'fixnum)
+ (and (eq highlimit :No-Limit)
+ (setq highlimit #.Most-Positive-Fixnum)))))
+
+ (t (mishap env tcp-buffer "PARSE-REPEATS [1] Bad repeat-code: ~S"
+ repeater)))
+
+ (do ((repeat-count 0 (the fixnum (1+ repeat-count))))
+ ((= repeat-count (the fixnum highlimit))
+ ;; Succeeded in parsing HIGHLIMIT items -- successful return. If there
+ ;; are more such items in the input stream not matched by next element
+ ;; in current rule, parser will detect the mismatch when trying to
+ ;; parse the next item.
+ (values head env))
+
+ (declare (type fixnum repeat-count))
+
+ (multiple-value-bind (input-cont new-env)
+ (parse-item repeat-item env tcp-buffer head tail)
+
+ (declare (type fixnum input-cont))
+
+ (cond ((eq new-env :Fail)
+ (cond ((< repeat-count (the fixnum lowlimit))
+ ;; Failure BEFORE parsing LOWLIMIT items -- backtrack.
+ (return (values init-head :Fail)))
+ ;; Failure AFTER parsing LOWLIMIT items -- continue.
+ (t (return (values head env)))))
+
+ ;; Advance HEAD past bytes parsed successfully.
+ (t (setq head input-cont env new-env))))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/pds.config.example b/dicom/src/pds.config.example
new file mode 100644
index 0000000..23673f2
--- /dev/null
+++ b/dicom/src/pds.config.example
@@ -0,0 +1,253 @@
+;;;
+;;; pds.config
+;;;
+;;; Prism DICOM System Configuration.
+;;; Contains data used in Server only.
+;;;
+;;; 17-Feb-2000 BobGian remove *CHOWN-STRING* and *CHMOD-STRING*.
+;;; Superseded by containing directory mechanism. See note in "mainloop".
+;;; 10-Apr-2000 BobGian add configuration data for PET.
+;;; 11-Apr-2000 BobGian add configuration data for Radiology CT #3.
+;;; 27-Apr-2000 BobGian temporarily remove Radiology Indep Console from
+;;; list of acceptable remote entities (not DICOM-3 compatible).
+;;; 13-Jul-2000 BobGian change IP addr for Sun (CT image-viewing room) again.
+;;; 29-Dec-2000 BobGian update defaults - remove personal directories.
+;;; 15-Feb-2001 BobGian change AET for CT at Harborview.
+;;; 11-Apr-2001 BobGian remove hostname in *REMOTE-ENTITIES* -- only IP
+;;; address and AE Title used for acceptance discrimination.
+;;; 25-Apr-2001 BobGian set CTN test client to use "test" directory.
+;;; 30-Jul-2001 BobGian change IP for CT at Harborview.
+;;; 24-Sep-2001 BobGian add third field to *REMOTE-ENTITIES* -
+;;; "Client Name" string to identify remote client in log file.
+;;; 05-Dec-2001 BobGian add GE Advantage CT Sim as legal client.
+;;; 06-Mar-2002 BobGian remove "Prism_RT_Client" on Bilbo and Oboe from
+;;; *REMOTE-ENTITIES* - was for testing Dicom-RT on Oboe - obsolete.
+;;; Jul/Aug 2002 BobGian add extra optional element to *LOCAL-ENTITIES* and
+;;; *REMOTE-ENTITIES* indicating Structure-Set directory:
+;;; "/prismdata/research/structures/"
+;;; 25-Mar-2003 BobGian add config data for Radonc CT and GE Adv Sim in NN-115.
+;;; 18-Apr-2003 BobGian add "gandalf" as test client.
+;;; 18-Jun-2003 MarkWag change frodo config: new IP addr, location
+;;; 21-Dec-2003 BobGian: Add variable *IGNORABLE-GROUPS-LIST* to specify
+;;; slots that PARSE-OBJECT should log but otherwise ignore.
+;;; 27-Feb-2003 BobGian: Add Radiology research client. Remove Oboe.
+;;; 31-Mar-2004 BobGian: Update config for UW Radiology MRI Console.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+
+;;; Values set here override default values given in "dicom-server.system"
+;;; since this file is loaded last just before server begins operation.
+;;; SETQ rather than DEFPARAMETER used to avoid redefinition warnings.
+;;; This also makes clear the intention of changing existing bindings.
+;;;
+;;; Set for Radonc at University of Washington. See embedded comments
+;;; for resetting for Soroka Medical Center, Be'er Sheva, Israel.
+
+;;;=============================================================
+;;; Association Requestors from whom we will accept connections.
+
+;;; AE titles and optional directory dispatch.
+
+;(setq *remote-entities* nil) ;"Promiscuous" mode.
+;;;
+(setq *remote-entities* ;"Safe Hex" mode.
+ '(("128.208.90.17" "001G01M023-XU" "UWMC PACS - Images")
+ ("128.208.90.15" "M015QR" "UWMC PACS - Q/R")
+
+ ;; New Radonc CT in NN-115
+ ("128.208.141.78" "roct" "Radonc CT in NN-115")
+
+ ;; GE Advantage CT Simulator workstation in NN-115
+ ("128.208.141.79" "rows" "GE Advantage Sim in NN-115")
+
+ ;; GE Advantage CT Simulator workstation in NN-115
+ ("128.208.141.93" "frodo" "GE Advantage Sim in NN-115")
+
+ ;; ADAC/Pinnacle in Mark Phillips' office.
+ ("128.95.181.33" "PINNSB2-1" "ADAC/Pinnacle in NN-146E")
+
+ ;; Sun workstation (2nd floor UWMC, CT image-viewing room)
+ ("128.208.90.65" "UW01-PC1" "Sun workstation, UWMC Radiology")
+
+ ;; Radiology: old GE LightSpeed CT scanner (2nd floor UWMC)
+ ;; name on LightSpeed transfer pick-list: "Prism_Image_Srvr"
+ ("128.208.90.68" "ct03" "Old GE LightSpeed CT, UWMC Radiology")
+
+ ;; Radiology: new GE LightSpeed CT scanner (2nd floor UWMC)
+ ("128.208.90.102" "uwct1" "New GE LightSpeed CT, UWMC Radiology")
+
+ ;; PET Advance workstation (Nuc Med)
+ ;; Icon label: "radonc_cluster"
+ ("128.95.183.205" "RALPH" "PET Advance workstation, UWMC Nuc Med")
+
+ ;; Radiology MRI Console
+ ("128.208.90.77" "UMR1-OC0" "MRI Console, UWMC Radiology")
+
+ ;; Radiology MRI Console
+ ("128.208.90.78" "UMR1-OC0" "MRI Console, UWMC Radiology")
+
+ ;; UWMC Horizon LX
+ ("128.95.183.220" "UMR1_OC0" "UWMC Horizon LX")
+
+ ;; SCCA-SELU (contact: Tyrone Beal, 206-288-6211)
+ ("140.107.242.12" "ct01" "SCCA-SELU")
+
+ ;; CT/MRI Scanners at Children's Hospital
+ ("208.146.45.110" "mac" "CT/MRI Scanners, Children's Hospital")
+
+ ;; CT Main at Harborview
+ ("140.142.192.238" "hmerct3" "CT Main at Harborview")
+
+ ;; MR Main at Harborview
+ ("204.203.143.221" "HMRA-MR1" "MR Main at Harborview")
+
+ ;; VA Hospital, Seattle
+ ("198.137.1.131" "PICKER_CT_STORE" "VA Hospital, Seattle")
+
+ ("128.208.90.66" "CRQAUW" ;Prism research client in Radiology.
+ "Prism research client in Radiology"
+ "/prismdata/research/cases/" ;Patient database
+ "/prismdata/research/images/" ;Matched Patient Images database
+ "/prismdata/research/imagedump/" ;Unmatched Patient Images database
+ "/prismdata/research/structures/") ;Structure-Set database
+
+ ("128.208.141.69" "gandalf" ;Mark Wagner's CTN test client
+ "Mark Wagner's computer"
+ "/prismdata/test/cases/" ;Patient database
+ "/prismdata/test/images/" ;Matched Patient Images database
+ "/prismdata/test/imagedump/" ;Unmatched Patient Images database
+ "/prismdata/test/structures/") ;Structure-Set database
+
+ ("128.208.141.70" "Test_Client" ;Prism test client on Trumpet.
+ "Prism test client on Trumpet"
+ "/prismdata/test/cases/" ;Patient database
+ "/prismdata/test/images/" ;Matched Patient Images database
+ "/prismdata/test/imagedump/" ;Unmatched Patient Images database
+ "/prismdata/test/structures/") ;Structure-Set database
+
+ ("128.95.181.167" "Test_Client" ;Prism test client on IMRT.
+ "Prism test client on IMRT"
+ "/prismdata/test/cases/" ;Patient database
+ "/prismdata/test/images/" ;Matched Patient Images database
+ "/prismdata/test/imagedump/" ;Unmatched Patient Images database
+ "/prismdata/test/structures/") ;Structure-Set database
+
+ ("134.121.135.89" "EV2" ;Washington State Veterinary School
+ "Washington State Veterinary School"
+ "/prismdata/research/cases/" ;Patient database
+ "/prismdata/research/images/" ;Matched Patient Images database
+ "/prismdata/research/imagedump/" ;Unmatched Patient Images database
+ "/prismdata/research/structures/") ;Structure-Set database
+
+ ))
+
+;;; AE titles we will recognize as our own, and directory dispatch.
+;;; Server will accept any of these and will echo in A-Associate-AC
+;;; the actual name used by client in A-Associate-RQ.
+;(setq *local-entities* nil) ;"Promiscuous" mode.
+;;;
+(setq *local-entities* ;"Safe Hex" mode.
+ '(("Prism_DICOM_Srvr") ;Server's real name
+ ("Prism_Image_Srvr") ;Server's name on some machines
+ ("PRISM_IMAGE_SRVR") ;Server's name on VA machine
+ ("PDS_V1.0") ;Radiology CT Indep Console - Clinical
+ ("PDS_Research" ;Radiology CT Indep Console - Research
+ "/prismdata/research/cases/" ;Patient Database
+ "/prismdata/research/images/" ;Matched Patient Images database
+ "/prismdata/research/imagedump/" ;Unmatched Patient Images database
+ "/prismdata/research/structures/") ;Structure-Set database
+ ("RADONC/PRISM") ;Server's name on Radiology MRI Console
+ ))
+
+;;; IP address of Zero.washington.edu, on which PDS is running:
+;;; 128.95.181.65
+
+;;;=============================================================
+;;; User-Configurable System Parameters.
+
+;;; Patient case and index data:
+(setq *patient-database* "/prismdata/clinical/cases/")
+
+;;; Matched Patient Image database:
+(setq *matched-pat-image-database* "/prismdata/clinical/images/")
+
+;;; Unmatched Patient Image database:
+(setq *unmatched-pat-image-database* "/prismdata/clinical/imagedump/")
+
+;;; Structure-Set data for all patients:
+(setq *structure-database* "/prismdata/clinical/structures/")
+
+;;; Ranges for Group numbers to be ignored when parsing objects.
+;;; Value is a list of CONS pairs where CAR is an inclusive lower bound and
+;;; CDR is an exclusive upper bound. For example, the value here causes all
+;;; groupnumbers in the 50xx and 60xx ranges to be logged and ignored.
+(setq *ignorable-groups-list*
+ '(( #x5000 . #x5100 )
+ ( #x6000 . #x6100 )))
+
+;;; Default server listening port for production usage is 104.
+;;;
+;(setq *pds-server-port* 8000)
+
+;;; Logging Level:
+(setq *log-level* 0)
+
+;;; Each level includes all items logged at levels below it.
+;;;
+;;; Level 0 -- Production usage. Important messages only:
+;;; Reading of configuration file.
+;;; Configuration parameters.
+;;; Keepalive messages.
+;;; ARTIM Timeouts.
+;;; Connection by client to server.
+;;; Connection details (IP, etc) by client.
+;;; Association acceptance (+ AE-Titles, IP-Addrs) by server.
+;;; Association rejection decisions with reasons by server.
+;;; Association release by server.
+;;; Patient identification by server.
+;;; Location of data files written by server.
+;;; Rejection of non-axial images by server.
+;;; Any error that aborts association.
+;;; Environment printout on REPORT-ERROR (if available).
+;;; Dump of Dicom-Alist (if available) in REPORT-ERROR.
+;;; Aborts from client or server.
+;;; Unexpected socket closures.
+;;; Server exit.
+;;;
+;;; Level 1 -- Modest logging:
+;;; TCP connection opening/closing by client.
+;;; Association request by client.
+;;; PDU transmissions.
+;;; Lisp-format dump of data passed by server to writer fcns.
+;;; End-of-File on TCP reads.
+;;; Connection awaiting/opening/closing by server.
+;;; Patient identification for each dataset by server.
+;;;
+;;; Level 2 -- Simple testing:
+;;; DUL main loop iteration count.
+;;; State Transitions (Event, Action Function, Next-State).
+;;; Decoded PDU types on reception.
+;;; PDU transmissions.
+;;; Full error report after Association Rejection by server.
+;;; Value parsed from each DICOM slot by server.
+;;;
+;;; Level 3 -- Detailed testing:
+;;; TCP Reads.
+;;; Action Function messages.
+;;; Signaled Events.
+;;; PDU reads and decoding.
+;;; SEND-PDU arguments.
+;;; Environmental printout each iteration.
+;;; TCP-Buffer start-end pointers on each TCP read and parse.
+;;; Message parsing results.
+;;; Object parsing messages.
+;;;
+;;; Level 4 -- Full debugging:
+;;; Full PDU dumps (both list-structure and TCP buffer)
+;;; on reception and transmission.
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/prism-data.cl b/dicom/src/prism-data.cl
new file mode 100644
index 0000000..cdbaf86
--- /dev/null
+++ b/dicom/src/prism-data.cl
@@ -0,0 +1,382 @@
+;;;
+;;; prism-data
+;;;
+;;; Definitions for objects used in Images and Structure-Sets.
+;;; Contains declarations used in Server only.
+;;;
+;;; Jul/Aug 2002 BobGian add defns for classes used for Structure-Sets:
+;;; GENERIC-PRISM-OBJECT, PSTRUCT, ORGAN, POLYLINE, and CONTOUR.
+;;; 18-Sep-2002 BobGian add PAT-POS slot to IMAGE class for describing
+;;; patient position as scanned (Head-First Supine, etc).
+;;; 06-May-2003 BobGian add TUMOR and TARGET class defs (for structure-sets).
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defclass generic-prism-object ()
+
+ ((name :type string
+ :accessor name
+ :initarg :name
+ :documentation "The name string for each instance of an
+object, e.g., patient name, or plan name.")
+
+ )
+
+ (:default-initargs :name "Generic Prism object.")
+
+ (:documentation "This is the basic prism object definition for
+objects that will have names and be created and deleted via selector
+panels, and with their own editing panels.")
+
+ )
+
+;;;-------------------------------------------------------------
+
+(defclass pstruct (generic-prism-object)
+
+ ((contours :initarg :contours
+ :type list
+ :accessor contours
+ :documentation "A list of contours representing the
+surface of the volume.")
+
+ (display-color :initarg :display-color
+ :accessor display-color)
+
+ )
+
+ (:default-initargs :name "" :contours nil :display-color 'sl:white)
+
+ (:documentation "A pstruct is any kind of 3-d geometric structure
+pertaining to the case, either an organ, with density to be used in
+the dose computation, or an organ with no density, but whose dose
+histogram should be known, or a target, whose dose should be
+analyzed.")
+
+ )
+
+;;;-------------------------------------------------------------
+
+(defclass organ (pstruct)
+
+ ((tolerance-dose :type single-float
+ :initarg :tolerance-dose
+ :accessor tolerance-dose
+ :documentation "The accepted value for radiation
+tolerance for this organ type, in rads.")
+
+ (density :initarg :density
+ :accessor density
+ :documentation "The density to be used in the dose
+computation for inhomogeneity corrections. It can be nil or a number,
+so the type is not specified here. If nil, the organ is not used in
+the dose computation for inhomogeneity corrections.")
+
+ #+ignore
+ (organ-name :initarg :organ-name
+ :reader organ-name
+ :documentation "One of the known organ names.")
+
+ )
+
+ (:default-initargs :tolerance-dose 0.0 :density nil
+ :display-color 'sl:green)
+
+ (:documentation "This class includes both organs that represent
+inhomogeneities and organs for which there is a tolerance dose not to
+be exceeded. Some organs are of both types.")
+
+ )
+
+;;;--------------------------------------
+
+(defclass tumor (pstruct)
+
+ ((t-stage :type symbol
+ :initarg :t-stage
+ :accessor t-stage
+ :documentation "The tumor's t-stage - one of 't1, 't2,
+'t3, t4, or nil if unspecified.")
+
+ (m-stage :type symbol
+ :initarg :m-stage
+ :accessor m-stage
+ :documentation "The tumor's m-stage.")
+
+ (n-stage :type symbol
+ :initarg :n-stage
+ :accessor n-stage
+ :documentation "The tumor's n-stage - one of 'n0, 'n1,
+'n2, 'n3, or nil if unspecified.")
+
+ (cell-type :type symbol
+ :initarg :cell-type
+ :accessor cell-type
+ :documentation "One of a list of numerous cell types, or
+nil if unspecified.")
+
+ (site :type symbol
+ :initarg :site
+ :accessor site
+ :documentation "One of the known tumor sites, a symbol, as
+determined by the anatomy tree.")
+
+ (region :type symbol
+ :initarg :region
+ :accessor region
+ :documentation "For lung tumors, a region of the lung. Nil
+if unspecified or for other tumor sites, or one of 'hilum, 'upper-lobe,
+'lower-lobe, or 'mediastinum.")
+
+ (side :type symbol
+ :initarg :side
+ :accessor side
+ :documentation "For lung tumors, the side of the lung that
+the tumor is on. Nil if unspecified or for other tumor sites, or one
+of 'left or 'right.")
+
+ (fixed :type symbol
+ :initarg :fixed
+ :accessor fixed
+ :documentation "For lung tumors, an indication of whether
+the tumor is fixed to the chest wall or not. Nil if unspecified of
+for other tumor sites, or one of 'yes or 'no.")
+
+ (pulm-risk :type symbol
+ :initarg :pulm-risk
+ :accessor pulm-risk
+ :documentation "For lung tumors, the tumor's pulmonary
+risk. Nil if unspecified or for other tumor sites, or one of 'high
+or 'low.")
+
+ (grade :initarg :grade
+ :accessor grade
+ :documentation "The tumor's grade")
+
+ )
+
+ (:default-initargs :t-stage nil :n-stage nil :m-stage nil
+ :cell-type nil :site 'body :region nil
+ :side nil :fixed nil :pulm-risk nil
+ :grade nil :display-color 'sl:cyan)
+
+ (:documentation "There may be more than one tumor volume for a
+patient.")
+
+ )
+
+;;;--------------------------------------
+
+(defclass target (pstruct)
+
+ ((site :initarg :site
+ :accessor site
+ :documentation "One of the known tumor sites")
+
+ (required-dose :type single-float
+ :initarg :required-dose
+ :accessor required-dose)
+
+ (region :initarg :region
+ :accessor region)
+
+ (target-type :initarg :target-type
+ :accessor target-type
+ :documentation "One of either initial or boost")
+
+ (nodes :initarg :nodes
+ :accessor nodes
+ :documentation "Nodes to treat")
+
+ (average-size :type single-float
+ :initarg :average-size
+ :accessor average-size)
+
+ (how-derived :initarg :how-derived
+ :accessor how-derived)
+
+ )
+
+ (:default-initargs :site 'body :required-dose 0.0
+ :region nil :target-type "unspecified"
+ :how-derived "Manual"
+ :display-color 'sl:blue)
+
+ (:documentation "There may be more than one target volume for a
+patient, e.g., the boost volume and the large volume. Also, the tumor
+volume and the target volume are different.")
+
+ )
+
+;;;-------------------------------------------------------------
+
+(defclass polyline ()
+
+ ((z :type single-float
+ :initarg :z
+ :accessor z) ; z coord. of plane of definition
+
+ (vertices :type list
+ :initarg :vertices
+ :accessor vertices
+ :documentation "A list of 2-d coordinate pairs")
+
+ (display-color :type symbol
+ :initarg :display-color
+ :accessor display-color)
+
+ )
+
+ (:default-initargs :vertices nil :display-color 'sl:magenta)
+
+ (:documentation "Polylines represent any unconstrained curve in the
+plane, like a clipped isodose contour or a physician's signature.")
+
+ )
+
+;;;-------------------------------------------------------------
+
+(defclass contour (polyline)
+
+ ()
+
+ (:documentation "Contours are always part of some object, the type
+of which determines the definition plane. The vertices are a list of
+coordinate pairs because there is nothing about points that would make
+it worth having a list of point instances instead. Structurally, a
+contour is the same as a polyline but the implicit difference between
+them is that contours are non-self-intersecting, must enclose non-zero
+area, no three adjacent vertices can be collinear, and no vertices are
+duplicated. It is also understood that the last point is connected to
+the first, though it is not explicitly repeated in the vertices
+list.")
+
+ )
+
+;;;=============================================================
+
+(defclass image ()
+
+ ((id :type fixnum
+ :accessor id)
+
+ (uid :type string
+ :accessor uid)
+
+ (patient-id :type fixnum
+ :accessor patient-id
+ :documentation "The Prism Patient ID of the patient this
+image belongs to.")
+
+ (image-set-id :type fixnum
+ :accessor image-set-id
+ :documentation "The Prism image set ID of the primary
+image set the image belongs to; can also be changed in order to make it
+part of another image set.")
+
+ (pat-pos :type string
+ :accessor pat-pos
+ :initarg :pat-pos
+ :documentation "String, one of \"HFP\", \"HFS\", \"FFP\", \"FFS\"
+describing patient position as scanned (Head/Feet-First Prone/Supine, etc).
+Also legal but not used in Prism are \"HFDR\", \"HFDL\", \"FFDR\", \"FFDL\"
+for Head/Feet-first Decubitus Right/Left.")
+
+ (description :type string
+ :accessor description)
+
+ (acq-date :type string
+ :accessor acq-date)
+
+ (acq-time :type string
+ :accessor acq-time)
+
+ (scanner-type :type string
+ :accessor scanner-type) ;GE9800, SOMATOM-DR, etc
+
+ (hosp-name :type string
+ :accessor hosp-name)
+
+ (img-type :type string
+ :accessor img-type) ;CT, NMR, PET, etc
+
+ (origin :type (vector single-float 3)
+ :accessor origin
+ :documentation "Origin refers to the location in patient
+space of the corner of the image as defined by the point at pixel
+array reference 0 0 or voxel array reference 0 0 0 -- see the pixels
+and voxels slot in the respective image-2D and image-3D subclasses.")
+
+ (size :type list ; of two or three elements, x y z
+ :accessor size
+ :documentation "The size slot refers to the overall size of
+the image in each dimension, measured in centimeters in patient
+space.")
+
+ (range :type fixnum ;4095 fixed stub
+ :accessor range
+ :documentation "Range refers to the maximum pixel/voxel
+value possible for this type of image.")
+
+ (units :type string
+ :accessor units) ;eg: Hounsfield numbers
+
+ )
+
+ (:documentation "The basis for all kinds of geometric studies upon
+patients, including 2-D images, 3-D images, 2-D image sets, like a
+series of CT slices, and 3-D image sets. The information here defines
+all the parameters relevant to the moment of study itself and to
+parameters found in all images.")
+
+ )
+
+;;;-------------------------------------------------------------
+
+(defclass image-2D (image)
+
+ ((thickness :type single-float
+ :accessor thickness)
+
+ (x-orient :type (vector single-float 3)
+ :accessor x-orient
+ :documentation "The x-orient and y-orient slots are
+vectors in patient space that define the orientation of the X and Y
+axes of the image respectively, relative to the patient coordinate
+system.")
+
+ (y-orient :type (vector single-float 3)
+ :accessor y-orient
+ :documentation "See x-orient.")
+
+ (pix-per-cm :type single-float
+ :accessor pix-per-cm)
+
+ (pixels :type (simple-array (unsigned-byte 8) 1)
+ ;; Prism PIXEL array is (simple-array (unsigned-byte 16) 2) but
+ ;; DICOM treats it [effectively via overlay] as an array of type
+ ;; (simple-array (unsigned-byte 8) 1) .
+ :accessor pixels
+ :documentation "Pixels is the array of image data itself.
+The value at each index of the array refers to a sample taken from the
+center of the region indexed, and values for images with non-zero
+thickness refer to points mid-way through the image's thickness. The
+origin of the pixels array is in the upper left hand corner, and the
+array is stored in row-major order so values are indexed as row,
+column pairs, i.e., the dimensions are y, x.")
+
+ )
+
+ (:documentation "An image-2D depicts some 2-D slice, cross section
+or projected view of a patient's anatomy and is typically a single CT
+image, an interpolated cross section of a volume, or the result of ray
+tracing through a volume from an eyepoint to a viewing plane.")
+
+ )
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/prism-output.cl b/dicom/src/prism-output.cl
new file mode 100644
index 0000000..4b34d47
--- /dev/null
+++ b/dicom/src/prism-output.cl
@@ -0,0 +1,1285 @@
+;;;
+;;; prism-output
+;;;
+;;; Functions for writing DICOM objects into Prism filesystem.
+;;; Contains functions used in Server only.
+;;;
+;;; 01-Nov-2000 BobGian change AXIAL-image acceptance test also to print
+;;; value of DICOM slot showing value present [if image rejected].
+;;; 30-Jul-2001 BobGian improve formatting of data sent to log file.
+;;; 07-Oct-2001 BobGian simplify READ-OBJECT [remove opt args - never used].
+;;; 07-Oct-2001 BobGian PUT-IMAGE-SET -> WRITE-IMAGE-SET
+;;; [conflicted with different function of same name in Prism package].
+;;; 15-Oct-2001 BobGian remove *FILE-MOVE-LIST*, temporary directory, and file
+;;; moving - all output files now written directly to final directories.
+;;; 26-Dec-2001 BobGian change log message for non-Axial image.
+;;; 18-Jan-2002 BobGian fix identification of dataset.
+;;; 20-Jan-2002 BobGian:
+;;; 1. Don't write duplicates - if dataset is identified reliably as
+;;; duplicate [via its UID] then it must be identical to original.
+;;; 2. Don't append record to Image Set file until image itself has been
+;;; stored successfully. This is important since images are no longer
+;;; written to and moved from temporary directory. Presence of record
+;;; in Image Set file is sole indication of successful image storage.
+;;; 3. Rather than caching entire Image Set file only at point of patient
+;;; identification, list of image UIDs is created then [empty for new
+;;; set, but may contain data if some images in current set were sent
+;;; on a previous association]. This list is updated as each image is
+;;; stored during current association, extending duplicate detection to
+;;; multiple identical images received during current association.
+;;; 24-Jan-2002 BobGian output directory noted in log file on patient
+;;; identification - valid, since duplicates no longer written.
+;;; 19-Mar-2002 BobGian replace own error message printer [which was not
+;;; always reliable] with call to standard DESCRIBE function.
+;;; 19-Jun-2002 BobGian begin Structure-Set implementation.
+;;; Jul/Aug 2002 BobGian implement Structure-Set C-Store SOP class:
+;;; WRITE-DICOM-OUTPUT does dispatch on C-Store-RQ SOP class (:Image or
+;;; :Structure-Set), calling appropriate output routine.
+;;; GET-PRISM-PATIENT seeks patient name and ID match only for Images. For
+;;; Structure-Sets it creates a unique index file entry (indexed by name,
+;;; Hosp ID, and timestamp) for each dataset received. Name printed to
+;;; index file and log is "prettified" version (as in Prism records)
+;;; rather than raw string transmitted in DICOM header.
+;;; PRISM-IMAGE-WRITER (renamed from PRISM-DATA-WRITER) does image output.
+;;; Uses tag 0020:0032 "Image Position Patient (Z)" rather than tag
+;;; 0020:1041 "Slice Location (Z)" for image Z coordinate. Should work
+;;; for both CT and MR images. Experimental until verified.
+;;; WRITE-IMAGE-SET detects start of new image set transmitted during current
+;;; association by checking A-list of ID and UID for each image. If ID and
+;;; UID of new image match those of an existing one, new one is declared to
+;;; be a duplicate and ignored. If ID matches but UID is different, image
+;;; is declared to be first of a new image set. WRITE-IMAGE-SET increments
+;;; the image-set count (one larger than largest found in image index file)
+;;; and calls itself recursively to begin writing a new image set (rather
+;;; than overwriting existing images as formerly). The new image set
+;;; number is appended to a saved list of records to be appended to the
+;;; image index file when the association is released.
+;;; New function PRISM-STRUCTURE-WRITER decodes structure-set data and
+;;; writes data in Prism format (via PUT-OBJECT) to file.
+;;; GET-CANONICAL-NAME - new function factored and reused (formerly inlined).
+;;; PUT-OBJECT - new function almost identical to Prism version, differing by
+;;; being special-cased to data objects needed and by including a special
+;;; hook for passing filename for Image files to image-set file slot-value.
+;;; TAB-PRINT also made almost identical to version in Prism system
+;;; [needs to do arbitrary indentation for structure-sets whereas former
+;;; version only did single-level indentation for image-set file].
+;;; 06-Aug-2002 BobGian *PRINT-PRETTY* -> T in PUT-OBJECT.
+;;; 17-Aug-2002 BobGian tag 0020:0032 does not work for Z coord.
+;;; Reverting back to tag 0020:1041 until this can be figured out.
+;;; 20-Aug-2002 BobGian:
+;;; At end of image set (when new set detected here, or at conclusion of
+;;; association in DICOM-SERVER), log number of images stored in each set
+;;; to "image.index" record and to log file.
+;;; PRISM-STRUCTURE-WRITER now logs that it wrote file (and the filename).
+;;; Interchange SERIES <-> STUDY in all tag fields used to identify image
+;;; set number.
+;;; 26-Aug-2002 BobGian:
+;;; Series Instance UID (0020:000E) passed to WRITE-IMAGE-SET as definitive
+;;; and mandatory unique identifier of image set.
+;;; Image Position Patient (0020:0032) used as correct slot for image Z
+;;; coordinate - was buggy formerly (accessed X rather than Z coord).
+;;; Slice Location (0020:1041) is not a mandatory data element.
+;;; 27-Aug-2002 BobGian:
+;;; READ-OBJECT error messages renumbered.
+;;; READ-OBJECT changed always to abort [num args 4 -> 3]. Default return
+;;; values would cause incorrect operation and would mask problems.
+;;; All slots previously assumed to contain strings representing SINGLE-FLOAT
+;;; values instead can contain strings representing either SINGLE-FLOAT
+;;; or INTEGER values (data type DS for "Decimal String"). Converted
+;;; following slot accessors to read as REAL (INTEGER or SINGLE-FLOAT)
+;;; and coerce to SINGLE-FLOAT as necessary:
+;;; 0018:0050 Slice Thickness
+;;; 0028:0030 Pixel Spacing
+;;; 0020:0032 Image Position Patient
+;;; 3006:0050 Contour Data
+;;; Reflected Structure-Set contour Y and Z axes to test matchup.
+;;; 30-Aug-2002 BobGian:
+;;; Compute ORIGIN from X,Y,Z coordinates in 0020:0032 "Image Position
+;;; Patient" rather than from pixel spacing and image dimensions.
+;;; Determine Image-Set from correct slot: 0020:000E "Series Instance UID".
+;;; "New set during association" now works exactly as does initial set
+;;; determination - no need for kludges. Same-ID-different-UID is now
+;;; an error situation (assuming correct image-set identification).
+;;; 31-Aug-2002 BobGian:
+;;; Fix error in sign of X,Y coords for image ORIGIN slot.
+;;; Log count of images stored (may differ from ID of image).
+;;; 17-Sep-2002 BobGian:
+;;; *PRINT-ARRAY* -> T in PUT-OBJECT.
+;;; DICOM-ALIST passed to MISHAP in WRITE-IMAGE-SET, PRISM-STRUCTURE-WRITER,
+;;; and READ-OBJECT for error reporting.
+;;; 23-Sep-2002 BobGian add PAT-POS slot to image - obtained from Dicom
+;;; slot 0018:5100 - and calculate ORIGIN slot components using it.
+;;; It encodes patient positioning as HFS, FFS, HFP, FFP, etc.
+;;; 23-Sep-2002 BobGian modify PAT-POS usage to compute axis orientation.
+;;; 24-Sep-2002 BobGian:
+;;; Remove 3rd arg (DICOM-ALIST) to MISHAP and passage to it via intermediate
+;;; functions. Same functionality now obtainable via special variable.
+;;; 10-Oct-2002 BobGian fix bug in WRITE-IMAGE-SET: image set number was
+;;; not updating to include sets alread written in current association.
+;;; 12-Dec-2002 BobGian temporary fix to PRISM-IMAGE-WRITER to accept
+;;; Decubitus orientations.
+;;; 25-Apr-2003 BobGian:
+;;; Correct information and add additional fields to "structure.index" file
+;;; (was writing incorrect organ name).
+;;; Modify structure-set writer to write all structures, each to separate
+;;; file (was writing only first structure).
+;;; 08-May-2003 BobGian:
+;;; Modify PRISM-STRUCTURE-WRITER to write dispatch on object type
+;;; (ORGAN, TUMOR, or TARGET), based on info in DICOM stream, and to
+;;; write all objects into single structure-set file.
+;;; Add storage of DISPLAY-COLOR to contours and objects in structure-sets.
+;;; PUT-OBJECT does not bind *PRINT-PRETTY*. Outer binding used.
+;;; 15-May-2003 BobGian:
+;;; Re-order items in "structure.index" file record.
+;;; Add object descriptor and type to "pat-xxx.log" file printout.
+;;; 09-Jun-2003 BobGian add separator line at end of "pat-xxx.log" file.
+;;; 27-Aug-2002 BobGian remove IRRAD_VOLUME and TREATED_VOLUME as handled
+;;; structure-set import types (not well-defined objects in Prism).
+;;; 01-Sep-2003 BobGian write information on structure-sets to background
+;;; log file (used to go to special per-patient log file).
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 03-Mar-2004 BobGian: Change filter for 0008:0008 image type - rejects
+;;; LOCALIZER [GE "Scouts"], accepts and writes images of type ORIGINAL
+;;; PRIMARY AXIAL without complaint, and for any other type the server
+;;; logs the type [which may be experimental] and writes the image.
+;;; Added checks for missing or empty header slots [so PDS will not crash
+;;; when handling experimental data, but still preserving consistency checks
+;;; for expected data types].
+;;; 27-Apr-2004 BobGian: Variable split - *STORED-IMAGE-COUNT* ->
+;;; dicom::*STORED-IMAGE-COUNT-PER-SET* [per-image-set count]
+;;; dicom::*STORED-IMAGE-COUNT-CUMULATIVE* [cumulative over association].
+;;; WRITE-IMAGE-SET increments both and resets per-set count only.
+;;; 05-Nov-2004 BobGian - Convert to functional dispatch rather than hard-coded
+;;; function calls for greater modularity. Put this file in PRISM package.
+;;; 11-Mar-2005 BobGian - Changed PRISM-STRUCTURE-WRITER so that a structure
+;;; set of any non-recognized type will be treated as of type ORGAN.
+;;; 15-Mar-2005 BobGian - fix global symbols in wrong package when this file
+;;; was moved DICOM -> PRISM package.
+;;; 24-Aug-2006 I. Kalet change calls to single-float to calls to
+;;; coerce instead for ANSI conformance.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defun write-dicom-output (obj-type dicom-alist)
+
+ (declare (type (member :Image :Structure-Set) obj-type)
+ (type list dicom-alist))
+
+ ;; Format of each item on DICOM-ALIST:
+ ;;
+ ;; ( ( <GroupNum> . <ElemNum> ) <value> <value> ... )
+ ;;
+ ;; ie, CAR is tag pair and CDR is list of values whose length
+ ;; equals value multiplicity.
+
+ ;; 0010,0010 is Patient Name; 0010,0020 is Patient ID.
+ ;; If name/ID missing, use special value and declare this a NON-MATCH.
+ (let ((dicom-pat-name
+ (or (second (assoc '(#x0010 . #x0010) dicom-alist :test #'equal))
+ "*** No Name ***"))
+ (dicom-pat-id
+ (or (second (assoc '(#x0010 . #x0020) dicom-alist :test #'equal))
+ "*** No ID ***")))
+ (declare (type simple-base-string dicom-pat-name dicom-pat-id))
+
+ ;; Determine which Patient ID to use. For images, if we find the unique
+ ;; match, use real Prism Patient ID and write files to the Image Database.
+ ;; If ambiguity arises, construct a new Patient ID and write files to the
+ ;; Unmatched-Pat-Image database. For Structure-Sets, we use only a single
+ ;; directory and do not attempt patient identification.
+ (cond
+ ((eq obj-type :Image)
+ (multiple-value-bind (prism-pat-name prism-pat-id image-output-db)
+ ;; For images, GET-PRISM-PATIENT looks in normal and
+ ;; Unmatched-Pat-Image databases because patient might be
+ ;; identified either in Patient Database from a correct
+ ;; identification or in Unmatched-Pat-Image database from storage
+ ;; of a previously ambiguous identification. It also sets
+ ;; dicom::*CACHED-IMAGE-DB* [and returns it as IMAGE-OUTPUT-DB]
+ ;; as destination of data files.
+ (get-prism-patient dicom-pat-name dicom-pat-id)
+ (declare (type simple-base-string prism-pat-name image-output-db)
+ (type fixnum prism-pat-id))
+ (prism-image-writer prism-pat-name prism-pat-id
+ dicom-alist image-output-db)))
+ ((eq obj-type :Structure-Set)
+ (prism-structure-writer (get-canonical-name dicom-pat-name)
+ dicom-pat-id dicom-alist
+ dicom::*structure-DB*)))))
+
+;;;-------------------------------------------------------------
+;;; When identifying an entry, set variables caching those values so
+;;; same can be used on next data transfer for the same patient.
+
+(defun get-prism-patient (dicom-pat-name dicom-pat-id &aux
+ (prism-pat-id 0) (pat-db dicom::*patient-DB*)
+ (pat-idx-filename "patient.index")
+ (prism-pat-name "") (canonical-name ""))
+
+ (declare (type simple-base-string dicom-pat-name dicom-pat-id
+ canonical-name prism-pat-name pat-db pat-idx-filename)
+ (type fixnum prism-pat-id))
+
+ ;; If name/ID match those cached from the previous association, use them.
+ ;; Case-sensitive string comparison OK since Server set the variable.
+ ;; This branch should be taken on all patient identification attempts
+ ;; after the first.
+ (when (and (string= dicom-pat-name (or dicom::*cached-dicom-pat-name* ""))
+ (string= dicom-pat-id (or dicom::*cached-dicom-pat-ID* "")))
+ (setq prism-pat-id dicom::*cached-prism-pat-ID*)
+ (setq prism-pat-name dicom::*cached-prism-pat-name*)
+ (when (>= (the fixnum dicom::*log-level*) 1)
+ (format t
+ #.(concatenate
+ 'string
+ "~%GET-PRISM-PATIENT [1] Found cached entry:"
+ "~% Patient Name: ~S, Dicom ID: ~S, Prism ID: ~D~%")
+ prism-pat-name dicom-pat-id prism-pat-id))
+ (return-from get-prism-patient
+ (values prism-pat-name prism-pat-id dicom::*cached-image-DB*)))
+
+ ;; Convert DICOM patient name to canonical form against which to match
+ ;; PRISM patient name. If match found, cache original DICOM name.
+ (setq canonical-name (get-canonical-name dicom-pat-name))
+
+ ;; Next, search main Patient Database. GET-INDEX-LIST returns patient list
+ ;; in reverse order -- which is nice, since hits are more likely to occur at
+ ;; the end of the patient index file if they occur at all.
+ (dolist (pat-info (get-index-list
+ (concatenate 'string pat-db pat-idx-filename)))
+ ;; Case-insensitive string comparison used for patient's name.
+ ;; If Prism record matches CANONICAL-NAME from DICOM, use Prism's record
+ ;; as PRISM-PAT-NAME [for logging] and use CANONICAL-NAME as cached value
+ ;; for future comparisons.
+ (when (and (match-name (setq prism-pat-name (second pat-info))
+ canonical-name)
+ (match-id (third pat-info) dicom-pat-id))
+ (setq prism-pat-id (first pat-info))
+ (format t
+ #.(concatenate
+ 'string
+ "~%Patient found in \"~A~A\":"
+ "~% Patient Name: ~S, Dicom ID: ~S, Prism ID: ~D~%")
+ pat-db pat-idx-filename prism-pat-name dicom-pat-id prism-pat-id)
+ (setq dicom::*cached-dicom-pat-name* dicom-pat-name)
+ (setq dicom::*cached-dicom-pat-ID* dicom-pat-id)
+ (setq dicom::*cached-dicom-set-ID* "")
+ (setq dicom::*cached-prism-set-ID* 0)
+ (return-from get-prism-patient
+ (values (setq dicom::*cached-prism-pat-name* prism-pat-name)
+ (setq dicom::*cached-prism-pat-ID* prism-pat-id)
+ (setq dicom::*cached-image-DB*
+ dicom::*matched-pat-image-DB*)))))
+
+ ;; If not there, search the Unmatched-Pat-Image database.
+ (let* ((unmatched-pat-idx-filename
+ (concatenate 'string
+ dicom::*unmatched-pat-image-DB* pat-idx-filename))
+ (unmatched-pat-idx-list (get-index-list unmatched-pat-idx-filename)))
+ (declare (type simple-base-string unmatched-pat-idx-filename)
+ (type list unmatched-pat-idx-list))
+ (do ((new-id 0) (old-id 0)
+ (pts unmatched-pat-idx-list (cdr pts))
+ (pat-info))
+ ((null pts)
+ ;; If NOT found in Unmatched-Pat-Image database, generate a new entry
+ ;; with next available ID number, add entry to Unmatched-Pat-Image
+ ;; database, and cache and return these values.
+ (setq prism-pat-id (the fixnum (1+ new-id)))
+ (format t
+ #.(concatenate
+ 'string
+ "~%Creating entry in Unmatched-Pat-Image DB \"~A~A\":"
+ "~% Patient Name: ~S, Dicom ID: ~S, Prism ID: ~D~%")
+ dicom::*unmatched-pat-image-DB* pat-idx-filename
+ canonical-name dicom-pat-id prism-pat-id)
+ (push (list prism-pat-id canonical-name dicom-pat-id
+ (dicom::date/time) dicom::*remote-IP-string*)
+ unmatched-pat-idx-list)
+ (let ((*print-pretty* nil))
+ (with-open-file (strm unmatched-pat-idx-filename :direction :Output
+ :element-type 'base-char
+ :if-does-not-exist :Create
+ :if-exists :Supersede)
+ (dolist (item (nreverse unmatched-pat-idx-list))
+ (format strm "~S~%" item))))
+ (setq dicom::*cached-dicom-pat-name* dicom-pat-name)
+ (setq dicom::*cached-dicom-pat-ID* dicom-pat-id)
+ (setq dicom::*cached-dicom-set-ID* "")
+ (setq dicom::*cached-prism-set-ID* 0)
+ (values (setq dicom::*cached-prism-pat-name* canonical-name)
+ (setq dicom::*cached-prism-pat-ID* prism-pat-id)
+ (setq dicom::*cached-image-DB*
+ dicom::*unmatched-pat-image-DB*)))
+ (declare (type list pts pat-info)
+ (type fixnum new-id old-id))
+ (setq pat-info (car pts)
+ old-id (first pat-info))
+ (when (< new-id old-id) ;Accumulate max ID seen so far.
+ (setq new-id old-id))
+ ;; If found in Unmatched-Pat-Image database, cache and return values.
+ ;; Case-sensitive string comparisons OK since Server wrote the file.
+ (when (and (string= (second pat-info) canonical-name)
+ (string= (third pat-info) dicom-pat-id))
+ (setq prism-pat-id old-id)
+ (format t
+ #.(concatenate
+ 'string
+ "~%Patient found in Unmatched-Pat-Image DB \"~A~A\":"
+ "~% Patient Name: ~S, Dicom ID: ~S, Prism ID: ~D~%")
+ dicom::*unmatched-pat-image-DB* pat-idx-filename
+ canonical-name dicom-pat-id prism-pat-id)
+ (setq dicom::*cached-dicom-pat-name* dicom-pat-name)
+ (setq dicom::*cached-dicom-pat-ID* dicom-pat-id)
+ (setq dicom::*cached-dicom-set-ID* "")
+ (setq dicom::*cached-prism-set-ID* 0)
+ (return (values (setq dicom::*cached-prism-pat-name* canonical-name)
+ (setq dicom::*cached-prism-pat-ID* prism-pat-id)
+ (setq dicom::*cached-image-DB*
+ dicom::*unmatched-pat-image-DB*)))))))
+
+;;;=============================================================
+;;; Empty strings are returned as NIL from the association list DICOM-ALIST
+;;; rather than as null strings. That way, ASSOC returns NIL rather than
+;;; a null string for empty string slot values, enabling the search to
+;;; continue via the OR.
+;;;
+;;; Server type-checks objects returned by READ-FROM-STRING [in READ-OBJECT]
+;;; so that if a READ error occurs or the incorrect type is returned the
+;;; server can recover gracefully by calling dicom::MISHAP.
+
+(defun prism-image-writer (prism-pat-name prism-pat-id dicom-alist output-db
+ &aux (img-x-dim 0) (img-y-dim 0)
+ (not-supplied "Not Supplied"))
+
+ (declare (type simple-base-string prism-pat-name output-db not-supplied)
+ (type list dicom-alist)
+ (type fixnum prism-pat-id img-x-dim img-y-dim))
+
+ ;; Value multiplicity = 3 - compare against list. String "AXIAL" identifies
+ ;; what we want. Others in this list are usually "ORIGINAL" and "PRIMARY",
+ ;; although if the image is processed by the scanner the string "SECONDARY"
+ ;; can replace "PRIMARY".
+ ;; GE "Scouts" are tagged "LOCALIZER". If present, log reception but ignore
+ ;; image. If any other combination of tags appears, log reception and
+ ;; continue [may be part of an experimental data type].
+ (let ((im-type (cdr (assoc '(#x0008 . #x0008) dicom-alist :test #'equal))))
+ (declare (type list im-type))
+ (when (member "LOCALIZER" im-type :test #'string=)
+ (format t "~& Ignoring LOCALIZER image: ~S~%" im-type)
+ (return-from prism-image-writer nil))
+ (unless (and (member "ORIGINAL" im-type :test #'string=)
+ (member "PRIMARY" im-type :test #'string=)
+ (member "AXIAL" im-type :test #'string=))
+ (format t "~& Non-standard image type: ~S~%" im-type)))
+
+ (setq img-y-dim
+ (second (assoc '(#x0028 . #x0010) dicom-alist :test #'equal)) ;Rows
+ img-x-dim
+ (second (assoc '(#x0028 . #x0011) dicom-alist :test #'equal))) ;Columns
+
+ (let ((im (make-instance 'image-2D)))
+
+ (setf (id im) ;Image Number
+ (read-object
+ (second (assoc '(#x0020 . #x0013) dicom-alist :test #'equal))
+ 'fixnum "Image Number"))
+
+ (setf (uid im) ;SOP Instance UID
+ (or (second (assoc '(#x0008 . #x0018) dicom-alist :test #'equal))
+ not-supplied))
+
+ (do ((strings ;Listed in reverse order here -- reversed by PUSH in loop.
+ (list (second (assoc '(#x0018 . #x1030) ;Protocol Name
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0038 . #x0040) ;Discharge Diagnosis
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0032 . #x1060) ;Requested Procedure
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0018 . #x0039) ;Therapy Description
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0010 . #x21B0) ;Additional Patient History
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x1080) ;Admitting Diagnosis Descrip
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x1030) ;Study Description
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x103E) ;Series Description
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0020 . #x4000) ;Image Comments
+ dicom-alist :test #'equal)))
+ (cdr strings))
+ (accumulator '()))
+ ((null strings)
+ (setf (description im)
+ (cond ((consp accumulator)
+ (apply #'concatenate 'string accumulator))
+ (t not-supplied))))
+ (let ((item (car strings)))
+ (when (and (typep item 'simple-base-string) ;If something to add,
+ ;; and it doesn't duplicate a string already there,
+ (not (member item accumulator :test #'string=)))
+ (when (consp accumulator) ;but accumulator already has something,
+ (push " " accumulator)) ;first separate them with a space,
+ (push item accumulator)))) ;then add new string.
+
+ (setf (acq-date im)
+ (pretty-date
+ (or (second (assoc '(#x0008 . #x0021) ;Series Date
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x0020) ;Study Date
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x0022) ;Acquisition Date
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x0023) ;Image Date
+ dicom-alist :test #'equal))
+ "00000100")))
+
+ (setf (acq-time im)
+ (pretty-time
+ (or (second (assoc '(#x0008 . #x0031) ;Series Time
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x0030) ;Study Time
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x0032) ;Acquisition Time
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x0033) ;Image Time
+ dicom-alist :test #'equal))
+ "000000.0")))
+
+ (setf (scanner-type im)
+ (or (second (assoc '(#x0008 . #x1090) ;Manufacturer Model Name
+ dicom-alist :test #'equal))
+ (second (assoc '(#x0008 . #x0070) ;Manufacturer
+ dicom-alist :test #'equal))
+ not-supplied))
+
+ (setf (hosp-name im)
+ (or (second (assoc '(#x0008 . #x0080) ;Institution Name
+ dicom-alist :test #'equal))
+ not-supplied))
+
+ (setf (img-type im)
+ (or (second (assoc '(#x0008 . #x0060) ;Modality
+ dicom-alist :test #'equal))
+ not-supplied))
+
+ ;; Pixel Spacing: " 3.62323e-01\3.62323e-01" Order: Rows(Y),Cols(X)
+ ;; Value in slot: ( "...Y..." "...X..." ) as two-element list of strings.
+ ;; Value multiplicity = 2: accessing CDR as list of all values.
+ (let ((spacing (cdr (assoc '(#x0028 . #x0030) dicom-alist :test #'equal))))
+ (declare (type list spacing))
+ (when (consp spacing)
+ (let ((x-sz (* (coerce img-x-dim 'single-float)
+ (coerce (read-object (second spacing) 'real
+ "Pixel X Spacing")
+ 'single-float)
+ 0.1)) ;millimeters -> centimeters
+ (y-sz (* (coerce img-y-dim 'single-float)
+ (coerce (read-object (first spacing) 'real
+ "Pixel Y Spacing")
+ 'single-float)
+ 0.1))) ;millimeters -> centimeters
+ (declare (type single-float x-sz y-sz))
+ (setf (size im) (list x-sz y-sz))
+ (setf (pix-per-cm im) (/ (coerce img-x-dim 'single-float) x-sz)))))
+
+ (let ((image-position ;Image Position (Patient) (X, Y, Z)
+ (cdr (assoc '(#x0020 . #x0032) dicom-alist :test #'equal)))
+ (pat-position ;Patient Position ("HFS", "FFS", "HFP", "FFP", etc)
+ (second (assoc '(#x0018 . #x5100) dicom-alist :test #'equal)))
+ (x-multiplier 0.1) (y-multiplier -0.1) (z-multiplier -0.1))
+
+ (declare (type single-float x-multiplier y-multiplier z-multiplier))
+
+ ;; These multipliers convert millimeters -> centimeters and also
+ ;; set axis orientations according to patient position as scanned.
+ ;;
+ ;; HFS (usual): X+, Y-, Z- rel to Prism coords (no reversals).
+ ;; FFS: X+, Y-, Z- rel to Prism coords (no reversals).
+ ;; HFP: X-, Y+, Z- rel to Prism coords (reverse X,Y from default).
+ ;; FFP: X-, Y+, Z- rel to Prism coords (reverse X,Y from default).
+ ;;
+ ;; Prism seems to be "machine-centered" regarding Prone/Supine but
+ ;; "patient-centered" regarding Feet-First/Head-First. Supine image
+ ;; looks up (increasing Y); Prone image looks down (decreasing Y). But
+ ;; FF vs HF images look the same: Z increasing from head toward toe, and
+ ;; X,Y oriented as seen in machine coords looking from toes toward head.
+ ;;
+ ;; Thus the Dicom -> Prism transformations TAKE INTO ACCOUNT Prone vs
+ ;; Supine orientation indication to convert Dicom's patient-centered
+ ;; frame to Prism's machine-centered frame but LEAVE IN PLACE Dicom's
+ ;; patient-centered axis convention vis-a-vis the HF vs FF orientation.
+
+ (cond
+ ((or (consp image-position)
+ (typep pat-position 'simple-base-string))
+ (unless (and (typep pat-position 'simple-base-string)
+ (>= (length (the simple-base-string pat-position)) 3)
+ #+ignore
+ (member pat-position '("HFS" "FFS" "HFP" "FFP")
+ :test #'string=))
+ ;; Temporary fix to accept Decubitus orientations.
+ ;; Dicom slot may also contain "HFDR", "FFDR", "HFDL", or "FFDL",
+ ;; but PDS/Prism cannot use these orientations.
+ (dicom::mishap nil nil
+ "PRISM-IMAGE-WRITER [1] Bad PAT-POS slot: ~S"
+ pat-position))
+ (when (char= (aref (the simple-base-string pat-position) 2) #\P)
+ ;; PRONE rather than SUPINE orientation - reverse X and Y axes.
+ (setq x-multiplier (- x-multiplier) y-multiplier (- y-multiplier)))
+ #+ignore
+ ;; Ignore this transformation - preserve Dicom's patient-centeredness
+ ;; vis-a-vis HF vs FF as per comment above.
+ (when (char= (aref (the simple-base-string pat-position) 0) #\F)
+ ;; FEET-FIRST rather than HEAD-FIRST - reverse X and Z axes.
+ (setq x-multiplier (- x-multiplier) z-multiplier (- z-multiplier)))
+ (setf (pat-pos im) pat-position)
+ (setf (origin im)
+ (vector
+ (* (coerce (read-object (first image-position) 'real
+ "Image X coord")
+ 'single-float)
+ x-multiplier)
+ (* (coerce (read-object (second image-position) 'real
+ "Image Y coord")
+ 'single-float)
+ y-multiplier)
+ (* (coerce (read-object (third image-position) 'real
+ "Image Z coord")
+ 'single-float)
+ z-multiplier))))
+ (t (setf (pat-pos im) not-supplied)
+ (setf (origin im) (vector 0.0 0.0 0.0)))))
+
+ (setf (range im) 4095)
+
+ (setf (units im) "H + 1024")
+
+ ;; (#x0018 . #x0088) is Spacing Between Slices (mm)
+ (let ((spacing (second (assoc '(#x0018 . #x0050) ;Slice Thickness (Z)
+ dicom-alist :test #'equal))))
+ (when (typep spacing 'simple-base-string)
+ (setf (thickness im)
+ (* (coerce (read-object spacing 'real "Slice Thickness")
+ 'single-float)
+ 0.1)))) ;millimeters -> centimeters
+
+ (setf (x-orient im) #(1.000 0.000 0.000))
+
+ (setf (y-orient im) #(0.000 -1.000 0.000))
+
+ (setf (pixels im) ;Pixel Data
+ (second (assoc '(#x7FE0 . #x0010) dicom-alist :test #'equal)))
+
+ (write-image-set
+ prism-pat-name prism-pat-id im
+ img-x-dim img-y-dim output-db ;Series Instance UID
+ (second (assoc '(#x0020 . #x000E) dicom-alist :test #'equal)))))
+
+;;;-------------------------------------------------------------
+
+(defun write-image-set (prism-pat-name prism-pat-id im img-x-dim img-y-dim
+ output-db dicom-set-id &aux (prism-set-id 0))
+
+ "WRITE-IMAGE-SET prism-pat-name prism-pat-id im img-x-dim img-y-dim
+ output-db dicom-set-id
+
+appends image IM to image-set for patient whose ID is PRISM-PAT-ID, or
+creates a new image-set. New images and all image-sets go to OUPTUT-DB."
+
+ (declare (type simple-base-string prism-pat-name output-db dicom-set-id)
+ (type fixnum prism-pat-id img-x-dim img-y-dim prism-set-id))
+
+ (cond
+ ;; If continuing with an already-identified Image Set, use cached values,
+ ;; and conditionally append to already-started Image Set file.
+ ((string= dicom-set-id dicom::*cached-dicom-set-ID*)
+ (setq prism-set-id dicom::*cached-prism-set-ID*))
+
+ ;; Otherwise identify the Image Set and cache the identification.
+ ;; In addition to file itself, must also scan any records pending
+ ;; to be written to it at close of current asssociation.
+ (t (let ((im-set-record dicom::*current-im-set-record*))
+ (declare (type list im-set-record))
+ (when (consp dicom::*image-ID/UID-alist*)
+ (format t "~&Stored ~D images in this set.~%"
+ dicom::*stored-image-count-per-set*)
+ (setq dicom::*image-ID/UID-alist* nil)
+ ;; If current "image.index" file record [for Image-Set that just
+ ;; finished, since current image is first of next set] is a new one,
+ ;; update it with number of images in that set. This can happen
+ ;; only if dicom::*NEW-IM-INDEX-RECORDS* is non-NIL. If that record
+ ;; was already in the "image.index" file, do NOT update it, as this
+ ;; would screw up the comment string in the file.
+ (when (consp im-set-record)
+ (setf (fourth im-set-record)
+ (format nil "Set ~D (~D images): ~A"
+ (third im-set-record)
+ dicom::*stored-image-count-per-set*
+ (fourth im-set-record))))))
+
+ ;; Initialize count of images stored in current set.
+ (setq dicom::*stored-image-count-per-set* 0)
+
+ (let ((image-set-idx-filename
+ (concatenate 'string output-db "image.index")))
+ (declare (type simple-base-string image-set-idx-filename))
+
+ (with-open-file (strm image-set-idx-filename
+ :direction :input
+ :element-type 'base-char
+ :if-does-not-exist nil)
+ ;; If no file, OPEN returns NIL, IMAGE-SET-RECORD gets NIL,
+ ;; and iteration ends immediately.
+ (do ((image-set-record (and strm (read strm nil nil))
+ (and strm (read strm nil nil))))
+ ((null image-set-record)
+
+ ;; If new sets have been written, new Image Index records
+ ;; await appending to index file. Set PRISM-SET-ID to highest
+ ;; value so far [used for last set written] before incrementing
+ ;; to get upcoming set's index number.
+ (let ((im-index-records dicom::*new-im-index-records*))
+ (declare (type list im-index-records))
+ (when (consp im-index-records)
+ (setq prism-set-id (third (car im-index-records)))))
+
+ ;; Creating new Image Set. Assign next available index number.
+ (setq prism-set-id (the fixnum (1+ prism-set-id)))
+ (format t
+ #.(concatenate
+ 'string
+ "~%Creating Image Set in ~S:~% Patient Name: ~S,"
+ " Patient ID: ~D, Image-Set ID: ~D~%")
+ dicom::*cached-image-DB*
+ prism-pat-name prism-pat-id prism-set-id)
+ ;; Record identifying new image set is cached for writing to
+ ;; "image.index" file at conclusion of successful association.
+ ;; Record itself is the CDR of this list. CAR of it is the
+ ;; filename to which to write the record.
+ ;; Image-Set-ID is included in Image Index file because
+ ;; sometimes description strings for different sets are
+ ;; identical, making it hard for user to tell them apart.
+ (push (setq dicom::*current-im-set-record*
+ (list image-set-idx-filename
+ prism-pat-id prism-set-id
+ (description im)
+ dicom-set-id dicom::*remote-IP-string*))
+ dicom::*new-im-index-records*))
+
+ ;; DICOM-SET-ID is a string and so is corresponding field of the
+ ;; index file if Server wrote the file. However, patients scanned
+ ;; before Server was used have this field missing in index file
+ ;; records, yielding NIL as the (FOURTH IMAGE-SET-RECORD) result.
+ ;; Thus the need for (OR (FOURTH IMAGE-SET-RECORD) "") to
+ ;; "stringify" the NIL. This will work on new cases and will
+ ;; cause first transmissions for old cases to be considered fresh
+ ;; Image Sets [most likely what is intended]. Later, as Server
+ ;; appends a record with all five fields, Image Set entry will
+ ;; match on both the Prism-Pat-ID and the Dicom-Set-ID fields.
+ ;; Note that comparisons on fourth field of IMAGE-SET-RECORD
+ ;; [the DICOM Image Set UID] are done only if the first field
+ ;; [the Prism Patient ID] matches PRISM-PAT-ID, so that Image Set
+ ;; counts FOR THIS PATIENT ONLY get accumulated.
+ (cond
+ ((/= prism-pat-id (the fixnum (first image-set-record))))
+ ((string= (or (fourth image-set-record) "") dicom-set-id)
+ ;; Identified existing Image Set -- may append or overwrite.
+ (setq prism-set-id (second image-set-record))
+ (format t
+ #.(concatenate
+ 'string
+ "~%Appending Image Set in ~S:~%"
+ " Patient Name: ~S, Patient ID: ~D,"
+ " Image-Set ID: ~D~%")
+ dicom::*cached-image-DB*
+ prism-pat-name prism-pat-id prism-set-id)
+ ;; Appending to an existing Image-Set. Do NOT muck with
+ ;; description string already written to "image.index" file.
+ (setq dicom::*current-im-set-record* nil)
+ (return))
+ ;; Accumulate maximum set index so far.
+ (t (setq prism-set-id
+ (max prism-set-id
+ (the fixnum (second image-set-record)))))))))
+
+ (setq dicom::*cached-dicom-set-ID* dicom-set-id
+ dicom::*cached-prism-set-ID* prism-set-id)))
+
+ (setf (patient-id im) prism-pat-id)
+ (setf (image-set-id im) prism-set-id)
+
+ (let ((pixarray-filename
+ (format nil "pat-~D.image-~D-~D"
+ prism-pat-id prism-set-id (id im)))
+ (ID/UID-alist dicom::*image-ID/UID-alist*)
+ (image-id (id im)) (image-uid (uid im)) pair
+ (im-set-filename
+ (format nil "~Apat-~D.image-set-~D"
+ output-db prism-pat-id prism-set-id)))
+
+ (declare (type simple-base-string pixarray-filename im-set-filename
+ image-uid)
+ (type list ID/UID-alist)
+ (type fixnum image-id))
+
+ (unless (consp ID/UID-alist)
+ ;; If no images yet recorded on this association, read and cache Alist
+ ;; of any ID/UIDs for images already stored in current Image Set from
+ ;; previous association(s). If no such images stored, Image Set file
+ ;; will not exist - cached Alist will be NIL.
+ ;; When appending to existing image set, count of images stored will
+ ;; include those already written when new appending begins.
+ (when (probe-file im-set-filename)
+ (with-open-file (strm im-set-filename
+ :direction :Input
+ :element-type 'base-char)
+ (do ((item (read strm nil :EOF) (read strm nil :EOF))
+ (prior-id nil) (prior-uid nil))
+ ((eq item :EOF))
+ (when (eq item 'id)
+ (setq prior-id (read strm nil :EOF)))
+ (when (eq item 'uid)
+ (setq prior-uid (read strm nil :EOF)))
+ ;; When end of record for a given image is reached,
+ ;; store results and reset vars used to accumulate results.
+ (when (and (eq item :End)
+ (typep prior-id 'fixnum)
+ (typep prior-uid 'simple-base-string))
+ (push (cons prior-id prior-uid) ID/UID-alist)
+ (setq prior-id nil prior-uid nil))))
+ (setq dicom::*image-ID/UID-alist* ID/UID-alist)))
+
+ ;; Test whether image is a duplicate [image ID/UID pair already on Alist]
+ ;; or the beginning of a new Image Set [ID/UID pair on Alist with same ID
+ ;; but different UID]. If continuation of current Set, output it to same
+ ;; Set. If duplicate, print message and ignore it. If new Set, update
+ ;; image object and output it to new Set by resetting cached variables and
+ ;; calling this function recursively.
+ (cond
+ ;; Image is new to current Image Set - write to output database.
+ ((null (setq pair (assoc image-id ID/UID-alist :test #'equal)))
+ ;; Note that image counts are incremented if an image file is actually
+ ;; written [ie, not a duplicate], and dicom::*IMAGE-ID/UID-ALIST*
+ ;; is extended. But dicom::*IMAGE-ID/UID-ALIST* also contains records
+ ;; for images written previously [ie, current duplicates], gotten from
+ ;; the image-set file.
+ (format t "~& Received image ~D: ~S, ~A.~%"
+ (incf (the fixnum dicom::*stored-image-count-per-set*))
+ pixarray-filename (pat-pos im))
+ (incf (the fixnum dicom::*stored-image-count-cumulative*))
+ (with-open-file (strm (concatenate 'string output-db pixarray-filename)
+ :direction :Output
+ :element-type '(unsigned-byte 8)
+ :if-does-not-exist :Create
+ :if-exists :Supersede)
+ (write-sequence (pixels im) strm))
+ ;; Append ID/UID of image just stored to Alist.
+ (setq dicom::*image-ID/UID-alist* (cons (cons image-id image-uid)
+ ID/UID-alist))
+ ;; Append record to Image Set file. This operation is done last so
+ ;; record will NOT be appended to Image Set file until image file
+ ;; itself has been stored successfully.
+ (with-open-file (strm im-set-filename :direction :Output
+ :element-type 'base-char
+ :if-does-not-exist :Create :if-exists :Append)
+ ;; *PRINT-ARRAY* must be T because ORIGIN slot value is an array,
+ ;; and we must print its slot values to the Image Set file.
+ (let ((*print-array* t))
+ (put-object im strm 0 pixarray-filename img-x-dim img-y-dim))))
+
+ ;; Duplicate - log that fact, but don't write image.
+ ((string= image-uid (cdr pair))
+ (format t "~& Received image: ~S, duplicate.~%" pixarray-filename))
+
+ ;; Same ID but different image UID on same Image-Set: error.
+ (t (dicom::mishap nil nil
+ "WRITE-IMAGE-SET [1] Bad image set UID: ~S ~S ~S"
+ prism-pat-name prism-pat-id dicom-set-id)))))
+
+;;;=============================================================
+
+(defun prism-structure-writer (canonical-name dicom-pat-id dicom-alist
+ output-db &aux (prism-pat-id 0)
+ (structure-idx-filename
+ (concatenate 'string
+ output-db "structure.index"))
+ (structure-list '()) (skipped-item-list '()))
+
+ (declare (type simple-base-string canonical-name dicom-pat-id output-db
+ structure-idx-filename)
+ (type list dicom-alist structure-list skipped-item-list)
+ (type fixnum prism-pat-id))
+
+ ;; This is a debugging hook to detect slot 3006:0045 "Contour Offset Vector",
+ ;; which indicates an offset of structure-set contour from the corresponding
+ ;; image. If missing, offset is specified to be zero. We have yet to see a
+ ;; value in this slot, but it might exist for other clients.
+ (let ((offset (assoc '(#x3006 . #x0045) dicom-alist :test #'equal)))
+ (when (consp offset)
+ (format t "~&Offset vector: ~S~%" offset)))
+
+ (when (probe-file structure-idx-filename)
+ (with-open-file (strm structure-idx-filename
+ :direction :Input :element-type 'base-char)
+ (do ((item (read strm nil :EOF) (read strm nil :EOF)))
+ ((eq item :EOF))
+ (let ((idx (first item)))
+ (declare (type fixnum idx))
+ (when (> idx prism-pat-id)
+ (setq prism-pat-id idx))))))
+
+ (do ((ss-roi-sequence ;Structure Set ROI Sequence
+ (cdr (assoc '(#x3006 . #x0020) dicom-alist :test #'equal))
+ (cdr ss-roi-sequence))
+ (roi-contour-sequence ;ROI Contour Sequence
+ (cdr (assoc '(#x3006 . #x0039) dicom-alist :test #'equal))
+ (cdr roi-contour-sequence))
+ (observation-sequence ;RT ROI Observations Sequence
+ (cdr (assoc '(#x3006 . #x0080) dicom-alist :test #'equal))
+ (cdr observation-sequence))
+ (obj-descriptor "") (obj-name "") (obj-type) (obj-itself))
+ ((null roi-contour-sequence))
+
+ (declare (type simple-base-string obj-descriptor obj-name)
+ (type list ss-roi-sequence roi-contour-sequence
+ observation-sequence))
+
+ (setq obj-name
+ (or (second (assoc '(#x3006 . #x0026) (car ss-roi-sequence)
+ :test #'equal)) ;ROI Name
+ (second (assoc '(#x3006 . #x0085) (car observation-sequence)
+ :test #'equal)) ;ROI Observation Label
+ "No object name"))
+
+ (setq obj-descriptor ;RT ROI Interpreted Type
+ (second (assoc '(#x3006 . #x00A4)
+ (car observation-sequence)
+ :test #'equal)))
+
+ (setq obj-type
+ (or (cdr (assoc obj-descriptor
+ '(("ORGAN" . ORGAN) ;All Prism-defined types.
+ ("EXTERNAL" . ORGAN)
+ ("AVOIDANCE" . ORGAN)
+ ("GTV" . TUMOR)
+ ("PTV" . TARGET)
+ ("CTV" . TARGET))
+ :test #'STRING=))
+ ;; Default for missing or incorrectly-specified data.
+ 'ORGAN))
+
+ (setq obj-itself (make-instance obj-type))
+
+ (setf (name obj-itself) obj-name)
+
+ (let ((contour-list '()) ;ROI Display Color
+ (roi-color (get-color (cdr (assoc '(#x3006 . #x002A)
+ (car roi-contour-sequence)
+ :test #'equal)))))
+
+ (declare (type list contour-list)
+ (type symbol roi-color))
+
+ ;;Set DISPLAY-COLOR of ORGAN, TUMOR, or TARGET
+ (setf (display-color obj-itself) roi-color)
+
+ (dolist (contour-alist ;Contour Sequence
+ (cdr (assoc '(#x3006 . #x0040) (car roi-contour-sequence)
+ :test #'equal)))
+ (declare (type list contour-alist))
+ (let ((contour-obj (make-instance 'contour))
+ (contour-data (cdr (assoc '(#x3006 . #x0050) contour-alist
+ :test #'equal)))) ;Contour Data
+ (declare (type list contour-data))
+ ;; CONTOUR-DATA: ( X1 Y1 Z1 X2 Y2 Z2 ... Xn Yn Zn )
+ ;; where all Zi should be same value.
+ (unless (= (length contour-data)
+ (the fixnum
+ (* (the fixnum
+ (read-object ;Number of Contour Points
+ (second (assoc '(#x3006 . #x0046)
+ contour-alist :test #'equal))
+ 'fixnum "Number of Contour Points"))
+ 3)))
+ (dicom::mishap nil contour-alist
+ "PRISM-STRUCTURE-WRITER [1] Bad vertices list."))
+
+ ;; Multiplication by 0.1 is for MM -> CM conversion.
+ ;; Have to do equivalent axis orientation business as we do for
+ ;; images using PAT-POS slot. Have to look up slot value for
+ ;; image associated with current structure-set.
+ (setf (z contour-obj) ;Z coordinate of first vertex
+ (* (coerce (read-object (third contour-data) 'real "Z")
+ 'single-float)
+ -0.1))
+ (do ((itemlist contour-data (cdddr itemlist))
+ (vert-list '()))
+ ((null itemlist)
+ (setf (vertices contour-obj) (nreverse vert-list)))
+ (push (list (* (coerce (read-object (first itemlist) 'real "X")
+ 'single-float)
+ 0.1)
+ (* (coerce (read-object (second itemlist) 'real "Y")
+ 'single-float)
+ -0.1))
+ vert-list))
+
+ ;; Set DISPLAY-COLOR of CONTOUR.
+ (setf (display-color contour-obj) roi-color)
+
+ (push contour-obj contour-list)))
+
+ (cond ((consp contour-list)
+ (setf (contours obj-itself) (nreverse contour-list))
+ (push (list obj-itself obj-descriptor obj-type)
+ structure-list))
+ (t (push (list obj-name obj-descriptor) skipped-item-list)))))
+
+ ;; Increment PRISM-PAT-ID since we always write a new Structure-Set.
+ (incf (the fixnum prism-pat-id))
+ (setq structure-list (nreverse structure-list))
+
+ (let ((plan-name
+ (or
+ ;; Structure Set Label
+ (second (assoc '(#x3006 . #x0004) dicom-alist :test #'equal))
+ ;; Structure Set Name
+ (second (assoc '(#x3006 . #x0002) dicom-alist :test #'equal))
+ "No plan name"))
+ (plan-date
+ (pretty-date
+ (or
+ ;; Structure Set Date
+ (second (assoc '(#x3006 . #x0008) dicom-alist :test #'equal))
+ ;; Instance Creation Date
+ (second (assoc '(#x0008 . #x0012) dicom-alist :test #'equal))
+ ;; Series Date
+ (second (assoc '(#x0008 . #x0021) dicom-alist :test #'equal))
+ ;; Study Date
+ (second (assoc '(#x0008 . #x0020) dicom-alist :test #'equal))
+ ;; Acquisition Date
+ (second (assoc '(#x0008 . #x0022) dicom-alist :test #'equal))
+ "00000100")))
+ (plan-time
+ (pretty-time
+ (or
+ ;; Structure Set Time
+ (second (assoc '(#x3006 . #x0009) dicom-alist :test #'equal))
+ ;; Instance Creation Time
+ (second (assoc '(#x0008 . #x0013) dicom-alist :test #'equal))
+ ;; Series Time
+ (second (assoc '(#x0008 . #x0031) dicom-alist :test #'equal))
+ ;; Study Time
+ (second (assoc '(#x0008 . #x0030) dicom-alist :test #'equal))
+ ;; Acquisition Time
+ (second (assoc '(#x0008 . #x0032) dicom-alist :test #'equal))
+ "000000.0"))))
+
+ (declare (type simple-base-string plan-name plan-date plan-time))
+
+ ;; Write information on structure-sets to regular log file.
+ (format t "~%Writing structure-sets: ~D actual, ~D empty structures,~%"
+ (length structure-list)
+ (length skipped-item-list))
+
+ (format t "~%Patient Name: ~S~%" canonical-name)
+ (format t "Hospital ID: ~S~%" dicom-pat-id)
+ (format t "Structure-set ID: ~D~%" prism-pat-id)
+ (format t "Plan Name: ~S~%" plan-name)
+ (format t "Plan Date: ~S~%" plan-date)
+ (format t "Plan Time: ~S~%~%" plan-time)
+ (dolist (item structure-list)
+ (format t "Actual structure: ~S, Sent type: ~A, Import type: ~A~%"
+ (name (first item)) (second item) (third item)))
+ (when (consp skipped-item-list)
+ (dolist (item (nreverse skipped-item-list))
+ (format t "Skipped structure: ~S, Sent type: ~A, (no contours)~%"
+ (first item) (second item))))
+ (format t "~%")
+
+ (when (consp structure-list)
+ ;; NB: Write Structure-Set data file before updating index file.
+ ;; This prevents Prism access before data is ready.
+ ;; Note that the structure index file is written [and therefore, a
+ ;; patient index number assigned when file later is read] only if we
+ ;; write non-empty structure-sets. We ignore empty structure-sets;
+ ;; we write no structure-set data file, and we make no entry in the
+ ;; structure-set index file for them.
+ (let ((structure-set-filename
+ (format nil "~Apat-~D.structure-set" output-db prism-pat-id)))
+ (declare (type simple-base-string structure-set-filename))
+ (format t "Writing structure-data file: ~S (~D structures)~%"
+ structure-set-filename (length structure-list))
+ (with-open-file (strm structure-set-filename :direction :Output
+ :element-type 'base-char
+ :if-does-not-exist :Create :if-exists :Append)
+ (dolist (item structure-list)
+ (put-object (first item) strm 4)))) ;*PRINT-PRETTY* is T here.
+ (let ((*print-pretty* nil))
+ (with-open-file (strm structure-idx-filename :direction :Output
+ :element-type 'base-char
+ :if-does-not-exist :Create :if-exists :Append)
+ (format strm "(~D ~S ~S ~S ~S ~S ~S)~%"
+ prism-pat-id
+ canonical-name
+ dicom-pat-id
+ plan-date
+ plan-time
+ plan-name
+ (format nil "~A"
+ (or (mapcar #'(lambda (x)
+ (name (first x)))
+ structure-list)
+ "No structures"))))))))
+
+;;;=============================================================
+;;; Utility functions used in main functions above.
+
+(defun get-canonical-name (dicom-pat-name)
+ (declare (type simple-base-string dicom-pat-name))
+ (let ((caret-pos (position #\^ dicom-pat-name :test #'char=)))
+ (cond
+ ((typep caret-pos 'fixnum)
+ (do* ((name
+ (format nil "~A, ~A"
+ (string-capitalize (subseq dicom-pat-name 0 caret-pos))
+ (string-right-trim
+ "^"
+ (string-capitalize
+ (subseq
+ dicom-pat-name
+ (the fixnum (1+ (the fixnum caret-pos))))))))
+ (len (length name))
+ (idx 0 (the fixnum (1+ idx))))
+ ((= idx len)
+ name)
+ (declare (type simple-base-string name)
+ (type fixnum len idx))
+ (when (char= (aref name idx) #\^)
+ (setf (aref name idx) #\Space))))
+ (t dicom-pat-name))))
+
+;;;-------------------------------------------------------------
+
+(defun match-name (name1 name2)
+ ;; Compares names character-by-character, case-insensitively,
+ ;; ignoring non-alphabetic characters.
+ (declare (type simple-base-string name1 name2))
+
+ (cond ((string= name2 "*** No Name ***")
+ ;; Special "missing name" tag indicates automatic mismatch.
+ nil)
+
+ (t (do ((limit1 (length name1))
+ (limit2 (length name2))
+ (p1 0) (p2 0) (ch1) (ch2))
+ ((and (= p1 limit1) (= p2 limit2))
+ t)
+ (declare (type fixnum limit1 limit2 p1 p2))
+ (setq ch1 (and (< p1 limit1) (aref name1 p1))
+ ch2 (and (< p2 limit2) (aref name2 p2)))
+ (cond ((and (characterp ch1)
+ (characterp ch2)
+ (char-equal ch1 ch2))
+ (setq p1 (the fixnum (1+ p1)))
+ (setq p2 (the fixnum (1+ p2))))
+ ((and (characterp ch1)
+ (not (alpha-char-p ch1)))
+ (setq p1 (the fixnum (1+ p1))))
+ ((and (characterp ch2)
+ (not (alpha-char-p ch2)))
+ (setq p2 (the fixnum (1+ p2))))
+ (t (return nil)))))))
+
+;;;-------------------------------------------------------------
+
+(defun match-id (id1 id2)
+ ;; Compares IDs character-by-character, ignoring non-digit characters.
+ (declare (type simple-base-string id1 id2))
+
+ (cond ((string= id2 "*** No ID ***")
+ ;; Special "missing ID" tag indicates automatic mismatch.
+ nil)
+
+ (t (do ((limit1 (length id1))
+ (limit2 (length id2))
+ (p1 0) (p2 0) (ch1) (ch2))
+ ((and (= p1 limit1) (= p2 limit2))
+ t)
+ (declare (type fixnum limit1 limit2 p1 p2))
+ (setq ch1 (and (< p1 limit1) (aref id1 p1))
+ ch2 (and (< p2 limit2) (aref id2 p2)))
+ (cond ((and (characterp ch1)
+ (characterp ch2)
+ (char= ch1 ch2))
+ (setq p1 (the fixnum (1+ p1)))
+ (setq p2 (the fixnum (1+ p2))))
+ ((and (characterp ch1)
+ (not (digit-char-p ch1)))
+ (setq p1 (the fixnum (1+ p1))))
+ ((and (characterp ch2)
+ (not (digit-char-p ch2)))
+ (setq p2 (the fixnum (1+ p2))))
+ (t (return nil)))))))
+
+;;;-------------------------------------------------------------
+
+(defun get-index-list (filename &aux (file-entries '()))
+
+ "GET-INDEX-LIST filename
+
+returns a list of lists, each one containing data about one database entry,
+a patient or an image study, from an index file. The returned list is in
+reverse order of the entries in the file."
+
+ (declare (type list file-entries))
+
+ (ignore-errors
+ (with-open-file (strm filename :direction :Input
+ :element-type 'base-char
+ :if-does-not-exist nil)
+ (when (streamp strm)
+ (do ((entry (read strm nil :EOF) (read strm nil :EOF)))
+ ((eq entry :EOF))
+ (push entry file-entries))))
+
+ file-entries))
+
+;;;-------------------------------------------------------------
+
+(defun get-color (rgb-list)
+
+ (declare (type list rgb-list))
+
+ (let ((red? (string/= (first rgb-list) "0"))
+ (green? (string/= (second rgb-list) "0"))
+ (blue? (string/= (third rgb-list) "0")))
+
+ (declare (type (or null fixnum) red? green? blue?))
+
+ (cond ((and red? green?)
+ (if blue? 'sl:white 'sl:yellow))
+ ((and red? (not green?))
+ (if blue? 'sl:magenta 'sl:red))
+ ((and (not red?) green?)
+ (if blue? 'sl:cyan 'sl:green))
+ (t (if blue? 'sl:blue 'sl:gray)))))
+
+;;;-------------------------------------------------------------
+;;; Read an object of type OBJ-TYPE from an arbirary string with
+;;; error catching, type-checking, and graceful recovery.
+
+(defun read-object (data-string obj-type situation)
+
+ (declare (type symbol obj-type)
+ (type simple-base-string situation))
+
+ (unless (typep data-string 'simple-base-string)
+ (dicom::mishap nil nil
+ #.(concatenate
+ 'string
+ "READ-OBJECT [1] Expected ~S and got empty"
+ " slot~% while reading ~A. Aborting Association.")
+ obj-type situation))
+
+ (multiple-value-bind (obj-itself msg)
+ (ignore-errors
+ (read-from-string data-string))
+
+ (cond ((typep msg 'condition)
+ (format t "~%READ-OBJECT [2] Error reading ~A:~%~%" situation)
+ (describe msg)
+ (dicom::mishap nil nil "Aborting Association."))
+
+ ((typep obj-itself obj-type)
+ obj-itself)
+
+ (t (dicom::mishap
+ nil nil
+ #.(concatenate 'string
+ "READ-OBJECT [3] Expected ~S and got ~S, ~S,~%"
+ " while reading ~A. Aborting Association.")
+ obj-type
+ (type-of obj-itself)
+ obj-itself
+ situation)))))
+
+;;;-------------------------------------------------------------
+
+(defun put-object (obj-itself strm tab &rest bin-file-data
+ &aux (tab+2 (the fixnum (+ tab 2)))
+ (tab+4 (the fixnum (+ tab 4))))
+
+ "PUT-OBJECT obj-itself strm tab
+
+writes a printed representation of object OBJ-ITSELF to the stream STRM,
+in a form suitable to be read in by GET-OBJECT."
+
+ (declare (type list bin-file-data)
+ (type fixnum tab tab+2 tab+4))
+
+ (tab-print (class-name (class-of obj-itself)) strm tab t)
+
+ (dolist (slotname (mapcar #'clos:slot-definition-name
+ (clos:class-slots (class-of obj-itself))))
+ (when (slot-boundp obj-itself slotname)
+ (tab-print slotname strm tab+2 nil)
+ (cond ((eq slotname 'pixels)
+ (tab-print bin-file-data strm 0 t))
+ ((eq slotname 'contours)
+ (fresh-line strm)
+ (dolist (obj (slot-value obj-itself slotname))
+ (put-object obj strm tab+4))
+ (tab-print :end strm tab+2 t))
+ (t (tab-print (slot-value obj-itself slotname) strm 0 t)))))
+
+ (tab-print :end strm tab t)) ; terminates object
+
+;;;-------------------------------------------------------------
+
+(defun tab-print (item strm tab cr?)
+
+ "TAB-PRINT item strm tab? cr?
+
+Given an item, a stream, an indentation value (integer),
+and a Return flag (T or NIL), prints the item."
+
+ (declare (type (member nil t) cr?)
+ (type fixnum tab))
+
+ (format strm "~A~S "
+ (cond ((= tab 0) "")
+ (t (make-string tab :initial-element #\Space)))
+ item)
+
+ (when cr? (format strm "~%")))
+
+;;;-------------------------------------------------------------
+;;; Convert "19950608" to "Jun 08 1995".
+
+(defun pretty-date (data)
+ (declare (type simple-base-string data))
+ (format nil "~A ~A ~A"
+ (nth (1- (read-from-string data nil nil :start 4 :end 6))
+ '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+ (subseq data 6 8)
+ (subseq data 0 4)))
+
+;;;-------------------------------------------------------------
+;;; Convert "133132.0" to "13:31:32".
+
+(defun pretty-time (data)
+ (declare (type simple-base-string data))
+ (format nil "~A:~A:~A"
+ (subseq data 0 2)
+ (subseq data 2 4)
+ (subseq data 4 6)))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/start-dicom b/dicom/src/start-dicom
new file mode 100644
index 0000000..977c5b2
--- /dev/null
+++ b/dicom/src/start-dicom
@@ -0,0 +1,27 @@
+#! /bin/tcsh -f
+#
+# start-dicom
+# Script to start Prism DICOM server.
+#
+# 09-Nov-2003 BobGian: add banner printout before startup.
+# 03-Mar-2004 BobGian: parameterize image file [optional argument].
+#
+
+if ( "$1" == "" ) then
+ set IMAGEFILE=dicom.dxl
+else
+ set IMAGEFILE=$1
+endif
+
+umask 117
+echo '' >> /prismdata/pds.log
+echo 'Starting PDS ...' >> /prismdata/pds.log
+date >> /prismdata/pds.log
+ls -ls /radonc/prism/$IMAGEFILE >> /prismdata/pds.log
+echo '' >> /prismdata/pds.log
+
+nohup /usr/local/acl62/alisp8 -I /radonc/prism/$IMAGEFILE >> /prismdata/pds.log &
+sleep 2
+chmod 644 /prismdata/pds.log
+
+# End.
diff --git a/dicom/src/state-rules.cl b/dicom/src/state-rules.cl
new file mode 100644
index 0000000..dc57a0c
--- /dev/null
+++ b/dicom/src/state-rules.cl
@@ -0,0 +1,228 @@
+;;;
+;;; state-rules
+;;;
+;;; DICOM Upper-Layer Protocol State Transition Table.
+;;; Contains declarations common to Client and Server.
+;;;
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; DUL State Machine transition table.
+
+(defparameter *State-Rule-List*
+ `(
+ ;;---------------------------------------------
+ (state-01
+ "Awaiting establishment of connection"
+ ((event-01) ae-01 state-04) ;SCU only
+ ((event-05) ae-05 state-02)) ;SCP only
+
+ ;;---------------------------------------------
+ (state-02 ;SCP only
+ "Connection open and awaiting A-Associate-RQ PDU"
+ ((event-06) ae-06 state-03)
+ ((event-15) aa-01 state-13) ;Added as error escape
+ ((event-16 event-18) nil nil)
+ ((event-17) nil nil)
+ ((event-03 event-04 event-10 event-12B event-13 event-19)
+ aa-01 state-13))
+
+ ;;---------------------------------------------
+ (state-03 ;SCP only
+ "Awaiting A-Associate response from local process"
+ ((event-07) ae-07 state-06)
+ ((event-08) ae-08 state-13) ;Extra args passed to AE-08
+ ((event-15 event-18) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-03 event-04 event-06 event-10 event-12B event-13 event-19)
+ aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-04 ;SCU only
+ "Awaiting connection to complete"
+ ((event-02) ae-02 state-05)
+ ((event-15 event-18) nil nil)
+ ((event-17) aa-04 nil))
+
+ ;;---------------------------------------------
+ (state-05 ;SCU only
+ "Awaiting A-Associate-AC or A-Associate-RJ PDU"
+ ((event-03) ae-03 state-06)
+ ((event-04) ae-04 nil)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-06 event-10 event-12A event-13 event-19) aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-06
+ "Association established and ready for Data Transfer"
+ ((event-09) dt-01 state-06) ;SCU only
+ ((event-10) dt-02 state-06)
+ ((event-11) ar-01 state-07) ;SCU only
+ ((event-12A event-12B) ar-02 state-08)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-03 event-04 event-06 event-13 event-19) aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-07 ;SCU only
+ "Awaiting A-Release-RSP PDU"
+ ;; P-Data-TF PDUs may arrive out of order here.
+ ((event-10) ar-06 state-07)
+ ((event-12A) ar-08 state-09)
+ ((event-12B) ar-08 state-10) ;If STATE-07 is SCU only, what is this?
+ ((event-13) ar-03 nil)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-03 event-04 event-06 event-19) aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-08 ;SCP only
+ "Awaiting A-Release response from local process"
+ ((event-09) ar-07 state-08) ;Currently not signaled
+ ((event-14) ar-04 state-13)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-03 event-04 event-06 event-10 event-12A event-12B
+ event-13 event-19)
+ aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-09 ;SCU only
+ "Awaiting A-Release response from local process"
+ ((event-14) ar-09 state-11)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-03 event-04 event-06 event-10 event-12A event-13 event-19)
+ aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-10 ;SCP only
+ "Awaiting A-Release-RSP PDU"
+ ((event-13) ar-10 state-12)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-03 event-04 event-06 event-10 event-12B) aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-11 ;SCU only
+ "Awaiting A-Release-RSP PDU"
+ ((event-13) ar-03 nil)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-03 event-04 event-06 event-10 event-12A event-19)
+ aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-12 ;SCP only
+ "Awaiting A-Release response from local process"
+ ((event-14) ar-04 state-13)
+ ((event-15) aa-01 state-13)
+ ((event-16) aa-03 nil)
+ ((event-17) aa-04 nil)
+ ((event-18) aa-02 nil)
+ ((event-03 event-04 event-06 event-10 event-12B event-13 event-19)
+ aa-08 state-13))
+
+ ;;---------------------------------------------
+ (state-13
+ "Waiting for connection to close"
+ ((event-06) aa-07A state-13)
+ ;; Event-15 added as error escape
+ ((event-15 event-16 event-17 event-18) nil nil)
+ ((event-19) aa-07B state-13)
+ ((event-03 event-04 event-10 event-12A event-12B event-13)
+ aa-06 state-13))
+
+ ;;---------------------------------------------
+ ))
+
+;;;=============================================================
+;;; Event Documentation.
+
+(eval-when (EVAL LOAD)
+ (setf (get 'event-01 'documentation) "A-Associate Request")
+ (setf (get 'event-02 'documentation) "Outgoing Connection Opened")
+ (setf (get 'event-03 'documentation) "A-Associate-AC PDU Received")
+ (setf (get 'event-04 'documentation) "A-Associate-RJ PDU Received")
+ (setf (get 'event-05 'documentation) "Incoming Connection Accepted")
+ (setf (get 'event-06 'documentation) "A-Associate-RQ PDU Received")
+ (setf (get 'event-07 'documentation) "A-Associate response -- ACCEPT")
+ (setf (get 'event-08 'documentation) "A-Associate response -- REJECT")
+ (setf (get 'event-09 'documentation) "P-Data Request Primitive")
+ (setf (get 'event-10 'documentation) "P-Data-TF PDU Received")
+ (setf (get 'event-11 'documentation) "A-Release Request Primitive")
+ (setf (get 'event-12A 'documentation) "A-Release-RQ PDU Rcvd by SCU")
+ (setf (get 'event-12B 'documentation) "A-Release-RQ PDU Rcvd by SCP")
+ (setf (get 'event-13 'documentation) "A-Release-RSP PDU Received")
+ (setf (get 'event-14 'documentation) "A-Release Response Primitive")
+ (setf (get 'event-15 'documentation) "A-Abort Request Primitive")
+ (setf (get 'event-16 'documentation) "A-Abort PDU Received")
+ (setf (get 'event-17 'documentation) "Connection Closed")
+ (setf (get 'event-18 'documentation) "ARTIM Timer Expired")
+ (setf (get 'event-19 'documentation) "Unrecognized/Invalid PDU Decoded"))
+
+;;;=============================================================
+;;; Protocol Data Unit Documentation.
+
+(eval-when (EVAL LOAD)
+
+ ;; PDUs for Association Negotiation.
+ (setf (get :A-Associate-RQ 'documentation) "A-Associate-RQ")
+ (setf (get :A-Associate-AC 'documentation) "A-Associate-AC")
+ (setf (get :A-Associate-RJ 'documentation) "A-Associate-RJ")
+
+ ;; DICOM Message [Command or Data-Set] Transfer PDU.
+ (setf (get :P-Data-TF 'documentation) "P-Data-TF")
+
+ ;; PDUs for Association Release.
+ (setf (get :A-Release-RQ 'documentation) "A-Release-RQ")
+ (setf (get :A-Release-RSP 'documentation) "A-Release-RSP")
+
+ ;; PDU for Association Abort.
+ (setf (get :A-Abort 'documentation) "A-Abort")
+
+ ;; C-Echo Message Handling.
+ ;; Echo Request - Complete PDU
+ (setf (get :C-Echo-RQ 'documentation) "C-Echo-RQ")
+ ;; Echo Response - Complete PDU
+ (setf (get :C-Echo-RSP 'documentation) "C-Echo-RSP")
+
+ ;; C-Store Message Handling.
+ ;; C-Store Request - Multiple PDUs
+ (setf (get :C-Store-RTPlan-RQ 'documentation) "C-Store-RTPlan-RQ")
+ ;; PDV Message - Command
+ (setf (get :C-Store-RTPlan-Command 'documentation) "C-Store-RTPlan-Command")
+ ;; PDV Message - Data
+ (setf (get :C-Store-RTPlan-Data 'documentation) "C-Store-RTPlan-Data")
+ ;; C-Store Request - Multiple PDUs
+ (setf (get :C-Store-RQ 'documentation) "C-Store-RQ")
+ ;; C-Store Response - Complete PDU
+ (setf (get :C-Store-RSP 'documentation) "C-Store-RSP"))
+
+;;;=============================================================
+
+(eval-when (EVAL LOAD)
+ (compile-states *State-Rule-List*)
+ (setq *State-Rule-List* nil))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/utilities.cl b/dicom/src/utilities.cl
new file mode 100644
index 0000000..3c3174b
--- /dev/null
+++ b/dicom/src/utilities.cl
@@ -0,0 +1,277 @@
+;;;
+;;; utilities
+;;;
+;;; Functions Embedded in Rules for DICOM Message Interpretation.
+;;; Utility functions for Object Parsing, Error Recovery and Logging,
+;;; Data/Time, Environmental Printout, PDU Dumping, Debugging, and Testing.
+;;; Contains functions common to Client and Server.
+;;;
+;;; 13-Apr-2001 BobGian fix DUMP-BYTESTREAM to dump max of *MAX-DUMPLEN* bytes.
+;;; 23-Apr-2001 BobGian fix DUMP-BYTESTREAM to dump arbitrary region of PDU.
+;;; 23-Apr-2001 BobGian simplify and improve error reporting.
+;;; 25-Apr-2001 BobGian fix DUMP-BYTESTREAM to dump arbitrary region of PDU.
+;;; 09-May-2001 BobGian improve formatting of environment printout.
+;;; 30-Jul-2001 BobGian improve formatting of data sent to log file.
+;;; 15-Oct-2001 BobGian remove *FILE-MOVE-LIST*.
+;;; 23-Jan-2002 BobGian add DUMP-DICOM-DATA as debug printer - independent
+;;; from logging functions in "dicom-rtplan" and Prism package.
+;;; 23-Jan-2002 BobGian divide REPORT-ERROR into separate functions, for
+;;; Client and for Server, reporting global vars specialized to each role.
+;;; 18-Feb-2002 BobGian change DUMP-DICOM-DATA to write to standard output.
+;;; 02-Mar-2002 BobGian functions embedded in rules moved to "compiler.cl".
+;;; 16-Apr-2002 BobGian second arg to MISHAP for printing arbitrary list
+;;; structure or dumping TCP-Buffer - passed to REPORT-ERROR.
+;;; 04-May-2002 BobGian DUMP-BYTESTREAM dumps all bytes between HEAD and TAIL.
+;;; 06-Aug-2002 BobGian *PRINT-PRETTY* -> T in DUMP-DICOM-DATA.
+;;; 21-Aug-2002 BobGian *PRINT-ARRAY* -> NIL in DUMP-DICOM-DATA (Oops! :-).
+;;; 17-Sep-2002 BobGian:
+;;; *PRINT-ARRAY* -> NIL always except when needed to be T.
+;;; MISHAP takes new 3rd arg (DICOM-ALIST) and passes it to REPORT-ERROR.
+;;; 24-Sep-2002 BobGian:
+;;; Remove 3rd arg (DICOM-ALIST) to REPORT-ERROR and MISHAP. Same
+;;; functionality now obtained via special variable set when data available.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 03-Nov-2003 BobGian New pretty-printer and data formatter written for
+;;; debugging client replaces dumper in server as well. DUMP-DICOM-DATA
+;;; is used as calling interface. Actual dumper is DISPLAY-DICOM-DATA.
+;;; 09-Nov-2003 BobGian - remove debugging code [for testing parsing routines].
+;;; 10-Sep-2004 BobGian - add TERPRI to header in DUMP-DICOM-DATA.
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; Useful Time-Display Utility.
+
+(defun date/time (&aux (universal-time (get-universal-time)))
+
+ (declare (type integer universal-time))
+
+ (multiple-value-bind (seconds minutes hours days months years)
+ (decode-universal-time universal-time)
+
+ (declare (type fixnum seconds minutes hours days months years))
+
+ (format nil "~A~D-~A-~D ~A~D:~A~D:~A~D"
+ (if (< days 10) "0" "") days
+ (nth (the fixnum (1- months))
+ '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul"
+ "Aug" "Sep" "Oct" "Nov" "Dec"))
+ years
+ (if (< hours 10) "0" "") hours
+ (if (< minutes 10) "0" "") minutes
+ (if (< seconds 10) "0" "") seconds)))
+
+;;;=============================================================
+;;; Error condition escape. If a run-time error occurs, MISHAP prints a
+;;; message to the log stream [regardless of Logging Level] and then:
+;;; In client, invokes the debugger by calling an untrapped ERROR.
+;;; In server, invokes ERROR, which is trapped by IGNORE-ERRORS in
+;;; wrapper functions.
+
+(defun mishap (env data msg &rest format-args)
+
+ ;; ENV may be NIL or a CONS. DATA may be NIL, an ARRAY [TCP-Buffer],
+ ;; or arbitrary list structure.
+ (declare (type list env format-args)
+ (type
+ (or null list (simple-array (unsigned-byte 8) (#.TCP-Bufsize)))
+ data)
+ (type simple-base-string msg))
+
+ (apply #'report-error env data msg format-args)
+
+ (apply #'error msg format-args))
+
+;;;-------------------------------------------------------------
+;;; Prints all numbers in base 10.
+
+(defun print-environment (env &aux thing)
+
+ (declare (type list env))
+
+ (format t "~%Environment:")
+
+ (cond
+ ((null env)
+ (format t " NIL"))
+
+ ((eq env :Fail)
+ (format t " :Fail"))
+
+ ((consp env)
+ (dolist (pair env)
+ (cond ((atom pair)
+ (mishap nil nil "PRINT-ENVIRONMENT [1] Bad PAIR ~S in ENV:~%~S"
+ pair env))
+
+ ((keywordp (setq thing (car pair)))
+ (print-env2 pair 1))
+
+ ((not (symbolp thing))
+ (mishap nil nil "PRINT-ENVIRONMENT [2] Bad SYMBOL ~S in ENV:~%~S"
+ thing env))
+
+ (t (format t "~% Global Var: ~A" thing)
+ (format t "~% Value: ~S" (cdr pair))))))
+
+ (t (mishap nil nil "PRINT-ENVIRONMENT [3] Bad ENV:~%~S" env)))
+
+ (terpri))
+
+;;;-------------------------------------------------------------
+
+(defun print-env2 (env level)
+
+ (declare (type list env)
+ (type fixnum level))
+
+ (terpri)
+
+ (do ((i 0 (the fixnum (1+ i))))
+ ((= i level))
+ (declare (type fixnum i))
+ (format t " "))
+
+ (format t "Component: ~A" (car env))
+
+ (dolist (object (cdr env))
+ (let ((thing (and (consp object) (car object))))
+
+ (cond ((and thing (keywordp thing))
+ (print-env2 object (the fixnum (1+ level))))
+
+ ((and thing (symbolp thing))
+ (format t "~% ")
+ (do ((i 0 (the fixnum (1+ i))))
+ ((= i level))
+ (declare (type fixnum i))
+ (format t " "))
+ (format t "Variable: ~A Value: ~S" thing (cdr object)))
+
+ (t (mishap nil nil "PRINT-ENV2 [1] Bad object: ~S" object))))))
+
+;;;-------------------------------------------------------------
+;;; Simple and fast dumper, adequate for most purposes.
+;;;
+;;; PDU is stored in TCP buffer from byte HEAD [inclusive, start] to byte
+;;; TAIL [exclusive, end]. This function dumps a PDU in a buffer from its
+;;; beginning up to its end.
+
+(defun dump-bytestream (msg tcp-buffer head tail
+ &aux (buflen (the fixnum (- tail head))))
+
+ (declare (type simple-base-string msg)
+ (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer)
+ (type fixnum head tail buflen))
+
+ (format t "~%Dumping ~A (~D bytes), [Decimal, Hex, Chars]:" msg buflen)
+
+ (do ((bytecount 0 (the fixnum (+ bytecount 20)))
+ (ptr head (the fixnum (+ ptr 20))))
+ ((>= bytecount buflen))
+
+ (declare (type fixnum bytecount ptr))
+
+ (when (= (the fixnum (mod bytecount 100)) 0)
+ (terpri))
+
+ (format t "~%~D~12T" ptr)
+
+ (do ((idx ptr (the fixnum (1+ idx)))
+ (cnt 0 (the fixnum (1+ cnt))))
+ ((or (= cnt 20)
+ (= idx tail)))
+
+ (declare (type fixnum idx cnt))
+
+ (when (= cnt 10) ;Spacer at 10 unit point
+ (format t " "))
+
+ (format t "~2,'0X " (aref tcp-buffer idx)))
+
+ (format t "~77T")
+
+ (do ((idx ptr (the fixnum (1+ idx)))
+ (cnt 0 (the fixnum (1+ cnt)))
+ (ch 0))
+ ((or (= cnt 20)
+ (= idx tail)))
+
+ (declare (type fixnum idx cnt ch))
+
+ (setq ch (aref tcp-buffer idx))
+ (format t "~C" (cond ((<= 32 ch 126)
+ (code-char ch))
+ (t #\.)))))
+
+ (terpri))
+
+;;;-------------------------------------------------------------
+;;; Debugging trace -- for dumping unimplemented SOP class
+;;; data during development and/or in error situations.
+
+(defun dump-dicom-data (dicom-alist strm)
+
+ (format strm "~%Dicom-Alist:~%~% (")
+ (display-dicom-data dicom-alist 4 120 *group/elemname-alist* strm)
+ (format strm ")~%"))
+
+;;;-------------------------------------------------------------
+
+(defun display-dicom-data (data indent-level max-col index-alist strm &aux
+ (indent-level+2 (the fixnum (+ indent-level 2))))
+
+ (declare (type list data index-alist)
+ (type fixnum indent-level max-col indent-level+2))
+
+ (do ((items data (cdr items))
+ (indent-string (make-string indent-level :initial-element #\Space))
+ (item) (key) (datalist) (text "") (len 0) (col indent-level) (label))
+ ((null items))
+
+ (declare (type list items item key datalist label)
+ (type cons index-alist)
+ (type simple-base-string indent-string text)
+ (type fixnum len col))
+
+ (setq item (car items) key (car item) datalist (cdr item))
+ (setq label (cdr (assoc key index-alist :test #'equal)))
+ (setq text (format nil "(<~A:~A ~A ~S>"
+ (nstring-upcase (format nil "~4,'0X" (car key)))
+ (nstring-upcase (format nil "~4,'0X" (cdr key)))
+ (symbol-name (the symbol (first label)))
+ (second label)))
+ (setq col (the fixnum (+ col (length text))))
+ (format strm "~A" text)
+
+ (cond ((null datalist)
+ (format strm " <empty>)"))
+
+ ((consp (car datalist))
+ (dolist (thing datalist)
+ (format strm "~%~A (" indent-string)
+ (display-dicom-data thing
+ indent-level+2
+ max-col
+ index-alist
+ strm)
+ (format strm ")"))
+ (format strm ")"))
+
+ (t (dolist (thing datalist)
+ (setq text (format nil " ~S" thing)
+ len (length text))
+ (when (> (setq col (the fixnum (+ col len))) max-col)
+ (format strm "~%~A" indent-string)
+ (setq col (the fixnum (+ indent-level len))))
+ (format strm "~A" text))
+ (format strm ")")))
+
+ (when (cdr items)
+ (format strm "~%~A" indent-string)
+ (setq col indent-level))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/wrapper-client.cl b/dicom/src/wrapper-client.cl
new file mode 100644
index 0000000..9d6284c
--- /dev/null
+++ b/dicom/src/wrapper-client.cl
@@ -0,0 +1,145 @@
+;;;
+;;; wrapper-client
+;;;
+;;; Client-mode wrappers and functions.
+;;; Contains functions used in Client only.
+;;;
+;;; 26-Dec-2000 BobGian add log messages for rule/state compilation.
+;;; 21-Jun-2001 BobGian target configuration parameters now determined
+;;; from machine definition file rather than from startup dialog.
+;;; 10-Aug-2001 BobGian wrap IGNORE-ERRORS around DICOM-CLIENT to catch
+;;; and report otherwise uncaught errors rather than crashing Prism.
+;;; 10-Sep-2001 BobGian remove IGNORE-ERRORS around DICOM-CLIENT -
+;;; should be debugged rather than ignored or just logged.
+;;; 11-Jan-2002 BobGian remodularize functionality so full DUL state is
+;;; encapsulated in state of special variables bound on client entry,
+;;; so that PDS can stack state and run client as a subsystem of server.
+;;; 20-Jan-2002 BobGian *PRINT-PRETTY* -> NIL except in logging functions.
+;;; 19-Mar-2002 BobGian add version-identifying banner printout at startup.
+;;; 27-Apr-2002 BobGian *PRINT-PRETTY* -> T except in index-file functions.
+;;; 04-May-2002 BobGian initialize TCP-Buffer to #\* so unused elements
+;;; can be spotted easily in dump.
+;;; 06-Aug-2002 BobGian *PRINT-PRETTY* -> NIL unless overridden.
+;;; 30-Aug-2002 BobGian Calling-AE-Title looked up by RUN-CLIENT from
+;;; pr::*DICOM-AE-TITLES* (indexed by hostname) rather than looked up
+;;; in machine IDENT slot by caller and passed this function. This
+;;; enables multiple clients, each with a unique AE title.
+;;; 17-Sep-2002 BobGian *PRINT-ARRAY* -> NIL always except when needed to be T.
+;;; 23-Sep-2002 BobGian pr::*DICOM-AE-TITLES* -> DICOM package.
+;;; 24-Sep-2002 BobGian add binding for *DICOM-ALIST*.
+;;; 08-May-2003 BobGian: *PRINT-PRETTY* T unless it needs to be NIL.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 08-Nov-2003 BobGian - remove *PRINT-RIGHT-MARGIN* and *PRINT-PRETTY*
+;;; bindings; new data dumper makes them irrelevant.
+;;; 09-Nov-2003 BobGian - remove startup banner; DICOM version number now
+;;; incorporated into Prism version number.
+;;; 09-Nov-2004 BobGian changed args to DICOM-CLIENT to modularize functional
+;;; dispatch mechanism.
+;;; 20-Jun-2009 I. Kalet move export and globals here to make
+;;; independent of defsystem
+;;; 17-Jul-2011 I. Kalet move export to dicom defpackage form in
+;;; dicom.cl to eliminate warning about export at top level
+;;;
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; System Parameter -- user-configurable.
+
+(defvar *dicom-ae-titles* nil
+ "Mapping from hostnames to AE titles for Dicom RT clients.")
+
+;;;=============================================================
+
+(defun run-client (cmd host port called-ae data instance-uid-str
+ &aux
+ (calling-ae
+ (or (second (assoc (sys:getenv "HOST")
+ *dicom-ae-titles* :test #'string=))
+ "No Title")) ;In case of misconfiguration.
+ (*calling-AE-name* calling-ae) (*print-array* nil)
+ (*called-AE-name* called-ae) (*remote-IP-string* nil)
+ (*status-code* -1) (*status-message* nil)
+ (*dicom-alist* nil))
+
+ "CMD: :C-Echo-RQ (Echo Verify) or :C-Store-RTPlan-RQ (Send RTPlan)."
+
+ ;; All internal state variables are bound to initial values on client
+ ;; startup so that server can push environment to run a client.
+
+ (declare (type keyword cmd)
+ (type simple-base-string host called-ae calling-ae instance-uid-str)
+ (type (or null simple-base-string) *status-message*)
+ (type list data)
+ (type fixnum port *status-code*))
+
+ (setf *Implementation-Version-Name* "PDR_1.0"
+ *Implementation-Class-UID* "1.2.840.113994.100.10.1.2")
+
+ (cond ((eq cmd :C-Echo-RQ)
+ (let* ((echo-sop-str *Echo-Verification-Service*)
+ (echo-sop-len (length echo-sop-str)))
+ (declare (type simple-base-string echo-sop-str)
+ (type fixnum echo-sop-len))
+ (setq *SOP-class-name* echo-sop-str)
+ (catch :Abandon-Client
+ (dicom-client
+ `((Command . ,cmd)
+ (Remote-Hostname . ,host)
+ (Remote-Port . ,port)
+ (Calling-AE-Title . ,calling-ae)
+ (Called-AE-Title . ,called-ae)
+ (SOP-Class-UID-Len . ,echo-sop-len)
+ (SOP-Class-UID-Str . ,echo-sop-str)
+ (Role-SOP-Class-UID-Len . ,echo-sop-len)
+ (Role-SOP-Class-UID-Str . ,echo-sop-str))))))
+
+ ((eq cmd :C-Store-RTPlan-RQ)
+ (let* ((rtplan-sop-str *RTPlan-Storage-Service*)
+ (rtplan-sop-len (length rtplan-sop-str)))
+ (declare (type simple-base-string rtplan-sop-str)
+ (type fixnum rtplan-sop-len))
+ (setq *SOP-class-name* rtplan-sop-str)
+ (catch :Abandon-Client
+ (dicom-client
+ `((Command . ,cmd)
+ (Remote-Hostname . ,host)
+ (Remote-Port . ,port)
+ (Calling-AE-Title . ,calling-ae)
+ (Called-AE-Title . ,called-ae)
+ (SOP-Class-UID-Len . ,rtplan-sop-len)
+ (SOP-Class-UID-Str . ,rtplan-sop-str)
+ (Role-SOP-Class-UID-Len . ,rtplan-sop-len)
+ (Role-SOP-Class-UID-Str . ,rtplan-sop-str)
+ (Store-SOP-Instance-UID-Len . ,(even-length instance-uid-str))
+ (Store-SOP-Instance-UID-Str . ,instance-uid-str)
+ (RTPlan-DataSet , at data))))))
+
+ (t (error "RUN-CLIENT [1] Bad command: ~S ~S ~S" cmd host port)))
+
+ (values *status-code* (or *status-message* "Unknown error")))
+
+;;;-------------------------------------------------------------
+
+(defun dicom-client (initial-environment &aux (*max-datafield-len* nil)
+ (*connection-strm* nil) (*checkpointed-environment* '()))
+
+ (declare (type list *checkpointed-environment*))
+
+ (unwind-protect
+ (dicom-mainloop
+ (make-array #.TCP-Bufsize ;TCP buffer
+ :element-type '(unsigned-byte 8)
+ ;; Initialize to #\* so unused elements can be
+ ;; spotted easily in dump.
+ :initial-element #.(char-code #\*))
+ nil ;TCP stream
+ initial-environment ;All args passed as initial environment
+ :Client ;Role or Mode
+ 'event-01) ;Initial activating Event
+ (when *connection-strm*
+ (close *connection-strm*)
+ (setq *connection-strm* nil))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/wrapper-client.cl~ b/dicom/src/wrapper-client.cl~
new file mode 100644
index 0000000..ad3058c
--- /dev/null
+++ b/dicom/src/wrapper-client.cl~
@@ -0,0 +1,143 @@
+;;;
+;;; wrapper-client
+;;;
+;;; Client-mode wrappers and functions.
+;;; Contains functions used in Client only.
+;;;
+;;; 26-Dec-2000 BobGian add log messages for rule/state compilation.
+;;; 21-Jun-2001 BobGian target configuration parameters now determined
+;;; from machine definition file rather than from startup dialog.
+;;; 10-Aug-2001 BobGian wrap IGNORE-ERRORS around DICOM-CLIENT to catch
+;;; and report otherwise uncaught errors rather than crashing Prism.
+;;; 10-Sep-2001 BobGian remove IGNORE-ERRORS around DICOM-CLIENT -
+;;; should be debugged rather than ignored or just logged.
+;;; 11-Jan-2002 BobGian remodularize functionality so full DUL state is
+;;; encapsulated in state of special variables bound on client entry,
+;;; so that PDS can stack state and run client as a subsystem of server.
+;;; 20-Jan-2002 BobGian *PRINT-PRETTY* -> NIL except in logging functions.
+;;; 19-Mar-2002 BobGian add version-identifying banner printout at startup.
+;;; 27-Apr-2002 BobGian *PRINT-PRETTY* -> T except in index-file functions.
+;;; 04-May-2002 BobGian initialize TCP-Buffer to #\* so unused elements
+;;; can be spotted easily in dump.
+;;; 06-Aug-2002 BobGian *PRINT-PRETTY* -> NIL unless overridden.
+;;; 30-Aug-2002 BobGian Calling-AE-Title looked up by RUN-CLIENT from
+;;; pr::*DICOM-AE-TITLES* (indexed by hostname) rather than looked up
+;;; in machine IDENT slot by caller and passed this function. This
+;;; enables multiple clients, each with a unique AE title.
+;;; 17-Sep-2002 BobGian *PRINT-ARRAY* -> NIL always except when needed to be T.
+;;; 23-Sep-2002 BobGian pr::*DICOM-AE-TITLES* -> DICOM package.
+;;; 24-Sep-2002 BobGian add binding for *DICOM-ALIST*.
+;;; 08-May-2003 BobGian: *PRINT-PRETTY* T unless it needs to be NIL.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 08-Nov-2003 BobGian - remove *PRINT-RIGHT-MARGIN* and *PRINT-PRETTY*
+;;; bindings; new data dumper makes them irrelevant.
+;;; 09-Nov-2003 BobGian - remove startup banner; DICOM version number now
+;;; incorporated into Prism version number.
+;;; 09-Nov-2004 BobGian changed args to DICOM-CLIENT to modularize functional
+;;; dispatch mechanism.
+;;; 20-Jun-2009 I. Kalet move export and globals here to make
+;;; independent of defsystem
+;;; 17-Jul-2011 I. Kalet move export to dicom defpackage form in
+;;; dicom.cl to eliminate warning about export at top level
+;;;
+
+;;;=============================================================
+;;; System Parameter -- user-configurable.
+
+(defvar *dicom-ae-titles* nil
+ "Mapping from hostnames to AE titles for Dicom RT clients.")
+
+;;;=============================================================
+
+(defun run-client (cmd host port called-ae data instance-uid-str
+ &aux
+ (calling-ae
+ (or (second (assoc (sys:getenv "HOST")
+ *dicom-ae-titles* :test #'string=))
+ "No Title")) ;In case of misconfiguration.
+ (*calling-AE-name* calling-ae) (*print-array* nil)
+ (*called-AE-name* called-ae) (*remote-IP-string* nil)
+ (*status-code* -1) (*status-message* nil)
+ (*dicom-alist* nil))
+
+ "CMD: :C-Echo-RQ (Echo Verify) or :C-Store-RTPlan-RQ (Send RTPlan)."
+
+ ;; All internal state variables are bound to initial values on client
+ ;; startup so that server can push environment to run a client.
+
+ (declare (type keyword cmd)
+ (type simple-base-string host called-ae calling-ae instance-uid-str)
+ (type (or null simple-base-string) *status-message*)
+ (type list data)
+ (type fixnum port *status-code*))
+
+ (setf *Implementation-Version-Name* "PDR_1.0"
+ *Implementation-Class-UID* "1.2.840.113994.100.10.1.2")
+
+ (cond ((eq cmd :C-Echo-RQ)
+ (let* ((echo-sop-str *Echo-Verification-Service*)
+ (echo-sop-len (length echo-sop-str)))
+ (declare (type simple-base-string echo-sop-str)
+ (type fixnum echo-sop-len))
+ (setq *SOP-class-name* echo-sop-str)
+ (catch :Abandon-Client
+ (dicom-client
+ `((Command . ,cmd)
+ (Remote-Hostname . ,host)
+ (Remote-Port . ,port)
+ (Calling-AE-Title . ,calling-ae)
+ (Called-AE-Title . ,called-ae)
+ (SOP-Class-UID-Len . ,echo-sop-len)
+ (SOP-Class-UID-Str . ,echo-sop-str)
+ (Role-SOP-Class-UID-Len . ,echo-sop-len)
+ (Role-SOP-Class-UID-Str . ,echo-sop-str))))))
+
+ ((eq cmd :C-Store-RTPlan-RQ)
+ (let* ((rtplan-sop-str *RTPlan-Storage-Service*)
+ (rtplan-sop-len (length rtplan-sop-str)))
+ (declare (type simple-base-string rtplan-sop-str)
+ (type fixnum rtplan-sop-len))
+ (setq *SOP-class-name* rtplan-sop-str)
+ (catch :Abandon-Client
+ (dicom-client
+ `((Command . ,cmd)
+ (Remote-Hostname . ,host)
+ (Remote-Port . ,port)
+ (Calling-AE-Title . ,calling-ae)
+ (Called-AE-Title . ,called-ae)
+ (SOP-Class-UID-Len . ,rtplan-sop-len)
+ (SOP-Class-UID-Str . ,rtplan-sop-str)
+ (Role-SOP-Class-UID-Len . ,rtplan-sop-len)
+ (Role-SOP-Class-UID-Str . ,rtplan-sop-str)
+ (Store-SOP-Instance-UID-Len . ,(even-length instance-uid-str))
+ (Store-SOP-Instance-UID-Str . ,instance-uid-str)
+ (RTPlan-DataSet , at data))))))
+
+ (t (error "RUN-CLIENT [1] Bad command: ~S ~S ~S" cmd host port)))
+
+ (values *status-code* (or *status-message* "Unknown error")))
+
+;;;-------------------------------------------------------------
+
+(defun dicom-client (initial-environment &aux (*max-datafield-len* nil)
+ (*connection-strm* nil) (*checkpointed-environment* '()))
+
+ (declare (type list *checkpointed-environment*))
+
+ (unwind-protect
+ (dicom-mainloop
+ (make-array #.TCP-Bufsize ;TCP buffer
+ :element-type '(unsigned-byte 8)
+ ;; Initialize to #\* so unused elements can be
+ ;; spotted easily in dump.
+ :initial-element #.(char-code #\*))
+ nil ;TCP stream
+ initial-environment ;All args passed as initial environment
+ :Client ;Role or Mode
+ 'event-01) ;Initial activating Event
+ (when *connection-strm*
+ (close *connection-strm*)
+ (setq *connection-strm* nil))))
+
+;;;=============================================================
+;;; End.
diff --git a/dicom/src/wrapper-server.cl b/dicom/src/wrapper-server.cl
new file mode 100644
index 0000000..3d24fff
--- /dev/null
+++ b/dicom/src/wrapper-server.cl
@@ -0,0 +1,456 @@
+;;;
+;;; wrapper-server
+;;;
+;;; Server-mode wrappers and functions.
+;;; Contains functions used in Server only.
+;;;
+;;; 21-Dec-2000 BobGian wrap IGNORE-ERRORS around error-prone fcns.
+;;; Include error-recovery options in case those fcns barf.
+;;; Change a few local variable names for consistency.
+;;; 26-Dec-2000 BobGian change local variable name [date -> date-string].
+;;; 11-Apr-2001 BobGian remove name-server lookup and printing of hostname.
+;;; IP address contains same information and is much faster.
+;;; 13-Apr-2001 BobGian add logging of source/target to file move.
+;;; 30-Jul-2001 BobGian improve formatting of data sent to log file.
+;;; 15-Oct-2001 BobGian remove file moving - outputs now written directly.
+;;; 15-Oct-2001 BobGian flush chown [replaced by SGID bit] and chmod
+;;; [replaced by umask in starting shell] mechanisms.
+;;; 17-Oct-2001 BobGian cache string variable initialization: "" -> NIL.
+;;; 23-Oct-2001 BobGian *PACKAGE* not bound - symbols printed instead
+;;; using "~A" FORMAT directive.
+;;; 23-Oct-2001 BobGian *PRINT-PRETTY* -> NIL; no need to indent index files.
+;;; Also, *PRINT-ARRAY* -> T globally.
+;;; 08-Jan-2002 BobGian move *STATUS-CODE* and *STATUS-MESSAGE* to proper
+;;; scope for server - bound for each connection, not for life of server.
+;;; 11-Jan-2002 BobGian remodularize functionality so full DUL state is
+;;; encapsulated in state of special variables bound on server connection
+;;; acceptance, so PDS can stack state to run client as subsystem of server.
+;;; 20-Jan-2002 BobGian *PRINT-PRETTY* -> T for printout of configuration data
+;;; then NIL for rest of operation [index files, logging, etc].
+;;; 24-Jan-2002 BobGian *PACKAGE* bound to Dicom package so symbols printed
+;;; to log file will not contain package prefix.
+;;; 25-Jan-2002 BobGian DICOM-SERVER must bind *CONNECTION-STRM*.
+;;; 19-Mar-2002 BobGian add version-identifying banner printout at startup.
+;;; 19-Mar-2002 BobGian replace own error message printer [which was not
+;;; always reliable] with call to standard DESCRIBE function.
+;;; 24-Apr-2002 BobGian *STATUS-MESSAGE* initialized to NIL and set
+;;; to appropriate message by any error or to "Success" on success.
+;;; 24-Apr-2002 BobGian add optional arg to set logging level, overriding
+;;; value in config file.
+;;; 27-Apr-2002 BobGian *PRINT-PRETTY* -> T except in index-file functions.
+;;; 04-May-2002 BobGian initialize TCP-Buffer to #\* so unused elements
+;;; can be spotted easily in dump.
+;;; Jul/Aug 2002 BobGian:
+;;; DICOM-SERVER: Change names of globals printed to log file at startup.
+;;; Bind all dynamic (special) vars on function entry rather than at top
+;;; level (except of course globals storing configuration data).
+;;; If association completes and images were stored successfully, append
+;;; cached records to "image.index" file. This prevents Prism users from
+;;; accidently accessing an incomplete image set still being received.
+;;; 06-Aug-2002 BobGian *PRINT-PRETTY* -> NIL unless overridden,
+;;; and T during printing of configuration information.
+;;; 20-Aug-2002 BobGian:
+;;; On error, close TCP stream first, then log message.
+;;; At end of image set (when new set detected by WRITE-IMAGE-SET, or at
+;;; conclusion of association in DICOM-SERVER), log number of images
+;;; stored in each set to "image.index" record and to log file.
+;;; 31-Aug-2002 BobGian log count of images actually stored (w/o duplicates).
+;;; 17-Sep-2002 BobGian *PRINT-ARRAY* -> NIL always except when needed to be T.
+;;; 24-Sep-2002 BobGian add binding for *DICOM-ALIST*.
+;;; 18-Oct-2002 BobGian fix bug whereby image index file was updated only if
+;;; last image set received in association contained images that were stored.
+;;; Correct behavior is to update if ANY images are stored successfully
+;;; during the association, regardless of which image set contained them.
+;;; 08-May-2003 BobGian: DICOM-SERVER -> RUN-SERVER (symmetry with RUN-CLIENT).
+;;; 30-Jul-2003 I. Kalet move dump-dicom-server here for new cvs code
+;;; management scheme.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 08-Nov-2003 BobGian - remove *PRINT-RIGHT-MARGIN* and *PRINT-PRETTY*
+;;; bindings; new data dumper makes them irrelevant.
+;;; 09-Nov-2003 BobGian - move startup banner version identification to
+;;; /radonc/prism/start-dicom, which prints date of dicom.dxl file.
+;;; 24-Dec-2003 BobGian: Variable *REPORTABLE-VARIABLES* holds list of
+;;; configurable variables whose values are logged at server startup.
+;;; 02-Mar-2004 BobGian: Writing non-axial images temporarily as test
+;;; of Computed-Radiography SOP class handling.
+;;; 27-Apr-2004 BobGian: Variable split - *STORED-IMAGE-COUNT* ->
+;;; *STORED-IMAGE-COUNT-PER-SET* [per-image-set count]
+;;; *STORED-IMAGE-COUNT-CUMULATIVE* [cumulative count over association].
+;;; 18-Apr-2005 I. Kalet incorporate SSL socket support per Tung Le.
+;;; 19-Jun-2007 I. Kalet correct misplaced ) in call to make-ssl-server-stream
+;;; 24-Jun-2009 I. Kalet move globals here to make files independent
+;;; of defsystem. Move dump-dicom-server to make-prism, not really
+;;; part of server. And, use socket: for symbols in acl-socket package
+;;; 4-Oct-2009 I. Kalet use environment variable PDS_CONFIG_DIRECTORY
+;;; to locate pds.config file.
+
+;;;=============================================================
+;;; Package definition needed to write some received Prism objects
+
+(defpackage :slik
+ (:nicknames "SL")
+ (:export "BLUE" "CYAN" "GRAY" "GREEN" "MAGENTA" "RED" "WHITE" "YELLOW"))
+
+;;;=============================================================
+
+(in-package :dicom)
+
+;;;=============================================================
+;;; Cached information. Reset on each new connection acceptance.
+
+;;; Variables used to cache directory information decided on each association
+;;; acceptance. Updated on each association acceptance.
+(defvar *patient-DB*) ;Directory for main "patient.index" file
+(defvar *matched-pat-image-DB*) ;Directory for Matched Patient Image data
+(defvar *unmatched-pat-image-DB*) ;Directory for Unmatched Patient Image data
+(defvar *structure-DB*) ;Directory for Structure-Set data
+
+;;; Variables used to cache patient information once identification is made
+;;; on first association so we needn't repeat the search on each successive
+;;; association for the same patient. Updated on each patient identification.
+(defvar *cached-dicom-pat-name*) ;String - pat name
+(defvar *cached-prism-pat-name*) ;String - pat name
+(defvar *cached-dicom-pat-ID*) ;String - pat hosp ID
+(defvar *cached-prism-pat-ID*) ;Fixnum - Prism number
+(defvar *cached-image-DB*) ;String - directory
+
+;;; Cached information describing identification of Image Set.
+;;; Updated on each Image Set identification [new patient or old-pt/new-set].
+(defvar *cached-dicom-set-ID*) ;String - Dicom Image-Set UID
+(defvar *cached-prism-set-ID*) ;Fixnum - Prism Image-Set number
+
+;;; Alist of ID-number/UID-string for images stored in current set, used
+;;; to test for duplication of image files and for beginning of new Image Set
+;;; on same association. Reset on each Image Set identification.
+(defvar *image-ID/UID-alist*)
+
+;;; Count of images actually stored in current Image-Set during current
+;;; Association. Does not count duplicates. Reset on each new Image Set
+;;; identification.
+(defvar *stored-image-count-per-set*)
+
+;;; Count of images actually stored cumulatively in all Image-Sets during
+;;; current Association. Does not count duplicates.
+(defvar *stored-image-count-cumulative*)
+
+;;; List of records to be appended to "image.index" file at concluson of
+;;; successful association. Not appending records until then prevents Prism
+;;; user from inadvertently accessing an incomplete set while image reception
+;;; is still in progress.
+(defvar *new-im-index-records*)
+
+;;; Pointer to record in "image.index" file for image-set currently being
+;;; written [if a new one], so number of images in set can be written to file.
+(defvar *current-im-set-record*)
+
+;;;=============================================================
+;;; System Parameters -- not user-configurable.
+
+;;; File name merged with current directory or value of
+;;; PDS_CONFIG_DIRECTORY environment variable. DICOM config file is
+;;; used only by server. Client uses standard Prism configuration file.
+(defparameter *config-file* "pds.config")
+
+;;;=============================================================
+;;; System Parameters -- Configurable via "pds.config" file in directory
+;;; "/radonc/prism" for the server.
+
+(defvar *pds-server-port* 104)
+(defvar *qlen* 5)
+
+;; Patient case and index data.
+(defvar *patient-database* "/prismdata/cases/")
+
+;; Matched Patient images.
+(defvar *matched-pat-image-database* "/prismdata/images/")
+
+;; Unmatched Patient images.
+(defvar *unmatched-pat-image-database* "/prismdata/imagedump/")
+
+;; Structure-Sets for all patients.
+(defvar *structure-database* "/prismdata/structures/")
+
+;;; Association Requestors from whom to accept proposed associations.
+;;; If NIL, associations will be accepted from anybody. If non-NIL, this is
+;;; a list of 2-element lists of strings representing IP addresses [dotted]
+;;; and AE-Titles of acceptable clients.
+;;;
+;;; Optionally, each sublist can also contain four more elements, these being
+;;; [respectively] the directory for the main "patient.index" file, for the
+;;; "image.index" file, for the "patient.index" file for unmatched patient
+;;; names [for images], and for the "structure.index" file. If not present,
+;;; these values default to the values of the four variables just above.
+(defvar *remote-entities* '( ))
+
+;;; Server AE names acceptable for Association Requestors to use.
+;;; If NIL, associations will be accepted for any name. If non-NIL,
+;;; this is a list of AE names acceptable for client to use. Server has
+;;; one name, but certain clients might be configured differently.
+;;;
+;;; Each AE name is in form of a list:
+;;; ( <Called-AE-Title> <Pat-Index-Dir> <Matched-Pat-Image-Dir>
+;;; <Unmatched-Pat-Image-Dir> <Structure-Set-Dir> )
+;;; The first element is required; the rest are optional,
+;;; for overriding default target directories.
+(defvar *local-entities* '( ))
+
+(defvar *keepalive-timeout* 7200) ;Two hours
+
+;;; List of variables settable in "pds.config" file and whose values are
+;;; reported to log file at server startup.
+(defvar *reportable-variables*
+ '(*pds-server-port*
+ *qlen*
+ *patient-database*
+ *matched-pat-image-database*
+ *unmatched-pat-image-database*
+ *structure-database*
+ *keepalive-timeout*
+ *artim-timeout*
+ *remote-entities*
+ *local-entities*
+ *image-storage-services*
+ *object-storage-services*
+ *all-services*
+ *application-context-name*
+ *transfer-syntax-name*
+ *ignorable-groups-list*))
+
+;;;=============================================================
+;;; Main server startup function. No arguments, to facilitate running as
+;;; a stand-alone executable. All configuration done via parameters set in
+;;; "dicom-server.system" and local overrides in config file.
+;;; Make sure Standard-Output is redirected to a file in Runtime system.
+
+(defun run-server (&aux accept-strm tcp-strm *connection-strm*
+ (*print-array* nil) (*package* (find-package :Dicom))
+ ;; Initialize to #\* so unused elements can be
+ ;; spotted easily in dump.
+ (tcp-buffer
+ (make-array #.TCP-Bufsize
+ :element-type '(unsigned-byte 8)
+ :initial-element #.(char-code #\*))))
+
+ (declare (type (simple-array (unsigned-byte 8) (#.TCP-Bufsize)) tcp-buffer))
+
+ (format t "~&~%Prism DICOM Server ...")
+
+ (setf *Implementation-Version-Name* "PDS_1.5.1"
+ *Implementation-Class-UID* "1.2.840.113994.100.10.1.1")
+
+ (let* ((config-path (sys:getenv "PDS_CONFIG_DIRECTORY"))
+ (config-file (concatenate 'string config-path *config-file*)))
+ ;; Configuration file, if present, must be named and located by this var.
+ ;; Need exist only if desired to override default parameter values.
+ (declare (type simple-base-string config-file))
+ (cond ((probe-file config-file)
+ (format t "~&~%Loading configuration file: ~S~%" config-file)
+ (load config-file :verbose nil))
+ (t (format t "~&~%Configuration file not found: ~S~%" config-file))))
+
+ ;; Check here for erroneous configuration before starting main loop.
+ ;; Better to abort during startup than to crash during operation.
+ (dolist (dirname (list *patient-database*
+ *matched-pat-image-database*
+ *unmatched-pat-image-database*
+ *structure-database*))
+ (unless (probe-file dirname)
+ (error "RUN-SERVER [1] Non-existent directory: ~S" dirname)))
+
+ (format t "~%Logging at level: ~D, ~A~%" *log-level* (date/time))
+ (format t "~%Configuration parameters:~%~%")
+ (dolist (sym *reportable-variables*)
+ (let ((sym-value (symbol-value sym)))
+ (cond ((consp sym-value)
+ (format t " ~S~34TA list of values:~%" sym)
+ (dolist (val sym-value)
+ (format t "~37T~S~%" val)))
+ (t (format t " ~S~34T~S~%" sym sym-value)))))
+
+ (format t "~%Prism Dicom Server listening for connections.~%")
+
+ (setq accept-strm (socket:make-socket :connect :Passive
+ :address-family :Internet
+ :type :Stream
+ :format :Binary
+ :reuse-address nil
+ :backlog *qlen*
+ :local-port
+ (if *use-ssl* *ssl-port*
+ *pds-server-port*)))
+
+ (unwind-protect
+
+ (do ((connection-count 1 (the fixnum (1+ connection-count)))
+ (remote-IP-addr) (remote-IP-string "") (remote-port 0)
+ (local-IP-addr) (local-IP-string "") (local-port 0) (date-string "")
+ (callers *remote-entities*) (*remote-IP-string* nil nil)
+ (caller nil nil) (*status-message* nil nil) (*status-code* -1 -1)
+ (*patient-DB* nil nil) (*cached-dicom-pat-name* nil nil)
+ (*cached-image-DB* nil nil) (*image-ID/UID-alist* nil nil)
+ (*cached-dicom-pat-ID* nil nil) (*cached-prism-set-ID* nil nil)
+ (*cached-dicom-set-ID* nil nil) (*cached-prism-pat-ID* nil nil)
+ (*cached-prism-pat-name* nil nil) (*matched-pat-image-DB* nil nil)
+ (*unmatched-pat-image-DB* nil nil) (*structure-DB* nil nil)
+ (*checkpointed-environment* nil nil) (*max-datafield-len* nil nil)
+ (*new-im-index-records* nil nil) (*current-im-set-record* nil nil)
+ (*stored-image-count-per-set* 0 0)
+ (*stored-image-count-cumulative* 0 0)
+ (*dicom-alist* nil nil))
+ (( ))
+
+ (declare (type list callers caller *checkpointed-environment*
+ *new-im-index-records* *current-im-set-record*)
+ (type simple-base-string remote-IP-string local-IP-string
+ date-string)
+ (type (or null simple-base-string) *status-message*)
+ (type fixnum connection-count remote-port local-port
+ *stored-image-count-per-set*
+ *stored-image-count-cumulative*
+ *status-code*))
+
+ (prog ( )
+ AWAIT-CONNECTION
+ (mp:with-timeout
+ (*keepalive-timeout*
+ (format t "~&PDS: Live on ~A~%" (date/time))
+ (go AWAIT-CONNECTION))
+ (let ((temp-tcp-strm (socket:accept-connection accept-strm
+ :wait t)))
+ (setq tcp-strm
+ (if *use-ssl*
+ (socket:make-ssl-server-stream temp-tcp-strm
+ :certificate *certificate*
+ :key *private-key*)
+ temp-tcp-strm)))))
+ (setq date-string (date/time)
+ remote-IP-addr (socket:remote-host tcp-strm)
+ remote-IP-string
+ (or (ignore-errors (socket:ipaddr-to-dotted remote-IP-addr))
+ (format nil "~D" remote-IP-addr))
+ remote-port (socket:remote-port tcp-strm)
+ local-IP-addr (socket:local-host tcp-strm)
+ local-IP-string
+ (or (ignore-errors (socket:ipaddr-to-dotted local-IP-addr))
+ (format nil "~D" local-IP-addr))
+ local-port (socket:local-port tcp-strm))
+
+ ;; Refuse connections from unknown clients and log that fact
+ ;; in order to track intrusion attempts.
+ (cond
+ ;; If in "promiscuous" mode or IP address matches ...
+ ((or (null callers)
+ (consp (setq caller (assoc remote-IP-string callers
+ :test #'string=))))
+
+ ;; CALLER is item [3-list or 7-list] on *REMOTE-ENTITIES* describing
+ ;; client whose IP address we just accepted. If in "promiscuous"
+ ;; mode, CALLER is not set here and thus must be preset to NIL each
+ ;; iteration. Usage: to log third element, a client-naming string.
+
+ ;; Cache information for possible error logging.
+ (setq *remote-IP-string* remote-IP-string)
+
+ ;; Identify remote client each time it connects so messages to
+ ;; follow can be interpreted as to identity of client.
+ (format t
+ #.(concatenate 'string
+ "~&~%Accepting connection ~D, ~A ...~%"
+ " Client IP address: ~A, port ~D (~A)~%"
+ " Server IP address: ~A, port ~D~%")
+ connection-count date-string
+ remote-IP-string remote-port (or (third caller) "Unknown")
+ local-IP-string local-port)
+
+ (unwind-protect
+ (multiple-value-bind (val msg)
+ (ignore-errors
+ (dicom-mainloop tcp-buffer ;TCP buffer
+ tcp-strm ;TCP stream
+ nil ;Initial Environment
+ :Server ;Role or Mode
+ 'event-05)) ;Initial activating Event
+ (declare (ignore val))
+ (when (typep msg 'condition)
+ ;; If an unexpected error occurs, report error and
+ ;; abandon current connection by closing streams but
+ ;; keep server alive to listen for next connection.
+ (format t "~%RUN-SERVER error:~%~%")
+ (describe msg)))
+
+ ;; After DICOM-MAINLOOP termination server closes current
+ ;; connection and waits for a new one.
+ (close tcp-strm))
+
+ (when (or (null *status-message*)
+ (string= *status-message* "Success"))
+ ;; When association completes successfully, log results.
+ (let ((im-index-records *new-im-index-records*))
+ (declare (type list im-index-records))
+ (when (consp *image-ID/UID-alist*)
+ ;; *IMAGE-ID/UID-ALIST* is non-NIL if images were received.
+ ;; They may have been ignored [not written] either because
+ ;; they were non-axial images or because they were duplicates.
+ ;; Images are counted only if actually written to filesystem
+ ;; during the association.
+ (format t "~&Stored ~D images in this set.~%"
+ *stored-image-count-per-set*)
+ (format
+ t "~%Stored ~D images cumulatively in this association.~%"
+ *stored-image-count-cumulative*))
+ ;; If any new image sets were stored successfully during this
+ ;; association [not just for its last image set received],
+ ;; append records cached earlier to the "image.index" file now.
+ ;; This prevents Prism from accessing image sets before the
+ ;; association concludes.
+ (when (consp im-index-records)
+ ;; First element of each record is filename.
+ ;; CDR of each is actual record to append.
+ (let ((im-set-record *current-im-set-record*)
+ (*print-pretty* nil))
+ (declare (type list im-set-record))
+ ;; If current record is a new one, update it with number
+ ;; of images in this set. If current record was already
+ ;; in "image.index" file, do NOT update some other record
+ ;; which happens to be on the list of new records
+ ;; to append to index file.
+ (when (consp im-set-record)
+ (setf (fourth im-set-record)
+ (format nil "Set ~D (~D images): ~A"
+ (third im-set-record)
+ *stored-image-count-per-set*
+ (fourth im-set-record))))
+ ;; But whether or not current record is new, append any
+ ;; cached new records to file, using filename obtained
+ ;; from any of them [use first - all have same filename].
+ (with-open-file (strm (first (first im-index-records))
+ :direction :Output
+ :element-type 'base-char
+ :if-does-not-exist :Create
+ :if-exists :Append)
+ (dolist (item (nreverse im-index-records))
+ (format strm "~S~%" (cdr item))))))))
+
+ ;; Extra blank line to offset possible keepalives to follow.
+ (format t "~%Closing connection ~D, ~A.~%~%"
+ connection-count (date/time)))
+
+ (t (format t
+ #.(concatenate 'string
+ "~%Refusing connection ~D, ~A ...~%"
+ " Client IP address: ~A, port ~D~%"
+ " Server IP address: ~A, port ~D~%~%")
+ connection-count date-string remote-IP-string
+ remote-port local-IP-string local-port)
+ (close tcp-strm))))
+
+ ;; Close passive socket only when server exits due to some error
+ ;; or the receipt of a KILL signal from Unix.
+ (close accept-strm)
+ (format t "~%Closed ACCEPT socket, ~A, ...~% ~S~%~%Server exit.~%~%"
+ (date/time) accept-strm))
+
+ (values))
+
+;;;=============================================================
+;;; End.
diff --git a/make-prism.cl b/make-prism.cl
new file mode 100644
index 0000000..4752b8a
--- /dev/null
+++ b/make-prism.cl
@@ -0,0 +1,90 @@
+;;;
+;;; make-prism
+;;;
+;;; utility or convenience functions for building a standalone prism
+;;; executable or a dumped prism image.
+;;;
+;;; 26-Jun-2009 I. Kalet separated from prism.cl file to avoid loading
+;;; unnecessary modules. Ditto from wrapper-server.
+;;;
+
+(in-package :common-lisp-user)
+
+(defpackage "PRISM" (:use "COMMON-LISP"))
+
+(defpackage "DICOM" (:use "COMMON-LISP"))
+
+;;;--------------------------------------
+
+#+allegro
+(defun dump-prism-image (&optional (name "prism.dxl"))
+
+ "dump-prism-image is a convenience function for creating a dumped
+ lisp image file from the current loaded environment. If name is not
+ provided, the name is prism.dxl."
+
+ ;; Assumes system has already been compiled.
+ ;; Compile, load into a fresh Lisp, and then run this function.
+
+ (setf (sys:gsgc-switch :print) nil)
+ (setf (sys:gsgc-switch :stats) nil)
+ (setf (sys:gsgc-switch :verbose) nil)
+ (setq excl:*restart-app-function* 'prism::prism-top-level)
+ (excl:gc t)
+ (excl:dumplisp :name name)
+ (values))
+
+;;;--------------------------------------
+
+#+allegro
+(defun build-prism (&optional (dirname "prismsys/"))
+
+ "build-prism is a convenience function to create a set of files that
+comprise a standalone Prism system runnable without an installed
+Allegro CL system."
+
+ (excl:generate-application
+ "prism" dirname
+ (append (mk:files-in-system :slik :all :binary)
+ (mk:files-in-system :polygons :all :binary)
+ (mk:files-in-system :dicom-common :all :binary)
+ (mk:files-in-system :dicom-client :all :binary)
+ (mk:files-in-system :prism :all :binary))
+ :restart-app-function 'prism::prism-top-level
+ :discard-compiler t
+ )
+ "Standalone Prism system built")
+
+;;;-------------------------------------------------------------
+
+(defun dump-dicom-server (&optional (name "dicom.dxl"))
+ ;; Assumes system has already been compiled.
+ ;; Compile, load into a fresh Lisp, and then run this function.
+ (setf (sys:gsgc-switch :print) nil)
+ (setf (sys:gsgc-switch :stats) nil)
+ (setf (sys:gsgc-switch :verbose) nil)
+ (setq excl:*restart-app-function* 'dicom::run-server)
+ (excl:gc t)
+ (excl:dumplisp :name name)
+ (values))
+
+;;;--------------------------------------
+
+#+allegro
+(defun build-dicom (&optional (dirname "dicomsys/"))
+
+ "build-dicom is a convenience function to create a set of files that
+comprise a standalone Prism DICOM system runnable without an installed
+Allegro CL system."
+
+ (excl:generate-application
+ "dicom" dirname
+ (append (mk:files-in-system :dicom-common :all :binary)
+ (mk:files-in-system :dicom-server :all :binary))
+ :restart-app-function 'dicom::run-server
+ :discard-compiler t
+ )
+ "Standalone Prism DICOM system built")
+
+;;;--------------------------------------
+;;; End.
diff --git a/polygons/src/contour-algebra.cl b/polygons/src/contour-algebra.cl
new file mode 100644
index 0000000..13f2ba9
--- /dev/null
+++ b/polygons/src/contour-algebra.cl
@@ -0,0 +1,2003 @@
+;;;
+;;; contour-algebra
+;;;
+;;; provides contour-union and contour-differences and other related
+;;; functions
+;;;
+;;; 4-Mar-1991 J. Unger write CONTOUR-DIFFERENCE routine and
+;;; supporting code.
+;;; 20-Aug-1991 J. Unger optimize critical parts of Weiler code.
+;;; 20-Aug-1991 J. Unger add code to CONTOUR-DIFFERENCE to insure that all
+;;; contours are made CCW before being operated on.
+;;; 25-Sep-1991 J. Unger work on contour-diff code: optimization mods,
+;;; enhance to return multiple contour pieces (if orig gets
+;;; split during subtraction), to return correct result in
+;;; all cases of "nonintersection", to handle partially
+;;; coincident contours, and fixed bug in sum-of-angles.
+;;; Changed CONTOUR-DIFFERENCE interface and added
+;;; VERTEX-LIST-DIFFERENCE routine to replace old CONTOUR-DIFF.
+;;; 16-Jan-1992 J. Unger add contour union and intersection code.
+;;; 19-Feb-1992 J. Unger fix CLOCKWISE-TRAVERSAL-P to handle polygons with
+;;; edges that fold back on themselves.
+;;; 28-Feb-1992 J. Unger fix MAKE-NEAR-ANNULUS so it properly handles some
+;;; kinds of concave inner contours (in particular, ones which,
+;;; when intersected with a vertical line, partition the contour
+;;; into more than two pieces.
+;;; 10-Mar-1992 J. Unger redo MAKE-NEAR-ANNULUS to conform to oncologists'
+;;; specification - 'connecting tube' width made nonzero and
+;;; function internals reworked.
+;;; 19-May-1992 J. Unger enhance MAKE-NEAR-ANNULUS to avoid constructing
+;;; an annulus through an optionally supplied tumor contour
+;;; to VERTEX-LIST-DIFFERENCE.
+;;; 30-Mar-1993 I. Kalet split off from old contour-functions, make
+;;; independent of prism etc. - still needs the NEARLY- stuff
+;;; 6-May-1994 J. Unger modify EDGE-EDGE-INTERSECT to provide option
+;;; to always return the intersection point. Also added
+;;; ORTHO-EXPAND-CONTOUR and CENTROID functions.
+;;; 14-Jul-1994 J. Unger fix bug in ORTHO-EXPAND-CONTOUR (calls to
+;;; EDGE-EDGE-INTERSECT could return T - strip out the T's).
+;;; 21-Jul-1994 J. Unger add bounding-box from prism package.
+;;; 7-Aug-1994 J. Unger add REMOVE-ADJACENT-REDUNDANT-VERTICES here from
+;;; contour-editor module in prism package (formerly called
+;;; remove-repeats). Add REMOVE-ADJACENT-COLLINEAR-VERTICES.
+;;; 13-Sep-1994 J. Unger add AREA-OF-TRIANGLE and AREA-OF-POLYGON functions.
+;;; 23-Sep-1994 J. Unger add PERIMETER-OF-POLYGON function.
+;;; 1-Dec-1994 J. Jacky In REMOVE-ADJACENT-REDUNDANT-VERTICES, change
+;;; 0.1 in NEAR to 0.03, try to solve 1 mm leaf creep
+;;; 8-Jan-1995 I. Kalet remove proclaim form and make *pi-over-180*
+;;; local to the polygons package, not the geometry package.
+;;; 1-Sep-1995 I. Kalet change some macros to functions
+;;; 1-Mar-1997 I. Kalet change keyword :epsilon to &optional
+;;; 6-May-1997 BobGian fix AREA-OF-TRIANGLE to return true area (had
+;;; returned double it) and fix AREA-OF-POLYGON correspondingly.
+;;; 21-Jun-1997 BobGian convert miscellanous REVERSE -> NREVERSE
+;;; where safe (result of PUSH-building a list) - for efficiency.
+;;; Also standardize indentation, comments, linewidths, etc.
+;;; 24-Jun-1997 BobGian convert all instances of PI to
+;;; #.(coerce PI 'SINGLE-FLOAT) and ditto for (* 2.0 PI) --
+;;; must keep all flonums in Prism as SINGLE-FLOATs.
+;;; 2-Jul-1997 BobGian rewrite CLOCKWISE-TRAVERSAL-P with simpler algorithm.
+;;; Also exporte it in polygon-system.cl since it is used in
+;;; beam-dose calculations.
+;;; Replace *BIG* by its DEFCONSTANTed value - used only in two
+;;; places (VERTEX-IN-CONTOUR and GET-FAR-POINT) for apparently
+;;; different purposes; this way values can be optimized
+;;; independently.
+;;; Flush X-MAKE-NEAR-ANNULUS (apparent left-over cruft).
+;;; Rename *TUMOR* -> *TUMOR-CONTOUR* (consistent w comments).
+;;; 3-Jul-1997 BobGian uniformize IN-BOUNDING-BOX and COLLINEAR - that
+;;; is, there were two functions of same name and similar
+;;; functionality but different argument conventions in
+;;; different packages (PRISM and POLYGONS). Replace both
+;;; with single functions (defined here, in POLYGONS package),
+;;; used simpler arg convention and added optional EPSILON
+;;; arg with default value appropriate for each to be passed
+;;; to NEARLY-xxx functions within. Update all calls to them.
+;;; For IN-BETWEEN do all of same except for collapsing two
+;;; versions into one - exists only in this file.
+;;; In EDGE-EDGE-INTERSECT - add opt arg EPSILON with default
+;;; value 1.0e-4 (same val as previously-used *EPSILON* const)
+;;; which is passed to internal NEARLY-xxx predicates.
+;;; In SCAN-FOR-COINCIDENT-SEGMENTS - replace previously-used
+;;; *EPSILON* by its value, resulting in scaled val of 1.0e-2 .
+;;; 3-Jul-1997 BobGian change calls to NEAR to call NEAR-POINTS
+;;; or NEAR-COORDS with appropriate argument convention.
+;;; 7-Jul-1997 BobGian add CANONICAL-CONTOUR to combine functionality
+;;; of REMOVE-ADJACENT-COLLINEAR-VERTICES (fix bug and rewrite)
+;;; and REMOVE-ADJACENT-REDUNDANT-VERTICES.
+;;; 9-Jul-1997 BobGian change CANONICAL-CONTOUR to return NIL for a
+;;; degenerate contour: three collinear vertices or fewer
+;;; than three supplied - zero enclosed area in either case.
+;;; 25-Jul-1997 BobGian fix two stupid bugs I introduced earlier in
+;;; CLOCKWISE-TRAVERSAL-P (symptoms: inf loop & wrong result).
+;;; 25-Aug-1997 BobGian change #.(expression (coerce PI 'SINGLE-FLOAT))
+;;; to #.(coerce (expression PI))
+;;; that is, do math in double-precision first and then coerce to
+;;; single-float at end, all inside read-time computation.
+;;; 7-Sep-1997 BobGian place tests in CLOCKWISE-TRAVERSAL-P for correct
+;;; datatype/format in input vertex list [to track down persistent bug].
+;;; Also added fast tests for traversal direction in certain special cases.
+;;; 23-Sep-1997 BobGian flush *TUMOR-CONTOUR* global - pass explicitly
+;;; from VERTEX-LIST-DIFFERENCE to MAKE-NEAR-ANNULUS.
+;;; 30-Sep-1997 thru 14-Oct-1997 BobGian:
+;;; Destructure args to ANGLE-SUBTENDED (faster and less garbage created).
+;;; General reorganization - place defns in top-down order and grouped by
+;;; relatedness to aid readability.
+;;; Rename COLLINEAR -> COLLINEAR-P (CommonLisp predicate convention,
+;;; and far too many grep hits otherwise).
+;;; Move data-integrity test in CLOCKWISE-TRAVERSAL-P to separate
+;;; function: CHECK-CONTOUR, for debugging. Bug now found, so fcn
+;;; left in file but commented out. Related debug code removed.
+;;; Cleanup to REMOVE-ADJACENT-REDUNDANT-VERTICES.
+;;; Comment-out VERTEX-LIST-UNION and GET-UNION-CIRCUITS - nowhere used.
+;;; Rename CENTER -> POLYCENTER (less easily confused). Also add decls,
+;;; inline-expand AVERAGE, LO-HI-COMPARE - simpler, tighter, more robust.
+;;; General cleanup and recoding of BUILD-CIRCUIT-LIST, BUILD-STRAND,
+;;; FIND-ALL, PERIMETER-OF-POLYGON, ORTHO-EXPAND-CONTOUR, GET-PIPE.
+;;; Inline GET-PIPE in MAKE-NEAR-ANNULUS and remove it.
+;;; PERTURB-SEGMENT: convert macro to function - works by side-effect on
+;;; first two arguments which are 2-lists, not by modifying parameter
+;;; directly, and thus can be factored out as a function with significant
+;;; savings of duplicated code.
+;;; Pass both lists to be modified as explicit args rather than as 1st
+;;; and 2nd items on single list - avoids need for wrap-around lists.
+;;; Improve (for later use) and comment-out (not currently used):
+;;; AREA-OF-TRIANGLE, AREA-OF-POLYGON, PERIMETER-OF-POLYGON.
+;;; Add fcn DE-ANNOTATE to undo effects of annotation spliced in by fcn
+;;; CONTOUR-CONTOUR-INTERSECT [which violates spec for vertex lists by
+;;; appending third element to coordinate lists - so splice it out here].
+;;; Speedups: Change some instances of EQUALP to EQ [to detect end of
+;;; traversal of circular chain of VERTEX objects] or to EQUAL [to detect
+;;; list equality (not EQness) in FIND-ALL and STRAND-EQUAL].
+;;; VERTEX-LIST-INTERSECTION: convert to predicate since that is only usage
+;;; here - original version saved (commented-out) in case of restorage.
+;;; Move CONTOUR-ENCLOSES-P to POLYGONS package, this file. Replace former
+;;; VERTEX-IN-CONTOUR with it due to possibly incorrect operation
+;;; of former in certain case (ray to infinity tangent to contour vertex).
+;;; This also allows flushing of redundant CLOCKWISE-TRAVERSAL-P tests.
+;;; Fix CONTOUR-ENCLOSES-P so it returns NIL for point ON (not INSIDE)
+;;; the contour.
+;;; EDGE-EDGE-INTERSECT: wire epsilon value in code and make all args
+;;; required (opt args are major efficiency lossage in inner loop fcns);
+;;; change to return ONE vertex or NIL (not LIST of >= 1 vertices, and
+;;; not T for coincident segments). Change interfaces with its callers.
+;;; Make SCAN-FOR-COINCIDENT-SEGMENTS and FIND-CONTOUR-INTERSECTIONS return
+;;; multiple values instead of list of several items.
+;;; EDGE-CONTOUR-INTERSECT: takes contour arg as unwrapped list - last
+;;; element not repeated - un-CDRed contour passed as additional arg so
+;;; we can find closing element (first on contour) when CDRing off end.
+;;; CONTOUR-CONTOUR-INTERSECT: same transformation applied to first arg.
+;;; Second arg is also an unwrapped contour, supplied only to be passed
+;;; to EDGE-CONTOUR-INTERSECT.
+;;; FOUND-INTERSECTIONS -> FOUND-INTERSECTIONS? .
+;;; VERTEX-LIST-DIFFERENCE: Insert test for contour orientation.
+;;; 9-Nov-1997 BobGian improve CLOCKWISE-TRAVERSAL-P one more time.
+;;; 8-Jan-1998 BobGian correct bad declaration in CLOCKWISE-TRAVERSAL-P.
+;;; 22-Jan-1998 BobGian add declarations for speedup to CONTOUR-ENCLOSES-P.
+;;; 26-Mar-1998 I. Kalet in ortho-expand-contour, check if
+;;; edge-edge-intersect returned nil before adding to result list.
+;;; 22-May-1998 BobGian cosmetic tuneup to CLOCKWISE-TRAVERSAL-P.
+;;; 01-Jun-1998 BobGian fix mistake in CONTOUR-ENCLOSES-P function --
+;;; missing expression in collinearity test. Also fix error in Doc
+;;; string -- polarity of return value was mistakenly reversed.
+;;; 03-Feb-2000 BobGian returned AREA-OF-TRIANGLE and AREA-OF-POLYGON to
+;;; active duty (exported and used in electron dosecalc); cosmetic fixes.
+;;; Change RETURN-FROM to RETURN where semantically equivalent.
+;;; 11-May-2000 BobGian found another double-float PI - coerced to
+;;; single-float in ROTATE-VERTICES.
+;;; 06-Sep-2000 BobGian fix ambiguous error messages in CLOCKWISE-TRAVERSAL-P.
+;;; 30-May-2001 BobGian:
+;;; Wrap generic arithmetic with THE-declared types.
+;;; Wrap SQRT in THE declarations to allow inlining.
+;;; Inline AREA-OF-TRIANGLE in AREA-OF-POLYGON.
+;;; Comment-out AREA-OF-TRIANGLE (nowhere used).
+;;;
+
+;;;
+;;; Includes:
+;;;
+;;; Weiler algorithm for determining contour difference. The contours in
+;;; the published algorithms have been renamed circuits here to avoid
+;;; confusion with our own CLOS contour objects. See the contour functions
+;;; implemention report for a general overview of the algorithm.
+;;;
+;;; References:
+;;;
+;;; (1) J.D. Foley et al: Computer Graphics, 2nd Edition, pp 937-945
+;;; (2) K. Weiler: "Polygon Comparison using a Graph Representation" in
+;;; SIGGRAPH '80, pp 10-18.
+;;;
+;;; See the comment in MAKE-NEAR-ANNULUS for modifying the 'tube width'.
+;;;
+;;; Future possible things to do:
+;;; o optimize EDGE-EDGE-INTERSECT with bounding box tests
+;;;
+;;; All contours are represented as vertex lists which are OPEN: first element
+;;; is NOT repeated as last, meaning the contour contains an implied edge from
+;;; last vertex to first. Most functions which need to CDR down such vertex
+;;; lists take two args for the contour - the list being CDRed down, and the
+;;; original (unCDRed) list to supply the first element (closing vertex of
+;;; contour) when CDRing off the end of the CDRed list.
+
+(in-package :polygons)
+
+;;;--------------------
+
+(defstruct circuit
+ owner
+ strand)
+
+(defstruct vertex
+ coords
+ intersect-p
+ owner
+ next
+ prev)
+
+;; The strand field of a circuit is a pointer to a doubly linked list
+;; of vertex structures (each vertex structure linked through its next
+;; and prev fields).
+
+;;;--------------------
+
+(defun see-strand (s)
+
+ "see-strand s
+
+Prints the coordinates of each member of a strand on the screen.
+Used for debugging."
+
+ (let ((r s))
+ (loop
+ (format t "~S ~S ~S ~S ~S ~S ~S ~%"
+ (vertex-coords r)
+ (vertex-owner r)
+ (vertex-intersect-p r)
+ (vertex-coords (vertex-next r))
+ (vertex-owner (vertex-next r))
+ (vertex-coords (vertex-prev r))
+ (vertex-owner (vertex-prev r)))
+ (cond ((eq (vertex-next r) s)
+ (return (values)))
+ (t (setq r (vertex-next r)))))))
+
+;;;--------------------
+
+(defun bounding-box (cntr)
+
+ "bounding-box cntr
+
+Given CNTR, a list of two-element vertices, returns list of two vertices,
+the lower left corner and upper right corner of the bounding box."
+
+ (if (null cntr) '((0.0 0.0) (0.0 0.0))
+ (let ((xs (mapcar #'first cntr))
+ (ys (mapcar #'second cntr)))
+ (list (list (apply #'min xs) (apply #'min ys))
+ (list (apply #'max xs) (apply #'max ys))))))
+
+;;;--------------------
+
+(defun collinear-p (v1x v1y ptx pty v2x v2y &optional (epsilon 1.0e-2))
+
+ "collinear-p v1x v1y ptx pty v2x v2y &optional (epsilon 1.0e-2))
+
+Returns T iff (V1X V1Y), (PTX PTY), and (V2X V2Y) are collinear
+to within EPSILON."
+
+ ;; Note - if EPSILON is too small, then some triples of points which
+ ;; are truly collinear will not be detected as such. At EPSILON
+ ;; = 1.0e-4, it's definitely too small.
+ ;;
+ ;; 3 points are collinear if cross-product of vector from 1st to 2nd and
+ ;; vector from 1st to 3rd is "nearly" zero. Rather than compare difference
+ ;; of two quantities with zero, we compare two quantities with each other.
+ ;; 1st is (V1X V1Y), 2nd is (PTX PTY), and 3rd is (V2X V2Y).
+
+ (declare (single-float v1x v1y ptx pty v2x v2y epsilon))
+
+ (< (- epsilon)
+ (- (* (- ptx v1x) (- v2y v1y))
+ (* (- pty v1y) (- v2x v1x)))
+ epsilon))
+
+;;;--------------------
+
+(defun in-between (v1x v1y ptx pty v2x v2y &optional (epsilon 1.0e-5))
+
+ "in-between v1x v1y ptx pty v2x v2y &optional (epsilon 1.0e-5)
+
+Returns T if (PTX, PTY) is on the line segment determined by (V1X, V1Y)
+and (V2X, V2Y), widened by EPSILON in both directions, NIL otherwise."
+
+ ;; COLLINEAR-P and IN-BOUNDING-BOX use different EPSILONs. Value used
+ ;; here is IN-BOUNDING-BOX's value, which is scaled by 1000.0 for
+ ;; use by COLLINEAR-P . Reason for difference: one uses tolerance
+ ;; for actual coordinate values while other uses it for comparing
+ ;; cross-product to zero. Cruft-up-the-wazoo here.
+
+ (declare (single-float v1x v1y ptx pty v2x v2y epsilon))
+
+ (and (collinear-p v1x v1y ptx pty v2x v2y (* epsilon 1.0e3))
+ (in-bounding-box v1x v1y ptx pty v2x v2y epsilon)))
+
+;;;--------------------
+
+(defun in-bounding-box (a b x y c d &optional (epsilon 1.0e-5))
+
+ "in-bounding-box a b x y c d &optional (epsilon 1.0e-5)
+
+Returns T if (x, y) is in the bounding box determined by (a,b) and (c,d),
+NIL otherwise."
+
+ (declare (single-float a b x y c d epsilon))
+
+ (and (or (nearly-increasing a x c epsilon)
+ (nearly-decreasing a x c epsilon))
+ (or (nearly-increasing b y d epsilon)
+ (nearly-decreasing b y d epsilon))))
+
+;;;--------------------
+
+(defun canonical-contour (verts)
+
+ "canonical-contour verts
+
+Post-processes VERTS (a list of vertices representing a contour, with
+implied wraparound from last to first) by removing adjacent redundant
+vertices (those extremely close to each other) and vertices internal
+to chains that comprise adjacent collinear segments. If resultant
+contour would enclose zero area or is otherwise invalid, returns NIL."
+
+ (let ((output (remove-adjacent-collinear-vertices
+ (remove-adjacent-redundant-vertices verts nil))))
+ ;;
+ (cond ((null (cddr output))
+ ;; Degenerate case - interior vertices of collinear chain
+ ;; have been removed leaving only 2 vertices - or fewer than
+ ;; 3 vertices were supplied in the first place. Return NIL
+ ;; to indicate degenerate (zero area) contour.
+ nil)
+ (t output))))
+
+;;;--------------------
+
+(defun remove-adjacent-redundant-vertices (sv internal?)
+
+ "remove-adjacent-redundant-vertices sv internal?
+
+Deletes all adjacent duplicate vertices of SV, including the endpoints.
+The INTERNAL? parameter is T only during recursive calls."
+
+ (cond (internal?
+ (cond ((cdr sv) ; need >= 2 vertices to compare
+ (let ((pt1 (car sv))
+ (rem (cdr sv)))
+ (loop
+ (cond ((and rem ;Use 0.03 below, not 0.1 or 10e-4
+ (near-points pt1 (first rem) 0.03))
+ (setq rem (cdr rem)))
+ (t (return))))
+ (cons pt1 (remove-adjacent-redundant-vertices rem t))))
+ (t sv)))
+ ;;
+ ;; Else, if called from outide, first call on the entire list,
+ ;; and then check explicitly front and end for duplicate points.
+ ;;
+ (t (let ((result (remove-adjacent-redundant-vertices sv t)))
+ (if (and (cdr result) ;Length >= 2
+ (near-points (first result)
+ (car (last result))
+ 0.03)) ;Same epsilon as used above.
+ ;; First point "near" last - throw away first point.
+ (cdr result)
+ ;; Otherwise return whole list.
+ result)))))
+
+;;;----------------------------------
+
+(defun remove-adjacent-collinear-vertices (verts)
+
+ "remove-adjacent-collinear-vertices verts
+
+Strips out vertices in VERTS found to lie in the middle of chains
+of adjacent collinear points, with the endpoints treated as wrapping
+around to the beginning again."
+
+ (setq verts (remove-adjacent-collinear-vertices-int verts))
+ (cond ((null (cdddr verts))
+ ;;Must be at least 4 vertices - if three or fewer are returned
+ ;;by REMOVE-ADJACENT-COLLINEAR-VERTICES-INT, we know they can't
+ ;;be collinear.
+ verts)
+ ;;
+ (t (let* ((tail (nthcdr (- (length verts) 2) verts))
+ (s1 (first verts))
+ (s2 (second verts))
+ (e1 (first tail))
+ (e2 (second tail))
+ (s1x (first s1))
+ (s1y (second s1))
+ (s2x (first s2))
+ (s2y (second s2))
+ (e1x (first e1))
+ (e1y (second e1))
+ (e2x (first e2))
+ (e2y (second e2))
+ (collin-e1-e2-s1? (collinear-p e1x e1y e2x e2y s1x s1y))
+ (collin-e2-s1-s2? (collinear-p e2x e2y s1x s1y s2x s2y)))
+ (cond ((and collin-e1-e2-s1? collin-e2-s1-s2?)
+ ;; First two and last two collinear -
+ ;; trim first and last.
+ (butlast (cdr verts)))
+ (collin-e2-s1-s2?
+ ;; Last and first two collinear - trim first.
+ (cdr verts))
+ (collin-e1-e2-s1?
+ ;; Last two and first collinear - trim last.
+ (butlast verts))
+ (t verts))))))
+
+;;;----
+
+(defun remove-adjacent-collinear-vertices-int (verts)
+ ;;
+ ;; Utility used only by REMOVE-ADJACENT-COLLINEAR-VERTICES.
+ ;; Removes interiors of collinear triples without end/beginning wrapping.
+ ;;
+ (cond ((null (cddr verts)) ; < 3 verts can't be collinear.
+ ;; Return them all because inner recursive call is building
+ ;; partial result upward at this point.
+ verts)
+ ;;
+ ((let ((v1 (first verts))
+ (v2 (second verts))
+ (v3 (third verts)))
+ (collinear-p (first v1) (second v1)
+ (first v2) (second v2)
+ (first v3) (second v3)))
+ ;; First three collinear - remove middle one and try again
+ ;; without shifting along in list.
+ (remove-adjacent-collinear-vertices-int
+ (cons (first verts) (cddr verts))))
+ ;;
+ ;; Otherwise, shift by one and examine next set of three vertices.
+ (t (cons (first verts)
+ (remove-adjacent-collinear-vertices-int (cdr verts))))))
+
+;;;--------------------
+;;; Error-check on validity of vertex-list inputs.
+;;; Left here (commented-out) as debugging aid.
+
+#+Ignore
+(defun check-contour (vlist)
+
+ (unless (and (consp vlist) ;Must be a list
+ (cddr vlist) ; of length at least 3
+ (dolist (vert vlist t) ; and each vertex
+ (unless (and (consp vert) ; must be a list
+ (= (length vert) 2) ; of length 2
+ (dolist (num vert t) ; and each element
+ (unless (typep num 'single-float) ; a s-float
+ (return nil))))
+ (return nil))))
+ (error "CHECK-CONTOUR - Bad vertex-list: ~S" vlist))
+
+ vlist) ;Pass-through for convenience of caller
+
+;;;--------------------
+
+(defun clockwise-traversal-p (vlist)
+
+ "clockwise-traversal-p vlist
+
+returns T if the vertex order in V-LIST (list of vertices, each a list
+of X, Y coords) is a clockwise traversal; NIL if counter-clockwise."
+
+ ;; Scan for leftmost vertex [minimal X-coordinate], saving both first and
+ ;; last one found, which may be the same if leftmost vertex is unique.
+
+ (unless (consp vlist)
+ (error "CLOCKWISE-TRAVERSAL-P [1] Empty contour."))
+
+ (do ((v1s vlist v2s) ;List starting with First of three
+ (v2s (cdr vlist) v3s) ;List starting with Second
+ (v3s (cddr vlist) (or (cdr v3s) vlist)) ;List st w Third
+ (xmin #.most-positive-single-float) ;Accum for min X coord
+ (vprev) ;Vertex one back from first leftmost
+ (vleft) ;First leftmost vertex found
+ (vnext) ;Vertex one fwd from first leftmost
+ (test 0.0)) ;Local var for comparison
+ ((and (consp vleft) ;Done when we have an answer
+ (eq v1s vlist)) ;and input recycles to beg of VLIST
+
+ ;; After scan, VLEFT holds first leftmost vertex found.
+ ;; Others with same X coord are ignored.
+ (when (or (eq vleft vnext)
+ (eq vleft vprev))
+ (error "CLOCKWISE-TRAVERSAL-P [2] Duplicated vertex."))
+
+ ;; Compare slope of line from VLEFT to VNEXT (slopeN) with slope
+ ;; of line from VLEFT to VPREV (slopeP).
+ ;; either slopeN or slopeP infinite -> vertical line -> non-unique
+ ;; leftmost vertex -- determine orientation by comparing Y coords.
+ ;; slopeN = slopeP is impossible -- collinear triple,
+ ;; slopeN > slopeP -> contour is CW,
+ ;; slopeN < slopeP -> contour is CCW,
+ (let ((vpx (first vprev))
+ (vpy (second vprev))
+ (vlx (first vleft))
+ (vly (second vleft))
+ (vnx (first vnext))
+ (vny (second vnext)))
+ (declare (single-float vpx vpy vlx vly vnx vny))
+ (cond
+ ((= vpx vlx)
+ (cond ((< vpy vly) t) ;CW traversal
+ ((> vpy vly) nil) ;CCW traversal
+ (t (error "CLOCKWISE-TRAVERSAL-P [3] Dup prev vertex."))))
+ ((= vlx vnx)
+ (cond ((< vly vny) t) ;CW traversal
+ ((> vly vny) nil) ;CCW traversal
+ (t (error "CLOCKWISE-TRAVERSAL-P [4] Dup next vertex."))))
+ (t (let ((slopeN (/ (- vny vly)
+ (- vnx vlx)))
+ (slopeP (/ (- vpy vly)
+ (- vpx vlx))))
+ (declare (single-float slopeN slopeP))
+ (cond ((> slopeN slopeP) t) ;CW traversal
+ ((< slopeN slopeP) nil) ;CCW traversal
+ (t (error "CLOCKWISE-TRAVERSAL-P [5] Collinear."))))))))
+ ;;
+ (declare (single-float test xmin))
+ ;;
+ ;; Find and track first instance of leftmost vertex so far.
+ (when (< (setq test (caar v2s)) xmin)
+ (setq xmin test
+ vprev (car v1s)
+ vleft (car v2s)
+ vnext (car v3s)))))
+
+;;;--------------------
+;;;
+;;; There currently is no invariant in prism about clockwise/counterclockwise
+;;; contours, so we need to insure that all contours input here are COUNTER
+;;; clockwise, before doing anything with them.
+;;;
+;;; When Prism is finished, contours and polylines with redundant vertices
+;;; will be screened out at the user-input phase. At the moment, however,
+;;; bad contours/polylines may be lurking around so we explicitly remove
+;;; the redundant vertices before getting down to business.
+;;;
+;;;---------------------------------------------------------------------------
+;;; There is a test for contour orientation (and reversal if not already CCW)
+;;; here. Since I am unsure if this is always required, and since it is NOT
+;;; on inner calls, whether to do this test is controlled by an optional
+;;; fourth argument. - BobGian
+;;;---------------------------------------------------------------------------
+;;;
+
+(defun vertex-list-difference (a1 a2 &optional a3 inputs-known-CCW?)
+
+ "vertex-list-difference a1 a2 &optional a3 inputs-known-CCW?
+
+Given two vertex lists A1 and A2, each a list of (x, y) pairs which
+implicitly encloses a region of the plane, returns a list of vertex lists
+which enclose the region of space that remains when A2 is subtracted from
+A1. NIL is returned if A1 lies completely within A2; an annulus shaped
+vertex list is returned if A2 lies completely within A1. More than one
+vertex list may be on the returned list if the resulting difference consists
+of several separate regions. If an optional vertex list A3 is supplied,
+then in the case that A1 lies completely within A2, attempts will be made to
+prevent the resulting annulus vertex list from crossing A3. This cannot be
+guaranteed, though. All input contours must normally be CCW, and they are
+tested and reversed if necessary unless INPUTS-KNOWN-CCW? is non-NIL."
+
+ ;; The last step of the 'preprocessing' is to perturb vertices of any
+ ;; segments coincident to both contours, so that no such coincident
+ ;; segments remain - this will make the merge step easier, should the
+ ;; perturbed contours still intersect (see FIND-CONTOUR-INTERSECTIONS).
+ ;;
+ (let ((v1 (remove-redundant-vertices a1))
+ (v2 (remove-redundant-vertices a2)))
+ ;;
+ ;; Setup ... Make sure all contours are traversed in CCW direction.
+ ;; Don't bother if not necessary - this could be time-expensive for
+ ;; inner calls.
+ (unless inputs-known-CCW?
+ (when (clockwise-traversal-p v1)
+ (setq v1 (reverse v1)))
+ (when (clockwise-traversal-p v2)
+ (setq v2 (reverse v2)))
+ (when (and (consp a3)
+ (clockwise-traversal-p a3))
+ (setq a3 (reverse a3))))
+ ;;
+ (multiple-value-bind (isecs-1 isecs-2)
+ (find-contour-intersections v1 v2)
+ ;;
+ (if (found-intersections? isecs-1)
+ ;;
+ ;; contours intersect - merge them, determine which of the merged
+ ;; circuits are external to both V1 and V2, extract contours from
+ ;; these circuits, and return on a list.
+ ;;
+ ;; BUILD-CIRCUIT-LIST "de-annotates" vertices in intersection lists.
+ ;;
+ (extract-contours
+ (get-difference-circuits
+ (determine-owners
+ (merge-circuits
+ (build-circuit-list isecs-1 isecs-2)))))
+ ;;
+ ;; Contours don't intersect - use CONTOUR-ENCLOSES-P to test whether
+ ;; V1 is inside V2 (return NIL if so); else use test again to see if
+ ;; V2 is inside V1 (return near annulus if so); else two contours
+ ;; must be completely separate, so return V1 unchanged. Note that
+ ;; a singleton list must be returned if result is not NIL, for
+ ;; consistency with above case.
+ ;;
+ ;; CAAR gets FIRST of FIRST - ie, X coord of first elem of contour.
+ ;; CADAR gets SECOND of FIRST - ie, Y coord of first elem of contour.
+ (cond ((contour-encloses-p isecs-2 (caar isecs-1) (cadar isecs-1))
+ nil)
+ ((contour-encloses-p isecs-1 (caar isecs-2) (cadar isecs-2))
+ (list (make-near-annulus (de-annotate isecs-1)
+ (de-annotate isecs-2)
+ a3)))
+ (t (list v1)))))))
+
+;;;--------------------
+
+(defun get-difference-circuits (circuits)
+
+ "get-difference-circuits circuits
+
+Finds and returns the list of circuits that consists of vertices internal to
+the first original contour and external to the second original contour,
+by finding all occurrences of circuits owned by both X and A, and then
+removing the duplicate circuits. One circuit will be returned for each
+distinct region of the difference. If no such circuits exist, then it
+must be the case that the two contours intersect but do not 'overlap';
+this can occur if the two touch but do not share any common area (in
+which case the circuit corresponding to the first contour is returned)
+or if the first is completely inside the second, but touches the second
+somewhere (in which case nil is returned)."
+
+ (or
+
+ ;; If there are any circuits owned by AX, return them.
+
+ (remove-duplicates
+ (append
+ (find-all '(A X) circuits :key #'circuit-owner)
+ (find-all '(X A) circuits :key #'circuit-owner))
+ :test #'strand-equal
+ :key #'circuit-strand)
+
+ ;; Otherwise, if there are any circuits owned by B, this is an indication
+ ;; that the 'A' contour lies outside of the 'B' contour, (and nothing
+ ;; interrupts the 'B' contour line), so find and return the 'A' contour.
+
+ (if (find-all '(B) circuits :key #'circuit-owner)
+ (remove-duplicates
+ (find-all '(A) circuits :key #'circuit-owner)
+ :test #'strand-equal
+ :key #'circuit-strand)
+
+ ;; Otherwise, the 'A' contour lies inside the 'B' contour; return NIL.
+
+ nil)))
+
+;;;--------------------
+
+(defun make-near-annulus (c1 c2 c3)
+
+ "make-near-annulus c1 c2 c3
+
+Returns a near annulus (a 'C' with a narrow opening) constructed from
+C1 and C2, the former of which is assumed to completely enclose the
+latter. C3 is optional 3rd arg sent to VERTEX-LIST-DIFFERENCE.
+Supplied contours must be counter-clockwise."
+
+ ;; Algorithm: We will drill a pipe between the inner contour (C2) and
+ ;; the outer one (C1) to connect the interior of C2 with the 'outside
+ ;; world'. When the implication is that C2 is a critical structure contour
+ ;; and C1 is a target contour, care must be taken to insure that the pipe
+ ;; does not pass through the tumor from which the target was originally
+ ;; generated, if possible. Thus, an effort will be made to direct the
+ ;; pipe away from the tumor contour (C3). This is done by determining
+ ;; the centers of C2 and C3 and orienting the pipe on the line from the
+ ;; center of C2 directly away from the center of C3. Denote the centers
+ ;; of C2 and C3 as P2 and P3 respectively. A ray from P3 through P2 is
+ ;; considered, and the furthest point of intersection between the ray
+ ;; and C2 is determined (this point is on the 'outside surface' of C2).
+ ;; This ray is actually the segment from P3 to PF, a point far away along
+ ;; the ray. Then find the closest point of intersection between C1 and
+ ;; the ray pointing in the same direction but starting at V. This point
+ ;; of intersection is on the 'inside surface' of C1; denote it W.
+ ;; Then define a thin vertical rectangular 'pipe' contour one end of which
+ ;; extends from V slightly across C2 and the other extending from W slightly
+ ;; across C1. The pipe is centered lengthwise about the VW segment. Take
+ ;; the VERTEX-LIST-DIFFERENCE of the pipe from C1, and then take the
+ ;; VERTEX-LIST-DIFFERENCE of C2 from this result. The second result
+ ;; will be the desired annulus - the outer contour with the pipe and
+ ;; inner contour removed from it
+
+ ;; NOTE - There are some configurations of C1, C2, and C3 for which this
+ ;; algorithm will NOT guarantee that the pipe does not pass through C3.
+ ;; In particular, it is impossible if C2 lies entirely within C3. If this
+ ;; condition occurs, a warning is issued. THERE ARE OTHER configurations
+ ;; of the three contours as well, for which this problem occurs, which are
+ ;; not checked. If C3 snakes around C2 entirely, but does not actually
+ ;; intersect it, for example. It is assumed that the contours returned by
+ ;; MAKE-NEAR-ANNULUS will be available for manual editing if this should be
+ ;; necessary.
+
+ ;; NOTE - C3 is obtained from the optional third argument to
+ ;; VERTEX-LIST-DIFFERENCE. It is NIL if there is no need to be
+ ;; concerned about pipe-tumor intersections, in which case
+ ;; an upward pointing pipe is created.
+
+ (let* ((p2 (polycenter c2))
+ (p3 (if c3 (polycenter c3)
+ (list (first p2) (- (the single-float (second p2)) 1.0))))
+ (pf (get-far-point p3 p2))
+ (v (first (sort (edge-contour-intersect p3 pf c2 c2)
+ #'(lambda (a b)
+ (in-between (first p3) (second p3)
+ (first b) (second b)
+ (first a) (second a))))))
+ (w (first (sort (edge-contour-intersect v pf c1 c1)
+ #'(lambda (a b)
+ (in-between (first v) (second v)
+ (first a) (second a)
+ (first b) (second b))))))
+ ;;
+ (r1 (vertex-list-difference
+ c1
+ ;; This is the "pipe" of width 0.2, aligned lengthwise along the
+ ;; segment from V to W. The 'tube width' can be adjusted by
+ ;; changing the constant 0.2 below. - Jon Unger
+ ;; NB: The pipe is actually 0.4 wide, since we perturb each side
+ ;; 0.2 units from starting position in direction away from its
+ ;; opposite side. - BobGian
+ (let ((v1 (copy-list v)) ;Copy all 4 vertices to be modified
+ (v2 (copy-list v))
+ (w1 (copy-list w))
+ (w2 (copy-list w)))
+ (perturb-segment v1 w1 0.2) ;Perturb long sides outward
+ (perturb-segment w2 v2 0.2)
+ (perturb-segment w1 w2 0.2) ;Perturb short sides outward
+ (perturb-segment v2 v1 0.2)
+ (list w1 w2 v2 v1)) ;CCW traversal around pipe
+ nil ;Pipe already supplied.
+ t)) ;Argument orientation already checked.
+ (r2 (vertex-list-difference (first r1) c2 nil t)))
+ ;;
+ (when c3
+ (if (not (vertex-list-difference c2 c3 nil t))
+ (warn "A critical structure lies completely within the target.~%")
+ (when (vertex-list-intersection c2 c3)
+ (warn "A critical structure intersects the target.~%"))))
+ ;;
+ (first r2)))
+
+;;;--------------------
+
+(defun polycenter (poly)
+
+ "polycenter poly
+
+Returns a two element list, the x and y coordinate of the center of
+the polygon poly. The coordinates are determined only by finding the
+min and max values in each axis and then taking the mid point between."
+
+ (let ((min-x #.most-positive-single-float)
+ (max-x #.most-negative-single-float)
+ (min-y #.most-positive-single-float)
+ (max-y #.most-negative-single-float))
+ (declare (single-float min-x max-x min-y max-y))
+ (dolist (vert poly)
+ (let ((x (first vert))
+ (y (second vert)))
+ (declare (single-float x y))
+ (when (< x min-x)
+ (setq min-x x))
+ (when (> x max-x)
+ (setq max-x x))
+ (when (< y min-y)
+ (setq min-y y))
+ (when (> y max-y)
+ (setq max-y y))))
+ (list (* 0.5 (+ min-x max-x))
+ (* 0.5 (+ min-y max-y)))))
+
+;;;--------------------
+
+(defun get-far-point (p q)
+
+ "get-far-point p q
+
+Returns a point along the ray from p through q, very far away from both.
+Used by MAKE-NEAR-ANNULUS."
+
+ ;; NOTE - if 1.0e5 is too big (say 1.0e10) here, for unknown reasons
+ ;; things screw up! [Overflow, perhaps?]
+
+ (let ((px (first p))
+ (py (second p))
+ (qx (first q))
+ (qy (second q)))
+ (list (+ px (* 1.0e5 (- qx px)))
+ (+ py (* 1.0e5 (- qy py))))))
+
+;;;--------------------
+
+#+Ignore ;Nowhere Used
+(defun vertex-list-union (a1 a2)
+
+ "vertex-list-union a1 a2
+
+Given two vertex lists, A1 and A2, each a list of (x y) pairs which
+implicitly encloses a region of the plane, returns a list of vertex
+lists which enclose the region of space that results from the union of
+the regions enclosed by A1 and A2. If A1 and A2 share some overlap,
+then this list consists of a single vertex list; otherwise, A1 and A2
+are returned on the list unchanged.
+
+NOTE that in the case where the union of two vertex lists results in a
+vertex list with one or more holes in the middle, this algorithm will
+return only the outermost vertex list and not the holes."
+
+ ;; The last step of the 'preprocessing' is to perturb vertices of any
+ ;; segments coincident to both contours, so that no such coincident
+ ;; segments remain - this will make the merge step easier, should the
+ ;; perturbed contours still intersect (see FIND-CONTOUR-INTERSECTIONS).
+ ;;
+ (let ((v1 (remove-redundant-vertices a1))
+ (v2 (remove-redundant-vertices a2)))
+ (multiple-value-bind (isecs-1 isecs-2)
+ (find-contour-intersections v1 v2)
+ ;;
+ (if (found-intersections? isecs-1)
+ ;;
+ ;; contours intersect - merge them, determine which of the merged
+ ;; circuits are internal to V1 but external to V2, extract contours
+ ;; from these circuits and return on a list.
+ ;;
+ ;; BUILD-CIRCUIT-LIST "de-annotates" vertices in intersection lists.
+ ;;
+ (extract-contours
+ (get-union-circuits
+ (determine-owners
+ (merge-circuits
+ (build-circuit-list isecs-1 isecs-2)))))
+ ;;
+ ;; Contours don't intersect - use CONTOUR-ENCLOSES-P to test whether
+ ;; V1 is inside V2 (return V2 if so); else use test again to see if
+ ;; V2 is inside V1 (return V1 if so); else two contours must be
+ ;; completely separate, so return them both unchanged. Note that
+ ;; a singleton list must be returned if result is a single contour,
+ ;; for consistency with separate contours case.
+ ;;
+ ;; CAAR gets FIRST of FIRST - ie, X coord of first elem of contour.
+ ;; CADAR gets SECOND of FIRST - ie, Y coord of first elem of contour.
+ (cond ((contour-encloses-p isecs-2 (caar isecs-1) (cadar isecs-1))
+ (list v2))
+ ((contour-encloses-p isecs-1 (caar isecs-2) (cadar isecs-2))
+ (list v1))
+ (t (list v1 v2)))))))
+
+;;;--------------------
+
+#+Ignore ;Nowhere Used
+(defun get-union-circuits (circuits)
+
+ "get-union-circuits circuits
+
+Finds and returns the list of circuits that consists of vertices
+internal either to the first or second original contours, by finding
+all occurrences of circuits owned solely by X, and then removing the
+duplicate circuits. Under normal operation, the result should be
+a single, distinct circuit when the two original contours overlap.
+
+NOTE that if the union of the two original contours results in a
+contour with holes in it, this routine will return only the outermost
+contour and not the holes."
+
+ ;; find any circuits owned solely by X.
+
+ (let ((x-circs
+ (remove-duplicates
+ (find-all '(X) circuits :key #'circuit-owner)
+ :test #'strand-equal
+ :key #'circuit-strand)))
+
+ ;; If there are more than one of these circuits, then what was output was
+ ;; an outer contour with holes in it. Figure out which are the holes
+ ;; by picking a point from the first contour and testing to see if that
+ ;; point is inside any of the other contours. The outer contour is the
+ ;; contour that it is inside, or if no points are inside, then the contour
+ ;; from which the point was taken is the outer contour. Return only the
+ ;; the outer contour. Otherwise, return the single circuit which was
+ ;; generated.
+
+ (if (> (length x-circs) 1)
+ (let* ((extracted (extract-contours x-circs))
+ (vert (first (first extracted)))
+ (outer-index
+ (position t (mapcar #'(lambda (vlist)
+ (contour-encloses-p vlist
+ (first vert)
+ (second vert)))
+ (cdr extracted))))
+ (outer (if outer-index
+ (nth (1+ outer-index) x-circs) ; select from x-circs
+ (first x-circs)))) ; it was vert's contour
+ (list outer))
+ x-circs)))
+
+;;;--------------------
+;;; This version is written as a predicate (returning only T/NIL) since
+;;; that is the only usage of this function in the POLYGONS system (and
+;;; this function is referenced nowhere else).
+
+(defun vertex-list-intersection (a1 a2)
+
+ "vertex-list-intersection a1 a2
+
+Given two vertex lists, A1 and A2, each a list of (x y) pairs which
+implicitly encloses a region of the plane, returns T if the regions of
+space enclosed by the contours they represent intersect, NIL otherwise."
+
+ ;; This version of VERTEX-LIST-INTERSECTION does NOT depend on the contours
+ ;; being traversed in CCW orientation, but for consistency with other code
+ ;; that condition SHOULD be true [ie, WILL be true modulo bugs].
+ ;;
+ (let ((v1 (remove-redundant-vertices a1))
+ (v2 (remove-redundant-vertices a2)))
+ (multiple-value-bind (isecs-1 isecs-2)
+ (find-contour-intersections v1 v2)
+ ;;
+ (cond
+ ((found-intersections? isecs-1)
+ ;; Contours intersect, implying spatial regions also intersect.
+ t)
+ ;;
+ ;; Contours don't intersect - use CONTOUR-ENCLOSES-P to test if V1
+ ;; is enclosed by V2 or V2 is enclosed by V1 - Return T if so.
+ ;; CAAR gets FIRST of FIRST: X coord of contour first elem.
+ ;; CADAR gets SECOND of FIRST: Y coord of contour first elem.
+ ((or (contour-encloses-p isecs-2 (caar isecs-1) (cadar isecs-1))
+ (contour-encloses-p isecs-1 (caar isecs-2) (cadar isecs-2))))
+ ;; Otherwise contours must be completely separate, so return NIL.
+ (t nil)))))
+
+;;;--------------------
+;;; This is the saved version of the function, in case we ever need to
+;;; restore it to its original functionality (returning a list of contour
+;;; intersections rather than being used only as a predicate).
+
+#+Ignore
+(defun vertex-list-intersection (a1 a2)
+
+ "vertex-list-intersection a1 a2
+
+Given two vertex lists, A1 and A2, each a list of (x y) pairs which
+implicitly encloses a region of the plane, returns a list of vertex
+lists which enclose the region of space that results from the
+intersection of the regions enclosed by A1 and A2. If A1 and A2 share
+some overlap, this list will contain one vertex list for each separate
+region of the intersection (there may be several); otherwise, NIL is
+returned."
+
+ ;; This version of VERTEX-LIST-INTERSECTION depends on the contours
+ ;; being traversed in CCW orientation, which condition SHOULD be true
+ ;; [ie, WILL be true modulo bugs].
+ ;;
+ ;; The last step of the 'preprocessing' is to perturb vertices of any
+ ;; segments coincident to both contours, so that no such coincident
+ ;; segments remain - this will make the merge step easier, should the
+ ;; perturbed contours still intersect (see FIND-CONTOUR-INTERSECTIONS).
+ ;;
+ (let ((v1 (remove-redundant-vertices a1))
+ (v2 (remove-redundant-vertices a2)))
+ (multiple-value-bind (isecs-1 isecs-2)
+ (find-contour-intersections v1 v2)
+ ;;
+ (if (found-intersections? isecs-1)
+ ;;
+ ;; Contours intersect - merge them, determine which of the merged
+ ;; circuits are internal to V1 but external to V2, extract contours
+ ;; from these circuits and return on a list.
+ ;;
+ ;; BUILD-CIRCUIT-LIST "de-annotates" vertices in intersection lists.
+ ;;
+ (extract-contours
+ (get-intersection-circuits
+ (determine-owners
+ (merge-circuits
+ (build-circuit-list isecs-1 isecs-2)))))
+ ;;
+ ;; Contours don't intersect - use CONTOUR-ENCLOSES-P to see if V1 is
+ ;; inside V2 (return V1 if so); else use test again to see if V2 is
+ ;; inside V1 (return V2 if so); else two contours must be completely
+ ;; separate, so return nil. Must return a singleton list if result
+ ;; is a single contour, for consistency with other cases.
+ ;;
+ ;; CAAR gets FIRST of FIRST - ie, X coord of first elem of contour.
+ ;; CADAR gets SECOND of FIRST - ie, Y coord of first elem of contour.
+ (cond ((contour-encloses-p isecs-2 (caar isecs-1) (cadar isecs-1))
+ (list v1))
+ ((contour-encloses-p isecs-1 (caar isecs-2) (cadar isecs-2))
+ (list v2))
+ (t nil))))))
+
+;;;--------------------
+
+(defun get-intersection-circuits (circuits)
+
+ "get-intersection-circuits circuits
+
+Finds and returns the list of circuits that consists of vertices
+internal both the first and second original contours, by finding all
+occurrences of circuits owned by A and B, and then removing the
+duplicate circuits. One circuit will be returned for each distinct
+region of the intersection. If no such circuits exist, then it must
+be the case that the two contours intersect but do not 'overlap'; this
+can occur if the two touch but do not share any common area (in which
+case nil is returned) or if the first is completely inside the second,
+but touches the second somewhere (in which case the first is
+returned), or vice versa (in which the second is returned)."
+
+ ;; if there are any circuits owned by AB, return them.
+
+ (or
+ (remove-duplicates
+ (append
+ (find-all '(A B) circuits :key #'circuit-owner)
+ (find-all '(B A) circuits :key #'circuit-owner))
+ :test #'strand-equal
+ :key #'circuit-strand)
+
+ ;; otherwise, if there are any circuits owned by AX, this is an indication
+ ;; that the 'B' contour lies within the 'A' contour, so find and return
+ ;; the B contour.
+
+ (if (or
+ (find-all '(A X) circuits :key #'circuit-owner)
+ (find-all '(X A) circuits :key #'circuit-owner))
+ (remove-duplicates
+ (find-all '(B) circuits :key #'circuit-owner)
+ :test #'strand-equal
+ :key #'circuit-strand))
+
+
+ ;; otherwise, if there are any circuits owned by BX, this is an indication
+ ;; that the 'A' contour lies within the 'B' contour, so find and return
+ ;; the A contour.
+
+ (if (or
+ (find-all '(B X) circuits :key #'circuit-owner)
+ (find-all '(X B) circuits :key #'circuit-owner))
+ (remove-duplicates
+ (find-all '(A) circuits :key #'circuit-owner)
+ :test #'strand-equal
+ :key #'circuit-strand))
+
+ ;; otherwise, the 'A' contour lies outside the 'B' contour, so return nil.
+
+ nil))
+
+;;;--------------------
+
+(defun remove-redundant-vertices (c)
+
+ "remove-redundant-vertices c
+
+Removes redundant (ie: two identical-within-EPSILON consecutive)
+vertices from a contour."
+
+ ;; NEAR-POINTS Uses default EPSILON of 1.0e-4 here.
+ (remove-duplicates c :test #'near-points))
+
+;;;--------------------
+
+(defun find-contour-intersections (c1 c2)
+
+ "find-contour-intersections c1 c2
+
+Finds the points of intersection between the two supplied contours, marks
+them, inserts them into the contours, and returns the two contours as a
+list. Each of the two returned contours is an \"annotated contour list\"
+of which the member vertices are of the form (x y) if they are not
+intersection points or (x y t) if they are. For details on the intersec-
+tion algorithm, see EDGE-EDGE-INTERSECT. Note that care is taken here to
+insure that there are no coincident segments found on the two intersection
+lists -- if so, then the vertices of these two segments are perturbed so
+that the segments no longer intersect, and all the intersections over the
+two vertex lists are recalculated."
+
+ (multiple-value-bind (perturbed? ilist-1 ilist-2)
+ (scan-for-coincident-segments
+ (contour-contour-intersect c1 c1 c2)
+ (contour-contour-intersect c2 c2 c1))
+ ;;
+ ;; PERTURBED?, if T, means coincident segments were found and the
+ ;; vertex intersection lists have been perturbed -- apply function
+ ;; recursively to redetermine intersections.
+ ;;
+ (if perturbed?
+ (find-contour-intersections ilist-1 ilist-2)
+ (values ilist-1 ilist-2))))
+
+;;;--------------------
+
+(defun scan-for-coincident-segments (isec-1 isec-2 &aux perturb?)
+
+ "scan-for-coincident-segments isec-1 isec-2
+
+If any two consecutive vertices of both of the two augmented vertex lists
+which comprise the intersecs list are themselves both intersection
+vertices (marked with 'T'), then that segment is coincident to both vertex
+lists. To eliminate this special case of coincident segments, the
+relevant vertices on one vertex list are slightly perturbed so they no
+longer form a coincident segment. Three values are returned: the first
+item is a boolean to indicate whether any coincident segments were found.
+The second and third items are (in the case that coincident segments were
+found) the original two intersection lists but with vertices of coincident
+segments PERTURBED, so that they are no longer coincident. In the case
+that no coincident segments were found, second and third items on the
+returned list are the original two intersection lists unchanged."
+
+ ;; Both args to this function are freshly-consed (at all levels).
+ ;; Therefore, we need not worry about PERTURB-SEGMENTS causing side
+ ;; effects to be propagated back through shared structure.
+ ;;
+ ;; Look for pairs of intersection vertices on ISEC-1. Then look for the
+ ;; same pairs of adjacent intersection vertices on ISEC-2 - for each
+ ;; match, perturb 1st and 2nd vertices of pair on ISEC-2 by same amount.
+ ;;
+ (do ((w isec-1 (cdr w))
+ (w1) (w2) (u1) (u2)
+ (w1x 0.0) (w1y 0.0)
+ (w2x 0.0) (w2y 0.0)
+ (u1x 0.0) (u1y 0.0)
+ (u2x 0.0) (u2y 0.0))
+ ((null w))
+ (declare (single-float w1x w1y w2x w2y u1x u1y u2x u2y))
+ (setq w1 (first w)
+ w2 (or (second w) (first isec-1)))
+ (when (and (third w1) (third w2))
+ (do ((u isec-2 (cdr u)))
+ ((null u))
+ (setq w1x (first w1)
+ w1y (second w1)
+ w2x (first w2)
+ w2y (second w2)
+ u1 (first u)
+ u1x (first u1)
+ u1y (second u1)
+ u2 (or (second u) (first isec-2))
+ u2x (first u2)
+ u2y (second u2))
+ (when (and (or (near-coords w1x w1y u1x u1y)
+ (near-coords w2x w2y u1x u1y))
+ (or (near-coords w1x w1y u2x u2y)
+ (near-coords w2x w2y u2x u2y)))
+ (setq perturb? t)
+ (perturb-segment u1 u2 1.0e-2)))))
+ ;;
+ ;; if PERTURB? is true, send back a flag (the 't' at the head of what is
+ ;; returned) to indicate that coincidences were found, followed by the two
+ ;; lists resulting from the perturbation.
+ ;;
+ (if perturb?
+ (values
+ t
+ ;; De-Annotate the vertex lists being returned, since the
+ ;; perturbation hack should have eliminated coincidental edges.
+ (de-annotate isec-1)
+ (de-annotate isec-2))
+ (values ;Else,
+ nil ; return NIL (no perturbs)
+ ;; LEAVE any vertex annotations in place, for here they signal
+ ;; intersections between NON-COINCIDENTAL segments.
+ isec-1 ; + two vertex intersection lists
+ isec-2)))
+
+;;;--------------------
+
+(defun contour-contour-intersect (c1-start c1 c2)
+
+ "contour-contour-intersect c1-start c1 c2
+
+Recursively finds the points of intersection between two contours and
+returns a copy of the first contour (C1) with the intersection points
+identified and spliced into the contour. The second contour (C2)
+is passed through unaffected. C1-START is original C1 contour, not
+CDRed on recursive calls, so we can wrap around to first element when
+traversing past last element of C1."
+
+ ;; I-LIST is the list of intersection points for the first edge of C1
+ ;; and the contour C2, sorted in order of closest proximity to V1;
+ ;; ANNOTS is the annotated vertex intersection list.
+ ;;
+ (when (consp c1)
+ (let* ((v1 (first c1))
+ (v2 (or (second c1) ;If C1 is at end, get "wrap-around"
+ (first c1-start))) ;element from head of original list
+ (v1x (first v1))
+ (v1y (second v1))
+ (i-list (sort (edge-contour-intersect v1 v2 c2 c2)
+ #'(lambda (a b)
+ (in-between v1x v1y
+ (first a) (second a)
+ (first b) (second b)))))
+ ;; NB: The MAPCAR and APPEND (applied to its FIRST arg) guarantee
+ ;; that ANNOTS here is fully freshly-consed at all levels, safely
+ ;; prepared for ultimate user of this function's return list
+ ;; (such list may be modified destructively soon).
+ (annots (mapcar #'(lambda (v)
+ (append v '(t))) i-list)))
+ ;;
+ ;; If no intersections of edge (V1, V2) with contour C2 were found,
+ ;; or if the first intersection point is far from V1, then push V1
+ ;; onto the annotated vertex intersection list. Finally, recur
+ ;; on the CDR of C1 and all of C2.
+ ;;
+ (unless (and (consp i-list)
+ (near-points v1 (first i-list)))
+ ;; Make sure value pushed is freshly-consed, for reasons above.
+ (push (copy-list v1) annots))
+ ;;
+ (append annots (contour-contour-intersect c1-start (cdr c1) c2)))))
+
+;;;--------------------
+
+(defun edge-contour-intersect (v1 v2 contour-start contour)
+
+ "edge-contour-intersect v1 v2 contour-start contour
+
+Recursively finds the points of intersection between an edge, determined
+by the vertices V1 and V2, and a contour CONTOUR, and returns the intersection
+points on a list. CONTOUR-START is initial CONTOUR (not CDRed in recursive
+calls) for finding closing first element when CDRing off end of CONTOUR."
+
+ (when (consp contour)
+ (let ((intersec (edge-edge-intersect v1 v2
+ (first contour)
+ (or (second contour)
+ (first contour-start))
+ nil)))
+ (cond ((consp intersec)
+ (cons intersec
+ (edge-contour-intersect v1 v2 contour-start (cdr contour))))
+ (t (edge-contour-intersect v1 v2 contour-start (cdr contour)))))))
+
+;;;--------------------
+;;;
+;;; Souped up for efficiency, since this is in the middle of a
+;;; frequently executed loop.
+;;;
+
+(defun edge-edge-intersect (v1 v2 v3 v4 always-return-isec?)
+
+ "edge-edge-intersect v1 v2 v3 v4 always-return-isec?
+
+Finds the intersection between two edges, determined by the pair V1, V2 and
+the pair V3, V4. If they're parallel (and non-coincident), returns NIL. If
+coincident, then returns V3 when it lies between V1 & V2, V1 when it lies
+between V3 & V4, and NIL otherwise. If not parallel, then computes the
+intersection point between the two lines running through the pair of
+segments and tests to see if this intersection point actually lies within
+each of the two segments. If so, or if ALWAYS-RETURN-ISEC? is non-NIL,
+returns that point and otherwise returns NIL."
+
+ (let* ((a (first v1))
+ (b (second v1))
+ (c (first v2))
+ (d (second v2))
+ (p (first v3))
+ (q (second v3))
+ (r (first v4))
+ (s (second v4))
+ (K (- c a))
+ (L (- d b))
+ (M (- r p))
+ (N (- s q))
+ (den (- (* M L) (* N K))))
+
+ ;; IN-BETWEEN, NEARLY-xxx, and NEAR-COORDS have different default
+ ;; EPSILONs. Values passed here are 1.0e-4 and 1.0e-5 - be careful.
+
+ (declare (single-float a b c d p q r s K L M N den))
+
+ (cond ((< -1.0e-4 den 1.0e-4)
+ ;;
+ ;; Parallel or coincident if true. In the parallel case,
+ ;; implicitly return NIL regardless of ALWAYS-RETURN-ISEC?
+ ;;
+ (when (< -1.0e-4
+ (- (* M (- (* a L) (* b K)))
+ (* K (- (* p N) (* q M))))
+ 1.0e-4)
+ (cond ((and (in-between a b p q c d 1.0e-5)
+ (not (near-coords p q c d 1.0e-4)))
+ v3)
+ ((and (in-between p q a b r s 1.0e-5)
+ (not (near-coords a b r s 1.0e-4)))
+ v1)
+ (t nil))))
+ ;;
+ ;; Otherwise, for segs neither parallel nor coincident ...
+ ;;
+ (t (let* ((x (/ (+ (* K M q)
+ (* M L a)
+ (- (* K M b))
+ (- (* K N p)))
+ den))
+ (y (/ (+ (* K N b)
+ (* L N p)
+ (- (* L M q))
+ (- (* L N a)))
+ (- den))))
+ (declare (single-float x y))
+ (cond ((or always-return-isec?
+ (and (in-bounding-box a b x y c d)
+ (in-bounding-box p q x y r s)
+ (not (near-coords x y c d 1.0e-4))
+ (not (near-coords x y r s 1.0e-4))))
+ ;;
+ ;; If flag is true, or the point of intersection is on
+ ;; both segs and not coincident with either V2 or V4,
+ ;; return the new intersection point.
+ ;;
+ (list x y))
+ ;;
+ ;; Otherwise return NIL.
+ (t nil)))))))
+
+;;;--------------------
+
+(defun found-intersections? (c)
+
+ "found-intersections? c
+
+Returns T if any intersections are on the annotated contour list C,
+NIL otherwise."
+
+ (dolist (v c nil) ; None if finished loop.
+ (when (third v) ; Found intersec.
+ (return t))))
+
+;;;--------------------
+
+(defun build-circuit-list (c1 c2)
+
+ "build-circuit-list c1 c2
+
+Given a pair of counter-clockwise contours, builds the list of circuit data
+structures. A reverse copy of each contour is made and the vertices in the
+pair are assigned owners (a unique identifier for one contour, the symbol X
+for its pair). Each circuit is closed to form a loop and the four circuits
+are returned on a list."
+
+ ;; It is absolutely critical that the input contours be counter-clockwise;
+ ;; otherwise the algorithm will return incorrect results. Make sure that
+ ;; outputs from FIND-CONTOUR-INTERSECTIONS are CCW. Tests here can be
+ ;; removed after correct operation verified.
+ (when (or (clockwise-traversal-p c1)
+ (clockwise-traversal-p c2))
+ (error "BUILD-CIRCUIT-LIST: Passed CW contour."))
+ ;;
+ (let ((c1-rev (reverse c1))
+ (c2-rev (reverse c2)))
+ (list
+ (make-circuit :strand (build-strand c1-rev 'A))
+ (make-circuit :strand (build-strand c1 'X))
+ (make-circuit :strand (build-strand c2-rev 'B))
+ (make-circuit :strand (build-strand c2 'X)))))
+
+;;;--------------------
+
+(defun build-strand (v-list owner)
+
+ "build-strand v-list owner
+
+Builds and returns a strand out of the list of annotated vertex pairs V-LIST.
+Every vertex in the strand is owned by OWNER."
+
+ ;; Fill in the COORDS, INTERSECT-P, and OWNER fields of each
+ ;; vertex strand structure.
+
+ (let ((strand (mapcar #'(lambda (elt)
+ (make-vertex
+ :coords (list (first elt) (second elt))
+ :intersect-p (third elt)
+ :owner owner))
+ v-list)))
+
+ ;; Wire the vertex strand structures together via the next and prev
+ ;; pointers. For upcoming operations, the members of the strand will
+ ;; be referenced via these pointers, and not by their 'top level'
+ ;; list structure (a vestige from the v-list organization).
+
+ (do ((w strand (cdr w)))
+ ((null (cdr w))
+ ;; (CAR W) is now the last element of STRAND [NOT (last strand) !!]
+ (setf (vertex-prev (first strand)) (car w))
+ (setf (vertex-next (car w)) (first strand)))
+ ;;
+ (setf (vertex-next (first w)) (second w))
+ (setf (vertex-prev (second w)) (first w)))
+
+ (first strand)))
+
+;;;--------------------
+
+(defun merge-circuits (circuits)
+
+ "merge-circuits circuits
+
+Merges the circuits together by re-wiring strands at intersections so that
+the plane is partitioned into regions of ownership."
+
+ ;; This is the key to and the most complex part of the entire contour
+ ;; differencing mechanism.
+
+ ;; Algorithm: from the list of 4 original circuits (A, X, B, and X), derive
+ ;; an intersection list of 4-tuples ('v-lists'), one such tuple for each
+ ;; intersection among the two contours. Each member of a 4-tuple is a
+ ;; pointer to that intersection as it is found on one the 4 original circuit
+ ;; lists. For each member of every 4-tuple, determine the successor strand
+ ;; that is to be spliced into that strand at its head, replacing the current
+ ;; 'rest' of the strand. See FIND-SUCCESSOR-STRAND for the details on which
+ ;; strand gets selected. Then this successor strand is spliced into place,
+ ;; and the resulting strand is made into a circuit and pushed onto the list
+ ;; with the original 4 circuits.
+
+ ;; Note - in certain cases, the 4-tuples above may be 3-tuples (when the
+ ;; two contours touch at a point but do not cross each other).
+
+ (dolist (4-tuple (find-circuit-intersections circuits) circuits)
+ (let ((adj-list (get-adjacent-vertices 4-tuple))
+ (prev-links (mapcar #'vertex-prev 4-tuple)))
+ (do ((vs 4-tuple (cdr vs))
+ (v-prevs prev-links (cdr v-prevs))
+ (v) (v-prev) (successor))
+ ((null vs))
+ (setq v (car vs)
+ v-prev (car v-prevs)
+ successor (find-successor-strand v 4-tuple adj-list))
+ (setf (vertex-next v-prev) successor)
+ (setf (vertex-prev successor) v-prev)
+ (push (make-circuit
+ :strand (vertex-prev v)) ; add what's behind us
+ circuits)))))
+
+;;;--------------------
+
+(defun find-circuit-intersections (circuit-list)
+
+ "find-circuit-intersections circuit-list
+
+The circuit list consists of 4 sublists: the inside and outside
+strands of both contours. This routine finds the points of
+intersection between the two original contours on each of the 4
+sublists. For each intersection point, the 4 occurrences of that
+intersection point on the sublists are gathered together into a
+4-tuple. These occurrences are not removed from their respective
+sublists, so the entirety of each sublist can still be accessed
+through the VERTEX-NEXT and VERTEX-PREV fields of each of the 4 points
+at the head of the tuple. All such 4-tuples (one per intersection
+point) are pushed onto a master list, which is returned."
+
+ (let* ((v (circuit-strand (first circuit-list)))
+ (w v)
+ (result '()))
+ (loop
+ (when (vertex-intersect-p w)
+ (push
+ (cons w (mapcar #'find-strand-intersections
+ (list w w w)
+ (cdr circuit-list)))
+ result))
+ (cond ((eq (vertex-next w) v)
+ (return (nreverse result)))
+ (t (setq w (vertex-next w)))))))
+
+;;;--------------------
+
+(defun find-strand-intersections (v circuit)
+
+ "find-strand-intersections v circuit
+
+Finds the vertex v in the circuit and returns the found vertex structure.
+Note that the vertices on the circuit before and after the found vertex
+will still be accessible from the returned vertex structure through its
+VERTEX-NEXT and VERTEX-PREV fields."
+
+ (let ((w (circuit-strand circuit)))
+ (loop
+ (if (near-points (vertex-coords v) (vertex-coords w))
+ (return w)
+ (setf w (vertex-next w))))))
+
+;;;--------------------
+
+(defun get-adjacent-vertices (tuple)
+
+ "get-adjacent-vertices tuple
+
+Given the tuple of vertex structures (each vertex's coordinates
+referencing the same intersection point, but on a different strand),
+this routine returns a copy of the vertex structures immediately
+preceeding and following each vertex (the copies returned on a list in
+the same order as the vertices in the tuple list). This original info
+is needed since the neighbor info will change as the vertex is rewired
+during the merge phase."
+
+ (mapcar #'(lambda (v)
+ (list
+ (copy-vertex (vertex-prev v))
+ (copy-vertex (vertex-next v))))
+ tuple))
+
+;;;--------------------
+
+(defun find-successor-strand (v tuple adj-list)
+
+ "find-successor-strand v tuple adj-list
+
+Given the intersection vertex structure v, the tuple of vertex
+intersections from which v comes, and an adj-list which indicates the
+original relationship between the next and previous neighbors of each
+vertex in the tuple, this routine finds and returns the new vertex
+structure (and implicitly its strand) that should follow v when the
+vertices are later rewired into regions of ownership. The strand that
+should follow v is essentially the one whose VERTEX-NEXT element (as
+determined by adj-list) subtends the smallest angle with v, as
+measured from v's right."
+
+ (do ((vs tuple (cdr vs))
+ (adj-1 adj-list (cdr adj-1))
+ (tuple-value))
+ ((null vs))
+ (when (eq v (car vs))
+ (let ((prev-coords (vertex-coords (caar adj-1)))
+ (v-coords (vertex-coords v)))
+ (do ((pc1 (first prev-coords))
+ (pc2 (second prev-coords))
+ (vc1 (first v-coords))
+ (vc2 (second v-coords))
+ (adj-2 adj-list (cdr adj-2))
+ (tuple-elements tuple (cdr tuple-elements))
+ (a-coords) (angle 0.0)
+ (min-angle #.most-positive-single-float))
+ ((null adj-2))
+ (declare (single-float pc1 pc2 vc1 vc2 angle min-angle))
+ (setq a-coords (vertex-coords (second (car adj-2))))
+ (when (< (setq angle (angle-subtended
+ pc1 pc2
+ vc1 vc2
+ (first a-coords) (second a-coords)))
+ min-angle)
+ (setq min-angle angle
+ tuple-value (car tuple-elements)))))
+ (return tuple-value))))
+
+;;;--------------------
+
+(defun angle-subtended (p1 p2 q1 q2 r1 r2)
+
+ "angle-subtended p1 p2 q1 q2 r1 r2
+
+Determines the measure of the 'directed' angle (p1 p2) -> (q1 q2) -> (r1 r2),
+that is, the counter-clockwise angle PQR, even if it is > 180 degrees."
+
+ (declare (single-float p1 p2 q1 q2 r1 r2))
+
+ (let* ((a (- p1 q1))
+ (b (- p2 q2))
+ (c (- r1 q1))
+ (d (- r2 q2))
+ (dot (+ (* a c) (* b d)))
+ (cross (- (* a d) (* b c)))
+ (len-ab (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *) (+ (* a a) (* b b))))))
+ (len-cd (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *) (+ (* c c) (* d d))))))
+ (quot (/ dot (* len-ab len-cd)))
+ (ctheta (max (min quot 1.0) -1.0)) ; don't let round off
+ (theta (acos ctheta))) ; throw us into imag
+
+ (declare (single-float a b c d dot cross len-ab len-cd quot ctheta theta))
+
+ ;; define 0 angles as 2 PI (first clause of the cond) so the algorithm
+ ;; won't be confused by selecting the strand from the same original
+ ;; contour but running in the opposite direction.
+
+ (cond ((near-coords p1 p2 r1 r2)
+ #.(coerce (* 2.0d0 pi) 'single-float))
+ ((plusp cross) theta)
+ (t (- #.(coerce (* 2.0d0 pi) 'single-float) theta)))))
+
+;;;--------------------
+
+(defun determine-owners (circuits)
+
+ "determine-owners circuits
+
+Traverses each circuit and determines its composite owner."
+
+ (when circuits
+ (let* ((circuit (first circuits))
+ (v (circuit-strand circuit))
+ (front v))
+ (loop
+ (pushnew (vertex-owner v) (circuit-owner circuit))
+
+ (cond ((eq (vertex-next v) front)
+ (return (cons circuit (determine-owners (cdr circuits)))))
+ (t (setq v (vertex-next v))))))))
+
+;;;--------------------
+
+(defun extract-contours (circuits)
+
+ "extract-contours circuits
+
+Extracts and returns the vertices in the strand of each circuit as a list
+of coordinate pairs."
+
+ (mapcar #'(lambda (circuit)
+ (let* ((v (circuit-strand circuit))
+ (front v)
+ (result '()))
+ (loop
+ (push (vertex-coords v) result)
+ (cond ((eq (vertex-next v) front)
+ (return (nreverse result)))
+ (t (setq v (vertex-next v)))))))
+ circuits))
+
+;;;--------------------
+
+(defun de-annotate (vlist)
+
+ "de-annotate vlist
+
+Returns a copy of VLIST in form as specified for a vertex-list, e.g.,
+a list of (X Y) pairs with any third-element T values stripped off."
+
+ (mapcar #'(lambda (vert)
+ (list (first vert) (second vert)))
+ vlist))
+
+;;;----------------------------------------------------
+
+(defun contour-encloses-p (vlist px py)
+
+ "contour-encloses-p vlist px py
+
+Returns T if contour VLIST (an OPEN vertex list - first vertex NOT repeated
+as last) encloses in either direction the point with coords (PX PY) - NIL if
+point is ON contour (matches a vertex or on an edge) or is outside."
+
+ ;; As VLIST is an open list representing a closed contour, there is an
+ ;; implied edge present from last to first vertex. Traversal can be in
+ ;; either direction, CW or CCW.
+ ;;
+ (declare (single-float px py))
+ ;;
+ (let* ((bck-vert (car (last vlist)))
+ (bnx (- (the single-float (first bck-vert)) px))
+ (bny (- (the single-float (second bck-vert)) py))
+ (accum-angle 0.0))
+ ;;
+ (declare (single-float bnx bny accum-angle))
+ ;;
+ (do ((fwd-verts vlist (cdr fwd-verts))
+ (fwd-vert) ;Actual Vertex
+ (fx 0.0) (fy 0.0) ;Rotating coords of FWD point
+ (bx bnx fx) ;Rotating X coord of BCK point
+ (by bny fy) ;Rotating Y coord of BCK point
+ (crossprod 0.0)
+ (dotprod 0.0))
+ ((null fwd-verts))
+ ;;
+ (declare (single-float bx by fx fy crossprod dotprod))
+ ;;
+ (setq fwd-vert (car fwd-verts)
+ fx (- (the single-float (first fwd-vert)) px)
+ fy (- (the single-float (second fwd-vert)) py))
+ ;;
+ ;; Check whether testpoint matches a contour vertex or lies
+ ;; on one of the edges between vertices -- return NIL if so.
+ (setq crossprod (- (* bx fy) (* by fx))
+ dotprod (+ (* bx fx) (* by fy)))
+ ;;
+ (when (or (and (= bx 0.0) ;Testpoint matches back vertex
+ (= by 0.0))
+ (and (= fx 0.0) ;Testpoint matches fwd vertex
+ (= fy 0.0))
+ (and (= 0.0 crossprod) ;Testpoint on back/fwd-vertex edge
+ (< dotprod 0.0)))
+ (return-from contour-encloses-p nil))
+ ;;
+ ;; Accumulate the included angle between vectors from testpoint
+ ;; to contour line segment endpoints. Included angle here is ARCTAN
+ ;; of cross-product divided by dot-product of test-point-to-initial-end
+ ;; vector and test-point-to-terminal-end vector. Positive sign of
+ ;; ACCUM-ANGLE indicates COUNTER-CLOCKWISE angle, negative sign a
+ ;; clockwise angle.
+ ;;
+ (incf accum-angle (the single-float
+ (atan crossprod (+ (* bx fx)
+ (* by fy))))))
+ ;;
+ ;; Point (PX PY) is INSIDE contour if accumulated angle is 2*PI
+ ;; [CCW enclosure] or -2*PI [CW enclosure].
+ ;; Point (PX PY) is OUTSIDE contour if accumulated angle is zero.
+ ;; Testing accumulated angle against threshold of +or- PI
+ ;; [more negative than -PI or more positive than +PI] should leave
+ ;; plenty of room for accumulated roundoff error.
+ ;;
+ (or (< accum-angle #.(coerce (- pi) 'single-float))
+ (> accum-angle #.(coerce pi 'single-float)))))
+
+;;;--------------------
+
+(defun strand-equal (str1 str2)
+
+ "strand-equal str1 str2
+
+Returns T if the two strands consist of the same ordered list of vertices.
+This is used to cull duplicates from the list of merged strands when
+looking for strands owned by a particular combination of A, X, & B."
+
+ ;; Get the two strands lined up, by running down STR1 with the pointer S,
+ ;; setting STR1 to S if the first elt of S matches that of STR2, or returning
+ ;; NIL if S advances all the way around the loop and matches STR1 again; or
+ ;; advancing S otherwise.
+
+ (let ((s (vertex-next str1)))
+ (loop
+ (cond ((and (equal (vertex-coords s) (vertex-coords str2))
+ (equal (vertex-owner s) (vertex-owner str2)))
+ (setq str1 s)
+ (return))
+ ((eq s str1)
+ (return-from strand-equal nil))
+ (t (setq s (vertex-next s))))))
+
+ ;; March down both strands in step (with V and W), checking for equality
+ ;; of vertices at each step. If the vertices are ever not equal, return
+ ;; NIL; if V loops all the way around to STR1, then check if W has looped
+ ;; back to STR2, returning T if so and NIL if not.
+
+ (let ((v (vertex-next str1))
+ (w (vertex-next str2)))
+ (loop
+ (cond ((not (and (equal (vertex-coords v) (vertex-coords w))
+ (equal (vertex-owner v) (vertex-owner w))))
+ (return nil))
+ ((eq v str1)
+ (return (eq w str2)))
+ (t (setq v (vertex-next v)
+ w (vertex-next w)))))))
+
+;;;--------------------
+
+(defun find-all (item seq &key key)
+
+ "find-all item seq &key key
+
+Finds all occurrences of ITEM in SEQ and returns a list of those found
+items in order."
+
+ (let ((result (member item seq :test #'equal :key key)))
+ (when (consp result)
+ (cons (car result)
+ (find-all item (cdr result) :key key)))))
+
+;;;--------------------
+
+(defun centroid (con)
+
+ "centroid con
+
+Returns the centroid of contour con, ie: the point whose x & y coords are
+the arithmetic average of the x & y coords, respectively, of the vertices."
+
+ (list (float (/ (apply #'+ (mapcar #'first con)) (length con)))
+ (float (/ (apply #'+ (mapcar #'second con)) (length con)))))
+
+;;;--------------------
+
+(defun ortho-expand-contour (con amt &aux (expanded-segs '()))
+
+ "ortho-expand-contour con amt
+
+Expands a contour, CON (a list of (x y) vertex pairs) by an amount, AMT,
+in such a way that each segment of CON is translated outward in a direction
+perpendicular to the segment by AMT."
+
+ ;; 1. Ensure that the contour is counter-clockwise; reverse it if not.
+ ;;
+ (when (clockwise-traversal-p con)
+ (setq con (reverse con)))
+ ;;
+ ;; 2. Perturb each successive pair of vertices by AMT. This produces a
+ ;; list of expanded segments. Each vertex of the old contour list
+ ;; will correspond to the endpoints of two successive pairs of
+ ;; expanded segments.
+ ;;
+ (do ((ptr con (cdr ptr))
+ (vert-1) (vert-2))
+ ((null ptr))
+ ;; Copy vertices which PERTURB-SEGMENT will modify destructively.
+ ;; The modified copies are then saved in EXPANDED-SEGS.
+ (setq vert-1 (copy-list (first ptr))
+ vert-2 (copy-list (or (second ptr) (first con))))
+ (perturb-segment vert-1 vert-2 amt)
+ (push (list vert-1 vert-2) expanded-segs))
+ ;;
+ ;; 3. Find the intersection between each successive pair of segment
+ ;; endpoints. These points of intersection are the vertices of
+ ;; the resulting expanded contour.
+ ;;
+ (do ((ptr expanded-segs (cdr ptr))
+ (seg-1) (seg-2) (inter) (result '()))
+ ((null ptr) result)
+ (setq seg-1 (first ptr)
+ seg-2 (or (second ptr) (first expanded-segs))
+ inter (edge-edge-intersect
+ (first seg-1) (second seg-1)
+ (first seg-2) (second seg-2) t))
+ (if inter (push inter result))))
+
+;;;--------------------
+
+(defun perturb-segment (a-vert b-vert amt)
+
+ "perturb-segment a-vert b-vert amt
+
+Perturbs A-VERT and B-VERT to the right (looking from A-VERT to B-VERT)
+by AMT. Works by side-effecting lists in first two arguments."
+
+ ;; Motivation: we're looking for a point C such that (1) segment CB is
+ ;; at right angles to AB, (2) C is to the right of AB (looking from B to A)
+ ;; and (3) the length of CB is AMT. If we take the cross product of AB and
+ ;; some vector XB where XB points straight up out of the plane, we'll get
+ ;; a resulting vector that satisfies (1) and (2). Now if the length of
+ ;; XB is AMT/LEN [LEN is length of vector (DX, DY) or segment AB], then the
+ ;; area of the parallelogram determined by XB and AB will be AMT. And the
+ ;; magnitude of the cross product of two vectors is equal to the area of the
+ ;; parallelogram they determine, so the magnitude of CB will also be equal
+ ;; to AMT, the desired quantity. So we calculate this general cross product
+ ;; and add the x-component of the result to the x-components of A and B, and
+ ;; likewise for the y-components, thus perturbing the two vertices A-VERT
+ ;; and B-VERT by the appropriate quantity.
+
+ (declare (single-float amt))
+ (let* ((ax (first a-vert))
+ (ay (second a-vert))
+ (bx (first b-vert))
+ (by (second b-vert))
+ (dx (- bx ax))
+ (dy (- by ay))
+ (fac (/ amt (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *)
+ (+ (* dx dx) (* dy dy)))))))
+ (pdx (* fac dx))
+ (pdy (* fac dy)))
+ (declare (single-float ax ay bx by dx dy fac pdx pdy))
+ ;; Return results by modifying destructively the lists passed
+ ;; as first two args here.
+ (setf (first a-vert) (+ ax pdy))
+ (setf (second a-vert) (- ay pdx))
+ (setf (first b-vert) (+ bx pdy))
+ (setf (second b-vert) (- by pdx))))
+
+;;;---------------------------------------
+
+(defun rotate-vertices (verts c-degrees)
+
+ "rotate-vertices verts c-degrees
+
+Rotates the vertices on VERTS, a list of (x y) pairs,
+by the angle C-DEGREES in a counter-clockwise direction."
+
+ (declare (single-float c-degrees))
+ ;;
+ (let* ((c-radians (* c-degrees #.(coerce (/ pi 180.0d0) 'single-float)))
+ (sin-c (sin c-radians))
+ (cos-c (cos c-radians)))
+ (declare (single-float c-radians sin-c cos-c))
+ (mapcar #'(lambda (v)
+ (let ((vx (first v))
+ (vy (second v)))
+ (declare (single-float vx vy))
+ (list (- (* vx cos-c)
+ (* vy sin-c))
+ (+ (* vy cos-c)
+ (* vx sin-c)))))
+ verts)))
+
+;;;---------------------------------------------
+;;; The AREA-OF-TRIANGLE and AREA-OF-POLYGON functions are taken from
+;;; "Computational Geometry in C" by Joseph O'Rourke, p 26.
+
+#+Ignore
+(defun area-of-triangle (a b c)
+
+ "area-of-triangle a b c
+
+Computes and returns the (oriented) area of the triangle determined
+by three points a, b, and c -- each point is an (x y) coordinate pair."
+
+ (let ((ax (first a))
+ (ay (second a))
+ (bx (first b))
+ (by (second b))
+ (cx (first c))
+ (cy (second c)))
+ (declare (single-float ax ay bx by cx cy))
+ (* (- (+ (* ax by)
+ (* ay cx)
+ (* bx cy))
+ (+ (* ay bx)
+ (* ax cy)
+ (* cx by)))
+ 0.5)))
+
+;;;---------------------------------------------
+
+(defun area-of-polygon (poly &aux (vert (first poly)) (ax (first vert))
+ (ay (second vert)) (bx 0.0) (by 0.0) (sum 0.0)
+ (cx 0.0) (cy 0.0))
+
+ "area-of-polygon poly
+
+Computes and returns the (non-oriented) area of polygon poly,
+a list of (x y) pairs."
+
+ (declare (type list poly vert)
+ (single-float sum ax ay bx by cx cy))
+
+ (setq poly (cdr poly)
+ vert (car poly)
+ bx (first vert)
+ by (second vert)
+ poly (cdr poly))
+
+ (loop
+
+ (setq vert (car poly)
+ cx (first vert)
+ cy (second vert))
+
+ (incf sum (- (+ (* ax by)
+ (* ay cx)
+ (* bx cy))
+ (+ (* ay bx)
+ (* ax cy)
+ (* cx by))))
+
+ (cond ((consp (setq poly (cdr poly)))
+ (setq bx cx by cy))
+ (t (return (cond ((> sum 0.0) ;Inline absolute value.
+ (* 0.5 sum))
+ (t (* -0.5 sum))))))))
+
+;;;---------------------------------------------
+
+#+Ignore
+(defun perimeter-of-polygon (poly)
+
+ "perimeter-of-polygon poly
+
+Computes and returns the perimeter of polygon POLY, a list of (x y) pairs."
+
+ (do ((sum 0.0)
+ (p poly (cdr p))
+ (A) (B) (dx 0.0) (dy 0.0))
+ ((null p)
+ sum)
+ (declare (single-float sum dx dy))
+ (setq A (first p)
+ B (or (second p) (first poly))
+ dx (- (the single-float (first A))
+ (the single-float (first B)))
+ dy (- (the single-float (second A))
+ (the single-float (second B))))
+ (incf sum (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *)
+ (+ (* dx dx)
+ (* dy dy))))))))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/polygons/src/convex-hull.cl b/polygons/src/convex-hull.cl
new file mode 100644
index 0000000..b74149e
--- /dev/null
+++ b/polygons/src/convex-hull.cl
@@ -0,0 +1,269 @@
+;;;
+;;; convex-hull
+;;;
+;;; A collection of routines to find the convex hull of an input list of
+;;; points.
+;;; NEAR-COORDS is defined in math .
+;;;
+;;; 31-Mar-1993 J. Unger/I. Kalet from earlier version of ptvt files.
+;;; Included scale-contour here since it uses convex-hull but nothing
+;;; else.
+;;; 23-Apr-1992 J. Unger fix bug in get-internal-point.
+;;; 7-May-1997 BobGian changed (EXPT (some-form) 2) to (SQR (some-form))
+;;; in SCALE-CONTOUR.
+;;; 24-Jun-1997 BobGian convert all instances of PI to
+;;; #.(coerce PI 'SINGLE-FLOAT) and ditto for (* 2.0 PI) --
+;;; got to keep all flonums in Prism as SINGLE-FLOATs.
+;;; 03-Jul-1997 BobGian changed calls to NEAR to call NEAR-COORDS
+;;; with appropriate argument convention.
+;;; 25-Aug-1997 BobGian changed #.(expression (coerce PI 'SINGLE-FLOAT))
+;;; to #.(coerce (expression PI))
+;;; that is, do math in double-precision first and then coerce to
+;;; single-float at end, all inside read-time computation.
+;;; 26-Sep-1997 BobGian replace ANGLE-MEASURE with ANGLE-SUBTENDED and
+;;; delete ANGLE-MEASURE - identical functionality, same package.
+;;; 30-Sep-1997 BobGian destructure args to ANGLE-SUBTENDED (faster and less
+;;; garbage created). Rename CENTER -> POLYCENTER (less easily confused).
+;;; 03-Feb-2000 BobGian cosmetic fixes (case regularization, right margin).
+;;;
+
+(in-package :polygons)
+
+;;;----------
+;;;
+;;; Simple doubly-linked list manipulation functions.
+;;;
+;;;----------
+
+;;; Node construction routines.
+
+(defun make-node (&optional data prev next) (list data prev next))
+
+(defun data-node (cur) (first cur))
+(defun set-data-node (cur data) (setf (first cur) data))
+(defsetf data-node set-data-node)
+
+(defun prev-node (cur) (first (rest cur)))
+(defun set-prev-node (cur prev) (setf (first (rest cur)) prev))
+(defsetf prev-node set-prev-node)
+
+(defun next-node (cur) (first (rest (rest cur))))
+(defun set-next-node (cur next) (setf (first (rest (rest cur))) next))
+(defsetf next-node set-next-node)
+
+;;;----------
+;;; Cdll operations
+;;;----------
+
+(defun make-cdll-node (&optional data) ; returns a 1-elt cdll
+ (let ((cdll (make-node data)))
+ (setf (next-node cdll) cdll)
+ (setf (prev-node cdll) cdll)
+ cdll))
+
+(defun insert-cdll-node (ins cur location) ;; returns ins in place
+ (case location
+ (:before
+ (setf (prev-node ins) (prev-node cur))
+ (setf (next-node ins) cur)
+ (setf (next-node (prev-node cur)) ins)
+ (setf (prev-node cur) ins))
+ (:after
+ (setf (next-node ins) (next-node cur))
+ (setf (prev-node ins) cur)
+ (setf (prev-node (next-node cur)) ins)
+ (setf (next-node cur) ins))
+ (t
+ (error "insert-cdll-node: location must be :before or :after. ~%")))
+ ins)
+
+(defun delete-cdll-node (cur) ; deletes cur -- won't
+ (setf (next-node (prev-node cur)) (next-node cur)) ; handle 1-elt cdll
+ (setf (prev-node (next-node cur)) (prev-node cur))
+ (setf cur nil)
+ (values))
+
+(defun print-cdll (cdll &optional first-node)
+ (unless (eq cdll first-node)
+ (format t "~a ~%" (data-node cdll))
+ (print-cdll (next-node cdll) (or first-node cdll))))
+
+;;;----------
+
+(defun get-internal-point (pts)
+
+ "GET-INTERNAL-POINT pts
+
+ Returns a point internal to the polygon determined by the list of points,
+ by returning the affine combination of three points on the list."
+
+ ;; Note - the internal point can't coincide with any of the supplied pts,
+ ;; or else the ANGLE-SUBTENDED comparison blows up when the program attempts
+ ;; to sort that point by polar angle. So we have to check the candidate
+ ;; internal point against all points in the contour, and try another one,
+ ;; if it turns out to be coincident with any of the supplied pts.
+
+ (loop
+ (let* ((p1 (first pts))
+ (p2 (second pts))
+ (p3 (third pts))
+ (all-clear t)
+ (candidate-x (+ (/ (first p1) 3.0)
+ (/ (first p2) 3.0)
+ (/ (first p3) 3.0)))
+ (candidate-y (+ (/ (second p1) 3.0)
+ (/ (second p2) 3.0)
+ (/ (second p3) 3.0))))
+ (dolist (pt pts)
+ (when (near-coords (first pt) (second pt) candidate-x candidate-y)
+ (setf all-clear nil)))
+ (when all-clear
+ (return-from get-internal-point (list candidate-x candidate-y)))
+ (setf pts (cdr pts)))))
+
+;;;----------
+
+(defun polar-smaller (q a b)
+
+ "polar-smaller q a b
+
+ Returns t if the polar angle of segment (a q) is smaller than that of
+ (b q), both with respect to the positive x axis. Otherwise, returns nil."
+
+ (let ((q1 (first q))
+ (q2 (second q)))
+ (< (angle-subtended 100000.0 q2
+ q1 q2
+ (first a) (second a))
+ (angle-subtended 100000.0 q2
+ q1 q2
+ (first b) (second b)))))
+
+;;;----------
+
+(defun list-to-cdll (lst)
+
+ "list-to-cdll lst
+
+ Makes and returns a circular doubly linked list from the simple list."
+
+ (if (null (rest lst))
+ (make-cdll-node (first lst))
+ (insert-cdll-node
+ (make-cdll-node (first lst))
+ (list-to-cdll (rest lst))
+ :before)))
+
+;;;----------
+
+(defun get-rightmost-cdll-node (cdll &optional first-node)
+
+ "get-rightmost-cdll-node cdll &optional first-node
+
+ Returns the rightmost node (the one with the largest y coordinate) of
+ the input circular doubly linked list. The optional argument is only
+ to be used internally by recursive calls."
+
+ (if (eq cdll first-node)
+ first-node
+ (let ((rt (get-rightmost-cdll-node
+ (next-node cdll) (or first-node cdll))))
+ (if (> (first (data-node cdll)) (first (data-node rt)))
+ cdll
+ rt))))
+
+;;;----------
+
+(defun left-turn-p (a b c)
+
+ "left-turn-p a b c
+
+ Returns true if traversing the points a, b, c makes a left turn;
+ nil otherwise."
+
+ (let ((ax (first a)) (ay (second a))
+ (bx (first b)) (by (second b))
+ (cx (first c)) (cy (second c)))
+ (plusp
+ (-
+ (+ (* ax by) (* cx ay) (* bx cy))
+ (+ (* cx by) (* ax cy) (* bx ay))))))
+
+;;;----------
+
+(defun cdll-to-list (cdll &optional first-node)
+
+ "cdll-to-list cdll &optional first-node
+
+ Makes and returns a simple list from a circular doubly linked list.
+ The optional argument is only to be used internally by recursive calls."
+
+ (unless (eq cdll first-node)
+ (cons
+ (data-node cdll)
+ (cdll-to-list (next-node cdll) (or first-node cdll)))))
+
+;;;----------
+
+(defun convex-hull (pts)
+
+ "convex-hull pts
+
+ Given pts, a list of xy pairs, finds and returns a subset of this list
+ which constitutes the convex hull of the points, using Graham's Scan."
+
+ (let* ((pts2 (copy-tree pts))
+ (q (get-internal-point pts2))
+ (sorted (sort pts2 #'(lambda (a b) (polar-smaller q a b))))
+ (cdll (list-to-cdll sorted))
+ (start (get-rightmost-cdll-node cdll))
+ (v start)
+ (w (prev-node v))
+ (f nil))
+
+ (loop
+ (when (and f (eq (next-node v) start)) (return))
+ (when (eq (next-node v) w) (setq f t))
+ (if (left-turn-p
+ (data-node v)
+ (data-node (next-node v))
+ (data-node (next-node (next-node v))))
+ (setq v (next-node v))
+ (progn
+ (delete-cdll-node (next-node v))
+ (setq v (prev-node v)))))
+
+ (cdll-to-list start)))
+
+;;;------------------
+
+(defun scale-contour (vertices scale-factors)
+
+ "scale-contour vertices scale-factors
+
+returns a list of vertices consisting of convex hull of original
+contour list of vertices expanded out from the center of the contour
+by the amount of the scale-factor in each direction. Scale-factor is
+a two element list whose first element is the scale factor in the x
+direction and the second is the scale factor in the y direction. The
+center of the contour is computed by averaging the extrema of the
+vertex coordinates."
+
+ (let* ((verts (convex-hull vertices))
+ (ctr (polycenter verts))
+ (xc (first ctr))
+ (yc (second ctr))
+ (scale-x (first scale-factors))
+ (scale-y (second scale-factors))
+ )
+ (mapcar #'(lambda (vertex)
+ (let* ((x (first vertex))
+ (y (second vertex))
+ (r (sqrt (+ (sqr (- x xc)) (sqr (- y yc)))))
+ )
+ (list (+ x (* scale-x (/ (- x xc) r)))
+ (+ y (* scale-y (/ (- y yc) r))))))
+ verts)))
+
+;;;--------------------
+;;; End.
diff --git a/polygons/src/math.cl b/polygons/src/math.cl
new file mode 100644
index 0000000..8848160
--- /dev/null
+++ b/polygons/src/math.cl
@@ -0,0 +1,156 @@
+;;;
+;;; math
+;;;
+;;; replication of some functions from prism misc module to make the
+;;; polygons package independent. Also includes package definition
+;;; and related global information.
+;;;
+;;; 1-Apr-1993 I. Kalet created
+;;; 07-Aug-1994 J. Unger add optional EPSILON param to NEAR so caller can
+;;; specify the value for EPSILON.
+;;; 8-Jan-1995 I. Kalet remove proclaim optimize form
+;;; 1-Sep-1995 I. Kalet change macros to functions
+;;; 1-Mar-1997 I. Kalet change keyword :epsilon to &optional
+;;; 8-May-1997 BobGian add SQR; inline SQR, AVERAGE.
+;;; 23-Jun-1997 BobGian add declaration for vars in NEARLY-EQUAL.
+;;; 03-Jul-1997 BobGian move NEARLY-EQUAL, NEARLY-INCREASING, and
+;;; NEARLY-DECREASING from misc.cl to this file; they were duplicated there.
+;;; All are now in here and in the POLYGONS package. (PRISM system now
+;;; explicitly depends on POLYGONS system.) Updated all calls throughout
+;;; PRISM to use the new definitions. Made optional EPSILON argument
+;;; explicit in arglist rather than using DEFCONSTANTed *EPSILON*
+;;; - this allows individual tuning.
+;;; Note that NEARLY-xxx all use a default EPSILON of 1.0e-5
+;;; while NEAR uses default EPSILON of 1.0e-4 at this time.
+;;; Also: NEARLY-xxx functions ALL take args as SINGLE-FLOAT only.
+;;; Rename NEAR -> NEAR-POINTS - change makes its name no longer a
+;;; very common substring - much easier to find using search/grep.
+;;; Add NEAR-COORDS with functionality identical to that of
+;;; NEAR-POINTS except that it takes args as 4 coordinate values
+;;; (pt1-x pt1-y pt2-x pt2-y) rather than as two points (sublists).
+;;; This makes it more like the NEARLY-xxx group and simplifies
+;;; argument destructuring in many places.
+;;; 3-Oct-1997 BobGian remove AVERAGE, LO-HI-COMPARE - now expanded in-place.
+;;; 27-Oct-1997 BobGian redefine SQR as macro to force compiler to inline it.
+;;; Allegro compiler does not obey INLINE decl for user-defined functions,
+;;; which is perfectly legal by CommonLisp spec.
+;;; 30-May-2001 BobGian inline NEARLY-EQUAL in NEAR-COORDS, add THE decls.
+;;; 20-Jun-2009 I. Kalet move defpackage and other globals here to be
+;;; independent of the system def file.
+;;;
+
+(defpackage "POLYGONS"
+ (:nicknames "POLY")
+ (:use "COMMON-LISP")
+ (:export "AREA-OF-POLYGON" "AREA-OF-TRIANGLE"
+ "BOUNDING-BOX"
+ "CANONICAL-CONTOUR" "CENTROID" "CLOCKWISE-TRAVERSAL-P"
+ "COLLINEAR-P" "CONTOUR-ENCLOSES-P" "CONVEX-HULL"
+ "IN-BOUNDING-BOX"
+ "NEARLY-EQUAL" "NEARLY-INCREASING" "NEARLY-DECREASING"
+ "ORTHO-EXPAND-CONTOUR"
+ "ROTATE-VERTICES"
+ "SCALE-CONTOUR" "SIMPLE-POLYGON"
+ "VERTEX-LIST-DIFFERENCE"
+ ))
+
+;;;---------------------------------------------
+
+(in-package :polygons)
+
+(defconstant *pi-over-180* (coerce (/ pi 180.0) 'single-float))
+
+;;;---------------------------------------------
+
+(defun near-points (p1 p2 &optional (epsilon 1.0e-4))
+ ;; Don't reduce the 1.0e-4 too much!
+
+ "NEAR-POINTS p1 p2 &optional (epsilon 1.0e-4)
+
+Returns T if the point P1 is within EPSILON of the point P2,
+NIL otherwise. EPSILON is an optional parameter and defaults to 1.0e-4.
+All coordinates must be SINGLE-FLOAT."
+
+ (near-coords (first p1) (second p1) (first p2) (second p2) epsilon))
+
+;;;--------
+
+(defun near-coords (p1x p1y p2x p2y &optional (epsilon 1.0e-4))
+ ;; Don't reduce the 1.0e-4 too much!
+
+ "near-coords p1x p1y p2x p2y &optional (epsilon 1.0e-4)
+
+Returns T if the point (P1X P1Y) is within EPSILON of the point (P2X P2Y),
+NIL otherwise. EPSILON is an optional parameter and defaults to 1.0e-4.
+All arguments must be SINGLE-FLOAT."
+
+ (declare (single-float p1x p1y p2x p2y epsilon))
+
+ (and (<= (- p1x p2x) epsilon)
+ (<= (- p2x p1x) epsilon)
+ (<= (- p1y p2y) epsilon)
+ (<= (- p2y p1y) epsilon)))
+
+;;;---------------------------------------------
+
+(defun nearly-equal (this that &optional (epsilon 1.0e-5))
+
+ "NEARLY-EQUAL this that &optional (epsilon 1.0e-5)
+
+Returns T if THIS is within EPSILON of THAT, inclusive, NIL otherwise.
+Note that the default EPSILON is arbitrary. Your calculation may require
+a coarser or finer grain. Args all SINGLE-FLOAT."
+
+ (declare (single-float this that epsilon))
+ (and (<= (- this that) epsilon)
+ (<= (- that this) epsilon)))
+
+;;;------------------------------------------
+
+(defun nearly-increasing (a b c &optional (epsilon 1.0e-5))
+
+ "NEARLY-INCREASING a b c &optional (epsilon 1.0e-5)
+
+Returns T if A, B, C form a nondecreasing sequence relaxed by EPSILON;
+that is, if (<= (- A EPSILON) B (+ C EPSILON)) is true (and returns NIL
+otherwise). Note that the default EPSILON is arbitrary. Your calculation
+may require a coarser or finer grain. Args all SINGLE-FLOAT."
+
+ (declare (single-float a b c epsilon))
+ (<= (- a epsilon) b (+ c epsilon)))
+
+;;;------------------------------------------
+
+(defun nearly-decreasing (a b c &optional (epsilon 1.0e-5))
+
+ "NEARLY-DECREASING a b c &optional (epsilon 1.0e-5)
+
+Returns T if A, B, C form a nonincreasing sequence relaxed by EPSILON;
+that is, if (>= (+ A EPSILON) B (- C EPSILON)) is true (and returns NIL
+otherwise). Note that the default EPSILON is arbitrary. Your calculation
+may require a coarser or finer grain. Args all SINGLE-FLOAT."
+
+ (declare (single-float a b c epsilon))
+ (>= (+ a epsilon) b (- c epsilon)))
+
+;;;------------------------------------------
+
+(defmacro sqr (x)
+
+ "SQR x
+Returns X squared (single-float in/out only)."
+
+ (cond ((symbolp x)
+ ;; Simple case - can evaluate arg twice because it is a variable.
+ `(the single-float (* (the single-float ,x)
+ (the single-float ,x))))
+ ;;
+ ;; Slightly harder case - want to avoid double evaluation
+ ;; of argument form.
+ (t (let ((var (gensym)))
+ `(let ((,var (the single-float ,x)))
+ (the single-float
+ (* (the single-float ,var) (the single-float ,var))))))))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/polygons/src/segments.cl b/polygons/src/segments.cl
new file mode 100644
index 0000000..aadf694
--- /dev/null
+++ b/polygons/src/segments.cl
@@ -0,0 +1,147 @@
+;;;
+;;; segments
+;;;
+;;; contains functions that work with segments and polygons
+;;;
+;;; 1-May-2004 I. Kalet created from code in the contour editor
+;;;
+
+(in-package :polygons)
+
+;;;-----------------------------------
+
+(defun segments-overlap (a b x y p q)
+
+ "segments-overlap a b x y p q
+
+Returns t iff any point of segment ((a,b), (x,y)) coincides with
+any point of segment ((x,y), (p,q)) with the exception of the shared
+vertex (x,y)."
+
+ (declare (single-float a b x y p q))
+ (and (collinear-p a b x y p q)
+ (not (in-bounding-box a b x y p q))))
+
+;;;----------------------------------
+
+(defun segments-intersect (a b c d p q r s)
+
+ "segments-intersect a b c d p q r s
+
+Returns t iff the segments defined by ((a,b),(c,d)) and ((p,q),(r,s))
+intersect, nil otherwise."
+
+ ;; Algorithm: first, determine whether the two edges are parallel or
+ ;; coincident to each other, or not. If they're parallel or
+ ;; coincident, determine which (if parallel, then they don't
+ ;; intersect, so return nil; if coincident, they do intersect, so
+ ;; return t). If they're not parallel or coincident then find the
+ ;; intersection point between the two lines running through the pair
+ ;; of segments, and test to see if this intersection point actually
+ ;; lies within each of the two segments. If so, return t. If not,
+ ;; don't.
+
+ (let* ((k (- c a))
+ (l (- d b))
+ (m (- r p))
+ (n (- s q))
+ (den (- (* m l) (* n k))))
+ (declare (single-float a b c d p q r s k l m n den))
+
+ ;; if den is zero, the two lines have the same slope (dy/dx is the same
+ ;; for both) -- so they must be parallel or coincident
+ (if (nearly-equal den 0.0)
+
+ ;; Below is true exactly when the lines are coincident and they
+ ;; share some overlap. The lines determined by the segments will
+ ;; be coincident when they are collinear. The segments will share
+ ;; some overlap when one of the three cases is true:
+ ;; cd is between pq and rs
+ ;; ab is between pq and rs
+ ;; pq is between ab and cd
+ (and (collinear-p a b c d p q)
+ (or (in-bounding-box p q c d r s)
+ (in-bounding-box p q a b r s)
+ (in-bounding-box a b p q c d)))
+
+ ;; below is executed for segs that are neither // nor coincident
+ (let* ((x (float (/ (+ (* k m q) (* m l a)
+ (- (* k m b)) (- (* k n p)))
+ den)))
+ (y (float (/ (+ (* k n b) (* l n p)
+ (- (* l m q)) (- (* l n a)))
+ (- den)))))
+ (declare (single-float x y))
+ ;; is the point of intersection on both segs?
+ (and (in-bounding-box a b x y c d)
+ (in-bounding-box p q x y r s))))))
+
+;;;-----------------------------------
+
+(defun segment-crosses-polygon (segptr)
+
+ "segment-crosses-polygon segptr
+
+Segptr is assumed to be a pointer to a circular list of x y x y vertex
+pairs, constituting a polygon. Returns t iff the second segment
+pointed to by segptr crosses or touches any other segment of the
+polygon, excepting the first and third segments pointed to by segptr,
+which share adjacent vertices with the second segment but may not
+overlap with that segment - nil otherwise."
+
+ ;; test first and second segments for overlap
+ (when (segments-overlap (first segptr) (second segptr)
+ (third segptr) (fourth segptr)
+ (fifth segptr) (sixth segptr))
+ (return-from segment-crosses-polygon t))
+
+ ;; test second and third segments for overlap
+ (setf segptr (cddr segptr))
+ (when (segments-overlap (first segptr) (second segptr)
+ (third segptr) (fourth segptr)
+ (fifth segptr) (sixth segptr))
+ (return-from segment-crosses-polygon t))
+
+ ;; test rest of segments against second in loop
+ (do ((next (nthcdr 4 segptr) (cddr next))
+ (a (first segptr))
+ (b (second segptr))
+ (c (third segptr))
+ (d (fourth segptr)))
+ ((eq (cddr next) segptr))
+ (when (segments-intersect a b c d
+ (first next) (second next)
+ (third next) (fourth next))
+ (return-from segment-crosses-polygon t)))
+
+ nil) ; all clear if get this far
+
+;;;------------------------------------
+
+(defun simple-polygon (flattened-vertex-list)
+
+ "simple-polygon flattened-vertex-list
+
+Returns t iff none of the segments of the vertex list flattened-vertex-list
+intersect or touch, excepting adjacent segments, which touch at their shared
+vertices; nil otherwise. Two adjacent segments which share any more
+than a vertex is considered an intersection. The segment connecting
+the ends of flattened-vertex-list together is also explicitly tested."
+
+ ;; Close a copy of flattened-vertex-list together and test each segment
+ ;; against all other segments, allowing for the two segments adjacent to
+ ;; the segment currently being tested to touch, but not to coincide.
+ ;; When exiting, ...
+ ;;
+ (let ((verts (copy-list flattened-vertex-list)))
+ (setf (cdr (last verts)) verts)
+ (when (segment-crosses-polygon verts) ; test first segment outside loop
+ (return-from simple-polygon nil))
+ (do ((next (cddr verts) (cddr next)))
+ ((eq next verts))
+ (when (segment-crosses-polygon next)
+ (return-from simple-polygon nil)))
+ t)) ;; return true if all segments check out
+
+;;;------------------------------------
+;;; End.
diff --git a/prism/src/anatomy-tree.cl b/prism/src/anatomy-tree.cl
new file mode 100644
index 0000000..e40ccf5
--- /dev/null
+++ b/prism/src/anatomy-tree.cl
@@ -0,0 +1,532 @@
+;;;
+;;; anatomy-tree
+;;;
+;;; 31-Jan-1991 C. Sweeney and B. Lockyear added instances of anatomy-tree
+;;; with class definition, removed load-anatomy-tree function,
+;;; and added initialize-instance method.
+;;; 7-Feb-1991 C. Sweeney fix typo and change names to symbols.
+;;; 16-Feb-1991 I. Kalet move the within function to here, from prototypes
+;;; also, correct some spelling errors in node names
+;;; 29-Mar-1991 I. Kalet add print-tree
+;;; 11-Apr-1991 I. Kalet add within-p ruler function here - used by both
+;;; generate-prototypes and generate-target
+;;; 21-Nov-1991 I. Kalet take out use-package
+;;; 30-Jul-1993 I. Kalet change package to autoplan.
+;;; 22-Mar-1994 J. Unger change 'site to 'pr:site in within-p definition
+;;; 24-Mar-1994 J. Unger move anatomy-tree into prism package, change
+;;; 'pr:site back to 'site & pr:tab-print to tab-print.
+;;; 28-Mar-1994 J. Unger move within-p to margin-rules.
+;;; 12-Jan-1995 I. Kalet move print-tree export to prism-system
+;;; 13-Sep-2005 I. Kalet add assertions for Graham inference code.
+;;; This module now depends on file-functions (for tab-print) and on
+;;; the inference module (with added macros).
+;;; 25-Jun-2008 I. Kalet move use-package call to prism defpackage
+;;;
+
+(in-package :prism)
+
+;;--------------------------------------
+;;; definition of anatomy tree nodes
+;;;--------------------------------------
+
+(defclass anatomy-tree-node ()
+
+ ((name :initarg :name
+ :accessor name)
+
+ (part-of :initarg :part-of
+ :accessor part-of)
+
+ (parts :initarg :parts
+ :accessor parts
+ :documentation "A list of symbols naming daughter nodes")
+
+ )
+
+ (:default-initargs :name nil :part-of nil :parts nil)
+
+ (:documentation "Each instance represents a single anatomic site or
+larger anatomic region. The tree structure implied by the parts and
+part-of slots describes anatomic relationships of tumor sites and
+groups of tumor sites.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((anode anatomy-tree-node)
+ &key name &allow-other-keys)
+ "This method makes the node available by name"
+ (set name anode)
+ (assert-value 'part-of (name anode) (part-of anode))
+ )
+
+;;;-------------------------------------------
+;;; rules that establish the subpart relation
+;;; which is the transitive closure of part-of
+;;;-------------------------------------------
+
+(<- (same ?x ?x))
+(<- (subpart ?x ?y) (same ?x ?y))
+(<- (subpart ?x ?y) (AND (part-of ?x ?z)
+ (subpart ?z ?y)))
+
+;;;-------------------------------------------
+;;; The within relation applies to an entity that has
+;;; a site property, which should be asserted separately.
+;;;-------------------------------------------
+
+(<- (within ?x ?y) (AND (site ?x ?z)
+ (subpart ?z ?y)))
+
+;;;-------------------------------------------
+;;; This is a functional version of within that
+;;; only applies to anatomy tree nodes.
+;;;-------------------------------------------
+
+(defun within (here there)
+
+ "WITHIN here there
+
+takes two anatomy tree node symbols and determines if THERE is equal
+to or an ancestor of HERE. Returns true if so, false otherwise.
+Error occurs if HERE or THERE is not a valid anatomy tree node."
+
+ (cond ((null here) nil)
+ ((eql here there) t)
+ (t (within (slot-value (symbol-value here) 'part-of) there))))
+
+;;;--------------------------------------
+
+(defun print-tree (node &key (indent 0) (stream t))
+
+ "PRINT-TREE node &key (indent 0) (stream t)
+
+Prints the name of node and all its sub-nodes recursively, to the
+indicated stream, default is *standard-output*, indenting by the
+number of spaces indicated by indent, at each level of subnodes.
+Returns nil."
+
+ (when node
+ (tab-print (name node) stream indent t)
+ (mapc #'(lambda (x) (print-tree (symbol-value x)
+ :indent (+ indent 3) :stream stream))
+ (parts node))
+ t))
+
+;;;----------------------------------------
+
+;;;---- the actual anatomy tree nodes follow ----
+
+(make-instance 'anatomy-tree-node
+ :name 'LUNG
+ :part-of 'BODY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'THYROID-GLAND
+ :part-of 'HEAD-AND-NECK
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'CRANIAL-NERVE-FORAMEN
+ :part-of 'BASE-OF-SKULL
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'MASTOID-AIR-CELLS
+ :part-of 'BASE-OF-SKULL
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PTERYGOID-PLATES
+ :part-of 'BASE-OF-SKULL
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PTERYGOID-MUSCLE
+ :part-of 'BASE-OF-SKULL
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'BASE-OF-SKULL
+ :part-of 'HEAD-AND-NECK
+ :parts '(CRANIAL-NERVE-FORAMEN MASTOID-AIR-CELLS
+ PTERYGOID-PLATES PTERYGOID-MUSCLE)
+)
+(make-instance 'anatomy-tree-node
+ :name 'BONE
+ :part-of 'HEAD-AND-NECK
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'NECK
+ :part-of 'HEAD-AND-NECK
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'ORBIT
+ :part-of 'HEAD-AND-NECK
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'SKIN
+ :part-of 'HEAD-AND-NECK
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'ORBITAL-BODY
+ :part-of 'GLOMUS-BODY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'CAROTID-BODY
+ :part-of 'GLOMUS-BODY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'VAGAL-BODY
+ :part-of 'GLOMUS-BODY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'SUPERIOR-LARYNGEAL-GLOMUS-BODY
+ :part-of 'GLOMUS-BODY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'TEMPORAL-BONE-GLOMUS-BODY
+ :part-of 'GLOMUS-BODY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'GLOMUS-BODY
+ :part-of 'HEAD-AND-NECK
+ :parts '(ORBITAL-BODY CAROTID-BODY VAGAL-BODY
+ SUPERIOR-LARYNGEAL-GLOMUS-BODY TEMPORAL-BONE-GLOMUS-BODY)
+ )
+(make-instance 'anatomy-tree-node
+ :name 'INNER-EAR
+ :part-of 'EAR
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PETROMASTOID
+ :part-of 'MIDDLE-EAR
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'MIDDLE-EAR
+ :part-of 'EAR
+ :parts '(PETROMASTOID)
+)
+(make-instance 'anatomy-tree-node
+ :name 'EXTERNAL-AUDITORY-CANAL
+ :part-of 'EXTERNAL-EAR
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'AURICLE
+ :part-of 'EXTERNAL-EAR
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'EXTERNAL-EAR
+ :part-of 'EAR
+ :parts '(EXTERNAL-AUDITORY-CANAL AURICLE)
+)
+(make-instance 'anatomy-tree-node
+ :name 'EAR
+ :part-of 'HEAD-AND-NECK
+ :parts '(INNER-EAR MIDDLE-EAR EXTERNAL-EAR)
+)
+(make-instance 'anatomy-tree-node
+ :name 'MINOR-SALIVARY-GLANDS
+ :part-of 'SALIVARY-GLANDS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'SUBMANDIBULAR
+ :part-of 'MAJOR-SALIVARY-GLANDS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'SUBLINGUAL-GLANDS
+ :part-of 'MAJOR-SALIVARY-GLANDS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PAROTID
+ :part-of 'MAJOR-SALIVARY-GLANDS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'MAJOR-SALIVARY-GLANDS
+ :part-of 'SALIVARY-GLANDS
+ :parts '(SUBMANDIBULAR SUBLINGUAL-GLANDS PAROTID)
+)
+(make-instance 'anatomy-tree-node
+ :name 'SALIVARY-GLANDS
+ :part-of 'HEAD-AND-NECK
+ :parts '(MINOR-SALIVARY-GLANDS MAJOR-SALIVARY-GLANDS)
+)
+(make-instance 'anatomy-tree-node
+ :name 'SPHENOIDAL-SINUS
+ :part-of 'PARANASAL-SINUSES
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'ETHMOIDAL-SINUS
+ :part-of 'PARANASAL-SINUSES
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'FRONTAL-SINUS
+ :part-of 'PARANASAL-SINUSES
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'MAXILLARY-SINUS
+ :part-of 'PARANASAL-SINUSES
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PARANASAL-SINUSES
+ :part-of 'NASAL-FOSSA-AND-SINUSES
+ :parts '(SPHENOIDAL-SINUS ETHMOIDAL-SINUS FRONTAL-SINUS
+ MAXILLARY-SINUS)
+)
+(make-instance 'anatomy-tree-node
+ :name 'NASAL-FOSSA
+ :part-of 'NASAL-FOSSA-AND-SINUSES
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'NASAL-FOSSA-AND-SINUSES
+ :part-of 'HEAD-AND-NECK
+ :parts '(PARANASAL-SINUSES NASAL-FOSSA)
+)
+(make-instance 'anatomy-tree-node
+ :name 'AERYTENOIDS
+ :part-of 'SUPRAGLOTTIS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'FALSE-CORD
+ :part-of 'SUPRAGLOTTIS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'VENTRICLE
+ :part-of 'SUPRAGLOTTIS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PHARYNGEAL-EPIGLOTTIC-FOLD
+ :part-of 'SUPRAGLOTTIS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'AERYEPIGLOTTIC-FOLD
+ :part-of 'SUPRAGLOTTIS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'EPIGLOTTIS
+ :part-of 'SUPRAGLOTTIS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'SUPRAGLOTTIS
+ :part-of 'LARYNX
+ :parts '(AERYTENOIDS FALSE-CORD VENTRICLE
+ PHARYNGEAL-EPIGLOTTIC-FOLD AERYEPIGLOTTIC-FOLD
+ EPIGLOTTIS)
+)
+(make-instance 'anatomy-tree-node
+ :name 'TRACHEA
+ :part-of 'SUBGLOTTIS
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'SUBGLOTTIS
+ :part-of 'LARYNX
+ :parts '(TRACHEA)
+)
+(make-instance 'anatomy-tree-node
+ :name 'GLOTTIS
+ :part-of 'LARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'LARYNX
+ :part-of 'HEAD-AND-NECK
+ :parts '(SUPRAGLOTTIS SUBGLOTTIS GLOTTIS)
+)
+(make-instance 'anatomy-tree-node
+ :name 'LOWER-PHARYNGEAL-WALL
+ :part-of 'HYPOPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'POSTERICOID
+ :part-of 'HYPOPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PYRIFORM-SINUS
+ :part-of 'HYPOPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'HYPOPHARYNX
+ :part-of 'PHARYNX
+ :parts '(LOWER-PHARYNGEAL-WALL POSTERICOID PYRIFORM-SINUS)
+)
+(make-instance 'anatomy-tree-node
+ :name 'LATERAL-PHARYNGEAL-WALL
+ :part-of 'PHARYNGEAL-WALL
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'POST-PHARYNGEAL-WALL
+ :part-of 'PHARYNGEAL-WALL
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'PHARYNGEAL-WALL
+ :part-of 'OROPHARYNX
+ :parts '(LATERAL-PHARYNGEAL-WALL POST-PHARYNGEAL-WALL)
+)
+(make-instance 'anatomy-tree-node
+ :name 'UVULA
+ :part-of 'OROPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'BASE-OF-TONGUE
+ :part-of 'OROPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'SOFT-PALATE
+ :part-of 'OROPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'POSTERIOR-TONSILLAR-PILLAR
+ :part-of 'TONSILLAR-PILLAR
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'ANTERIOR-TONSILLAR-PILLAR
+ :part-of 'TONSILLAR-PILLAR
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'TONSILLAR-PILLAR
+ :part-of 'TONSIL-AND-FOSSA
+ :parts '(POSTERIOR-TONSILLAR-PILLAR ANTERIOR-TONSILLAR-PILLAR)
+)
+(make-instance 'anatomy-tree-node
+ :name 'TONSILLAR-FOSSA
+ :part-of 'TONSIL-AND-FOSSA
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'TONSIL
+ :part-of 'TONSIL-AND-FOSSA
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'TONSIL-AND-FOSSA
+ :part-of 'OROPHARYNX
+ :parts '(TONSILLAR-PILLAR TONSILLAR-FOSSA TONSIL)
+)
+(make-instance 'anatomy-tree-node
+ :name 'OROPHARYNX
+ :part-of 'PHARYNX
+ :parts '(PHARYNGEAL-WALL UVULA BASE-OF-TONGUE SOFT-PALATE
+ TONSIL-AND-FOSSA)
+)
+(make-instance 'anatomy-tree-node
+ :name 'POSTERIOR-SUPERIOR-WALL
+ :part-of 'NASOPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'LATERAL-WALL
+ :part-of 'NASOPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'INFERIOR-WALL
+ :part-of 'NASOPHARYNX
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'NASOPHARYNX
+ :part-of 'PHARYNX
+ :parts '(POSTERIOR-SUPERIOR-WALL LATERAL-WALL INFERIOR-WALL)
+)
+(make-instance 'anatomy-tree-node
+ :name 'PHARYNX
+ :part-of 'HEAD-AND-NECK
+ :parts '(HYPOPHARYNX OROPHARYNX NASOPHARYNX)
+)
+(make-instance 'anatomy-tree-node
+ :name 'MOBILE-TONGUE
+ :part-of 'ORAL-CAVITY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'RETROMOLAR-TRIGONE
+ :part-of 'ORAL-CAVITY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'LIP
+ :part-of 'ORAL-CAVITY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'HARD-PALATE
+ :part-of 'ORAL-CAVITY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'GINGIVA
+ :part-of 'ORAL-CAVITY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'FLOOR-OF-MOUTH
+ :part-of 'ORAL-CAVITY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'BUCCAL-MUCOSA
+ :part-of 'ORAL-CAVITY
+ :parts NIL
+)
+(make-instance 'anatomy-tree-node
+ :name 'ORAL-CAVITY
+ :part-of 'HEAD-AND-NECK
+ :parts '(MOBILE-TONGUE RETROMOLAR-TRIGONE LIP HARD-PALATE
+ GINGIVA FLOOR-OF-MOUTH BUCCAL-MUCOSA)
+)
+(make-instance 'anatomy-tree-node
+ :name 'HEAD-AND-NECK
+ :part-of 'BODY
+ :parts '(THYROID-GLAND BASE-OF-SKULL BONE NECK ORBIT
+ SKIN GLOMUS-BODY EAR SALIVARY-GLANDS
+ NASAL-FOSSA-AND-SINUSES LARYNX PHARYNX
+ ORAL-CAVITY)
+)
+(make-instance 'anatomy-tree-node
+ :name 'BODY
+ :part-of NIL
+ :parts '(LUNG HEAD-AND-NECK)
+)
+
+;;;--------------------------------------
diff --git a/prism/src/attribute-editor.cl b/prism/src/attribute-editor.cl
new file mode 100644
index 0000000..d21750c
--- /dev/null
+++ b/prism/src/attribute-editor.cl
@@ -0,0 +1,762 @@
+;;;
+;;; attribute-editor
+;;;
+;;; The attribute-editor provides a facility for editing textual and
+;;; other non-graphical attributes of an organ, tumor, target, or
+;;; other pstruct. The base class and default constructor function
+;;; are provided as well as specific classes and constructors for
+;;; organs, tumors, and targets.
+;;;
+;;; 26-May-1993 J. Unger created.
+;;; 16-Aug-1993 I. Kalet allow other keys in initialize-instance
+;;; 18-Oct-1993 I. Kalet add code for tumors and targets, move name
+;;; and color here
+;;; 2-Dec-1993 I. Kalet change side to symbol
+;;; 22-Mar-1994 J. Unger make tumor-attr-editor match ptvt specs.
+;;; 27-May-1994 J. Unger change 'other to 'body in site list.
+;;; 31-May-1994 I. Kalet make button width parameterized.
+;;; 27-Jun-1994 I. Kalet add Density on/off button in organ editor
+;;; 05-Jul-1994 J. Unger add remove-notify for new-density event of
+;;; organ attrib editor to fix bug.
+;;; 06-Jul-1994 J. Unger minor fix to init of use/ignore in comp
+;;; button.
+;;; 8-Jan-1995 I. Kalet initialize density to nil as specified in the
+;;; implementation report. Destroy "use in comp" button in organ.
+;;; 8-Oct-1996 I. Kalet make req. dose textline in target numeric.
+;;; 24-Jun-1997 I. Kalet squeeze tumor editor vertically to fit the
+;;; medium easel size, change global pars to local vars in let forms,
+;;; don't initialize organ density or tolerance dose - they are now
+;;; guaranteed to be bound, delete Name: label in name textline.
+;;; 10-Mar-1998 I. Kalet coerce density, and tolerance dose to single
+;;; float on input.
+;;; 12-Apr-2000 I. Kalet use smaller font everywhere.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 26-Apr-2004 I. Kalet add editor panel for points
+;;; 17-May-2004 I. Kalet take out unnecessary local var in
+;;; initialize-instance method of point editor.
+;;; 25-Aug-2005 I. Kalet finish up point attribute editor
+;;;
+
+(in-package :prism)
+
+;;;-----------------------------------
+
+(defclass attribute-editor (generic-panel)
+
+ ((width :type fixnum
+ :accessor width
+ :initarg :width
+ :documentation "The width in pixels to make the frame")
+
+ (height :type fixnum
+ :accessor height
+ :initarg :height
+ :documentation "The height in pixels to make the frame")
+
+ (button-width :type fixnum
+ :accessor button-width
+ :initarg :button-width
+ :documentation "The width in pixels of an attribute
+editor button or textline.")
+
+ (fr :type sl:frame
+ :accessor fr
+ :documentation "The SLIK frame that contains the attribute
+editor.")
+
+ (object :type pstruct
+ :accessor object
+ :initarg :object
+ :documentation "The object to be edited by this attribute
+editor.")
+
+ (name-tln ;; :type sl:textline
+ :accessor name-tln
+ :documentation "The SLIK textline displaying the name of
+the pstruct being edited.")
+
+ (color-btn ;; :type sl:button
+ :accessor color-btn
+ :documentation "The color button for the pstruct being
+edited by the easel.")
+
+ )
+
+ (:default-initargs :width 150 :button-width 140 :height 75)
+
+ (:documentation "An attribute editor provides a facility for editing
+the textual and other non-graphical attributes of an object descended
+from the pstruct class.")
+
+ )
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((ae attribute-editor)
+ &rest initargs)
+
+ "Initializes the user interface for the basic attribute editor."
+
+ (let* ((frm (apply #'sl:make-frame (width ae) (height ae)
+ :title "Prism Attribute Editor"
+ initargs))
+ (frm-win (sl:window frm))
+ (obj (object ae))
+ (dx 5)
+ (bth 25)
+ (btw (- (width ae) (* 2 dx)))
+ (att-f (symbol-value *small-font*)) ;; the value, not the symbol
+ (name-t (apply #'sl:make-textline btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y dx
+ initargs))
+ (color-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 1)
+ :label "Color"
+ :button-type :momentary
+ initargs)))
+ (setf (fr ae) frm
+ (name-tln ae) name-t
+ (color-btn ae) color-b
+ (button-width ae) btw
+ (sl:info name-t) (name obj))
+ (ev:add-notify obj (sl:new-info name-t)
+ #'(lambda (ob tl new-info)
+ (declare (ignore tl))
+ (setf (name ob) new-info)))
+ (ev:add-notify obj (sl:button-on color-b)
+ #'(lambda (ob bt)
+ ;; maybe handle invisible differently ??
+ (setf (display-color ob)
+ (or (sl:popup-color-menu) (display-color ob)))
+ (setf (sl:fg-color bt) (display-color ob))
+ ;; popup-color-menu leaves it on
+ (setf (sl:on bt) nil)))
+ (setf (sl:fg-color color-b) (display-color obj))))
+
+;;;-----------------------------------
+
+(defmethod make-attribute-editor ((pstr pstruct) &rest initargs)
+
+ "make-attribute-editor ((pstr pstruct) &rest initargs
+
+Returns the default attribute-editor with specified parameters."
+
+ (apply #'make-instance 'attribute-editor
+ :object pstr :allow-other-keys t
+ initargs))
+
+;;;-----------------------------------
+
+(defmethod destroy :before ((ae attribute-editor))
+
+ "Releases X resources used by this panel."
+
+ (sl:destroy (color-btn ae))
+ (sl:destroy (name-tln ae))
+ (sl:destroy (fr ae)))
+
+;;;-----------------------------------
+
+(defclass organ-attribute-editor (attribute-editor)
+
+ ((density-button :accessor density-button
+ :documentation "The button that turns on/off the
+density attribute")
+
+ (density-tln ;; :type sl:textline
+ :accessor density-tln
+ :documentation "The density textline.")
+
+ (tol-dose-tln ;; :type sl:textline
+ :accessor tol-dose-tln
+ :documentation "The tolerance dose textline.")
+
+ )
+
+ (:default-initargs :height 155)
+
+ (:documentation "The subclass of attribute editor specific to
+organs.")
+
+ )
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((ae organ-attribute-editor)
+ &rest initargs)
+
+ "Initializes the user interface for the organ attribute editor."
+
+ (let* ((frm (fr ae))
+ (frm-win (sl:window frm))
+ (obj (object ae))
+ (dx 5)
+ (bth 25)
+ (btw (button-width ae))
+ (att-f (symbol-value *small-font*)) ;; the value, not the symbol
+ (den-btn (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 2)
+ :label (if (density obj)
+ "Use in comp."
+ "Ignore in comp.")
+ :button-type :momentary
+ initargs))
+ (den-t (apply #'sl:make-textline btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 3)
+ :label "Den: "
+ :numeric t :lower-limit 0.0 :upper-limit 20.0
+ :info (if (density obj)
+ (write-to-string (density obj))
+ "None")
+ initargs))
+ (tol-t (apply #'sl:make-textline btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 4)
+ :label "Tol: "
+ :numeric t :lower-limit 0.0 :upper-limit 10000.0
+ :info (write-to-string (tolerance-dose obj))
+ initargs)))
+ (setf (density-button ae) den-btn
+ (density-tln ae) den-t
+ (tol-dose-tln ae) tol-t)
+ (ev:add-notify ae (sl:button-on den-btn)
+ #'(lambda (aed btn)
+ (if (density (object aed))
+ (progn
+ (setf (density (object aed)) nil)
+ (setf (sl:label btn) "Ignore in comp."))
+ (progn
+ (setf (density (object aed)) 1.0)
+ (setf (sl:label btn) "Use in comp.")))))
+ (ev:add-notify ae (sl:new-info tol-t)
+ #'(lambda (aed a new-info)
+ (declare (ignore a))
+ (setf (tolerance-dose (object aed))
+ (coerce (read-from-string new-info)
+ 'single-float))))
+ (ev:add-notify ae (sl:new-info den-t)
+ #'(lambda (aed tl new-info)
+ (if (density (object aed))
+ (setf (density (object aed))
+ (coerce (read-from-string new-info)
+ 'single-float))
+ (setf (sl:info tl) "None"))))
+ (ev:add-notify ae (new-density obj)
+ #'(lambda (aed org new-den)
+ (declare (ignore org))
+ (setf (sl:info (density-tln aed))
+ (if new-den new-den "None"))))))
+
+;;;-----------------------------------
+
+(defmethod make-attribute-editor ((org organ) &rest initargs)
+
+ "make-attribute-editor (org organ) &rest initargs
+
+Returns an organ-specific attribute-editor with specified parameters."
+
+ (apply #'make-instance 'organ-attribute-editor
+ :object org :allow-other-keys t
+ initargs))
+
+;;;-----------------------------------
+
+(defmethod destroy :before ((ae organ-attribute-editor))
+
+ "Releases additional X resources used by this panel."
+
+ (ev:remove-notify ae (new-density (object ae)))
+ (sl:destroy (density-button ae))
+ (sl:destroy (density-tln ae))
+ (sl:destroy (tol-dose-tln ae)))
+
+;;;-----------------------------------
+
+(defclass tumor-attribute-editor (attribute-editor)
+
+ ((site-btn :accessor site-btn
+ :documentation "The site button.")
+
+ (t-stage-btn :accessor t-stage-btn
+ :documentation "The T-stage button.")
+
+ (n-stage-btn :accessor n-stage-btn
+ :documentation "The N-stage button.")
+
+ (cell-type-btn :accessor cell-type-btn
+ :documentation "The cell type button.")
+
+ (region-btn :accessor region-btn
+ :documentation "The region button.")
+
+ (side-btn :accessor side-btn
+ :documentation "The side button.")
+
+ (fixed-btn :accessor fixed-btn
+ :documentation "The fixed? button.")
+
+ (pulm-risk-btn :accessor pulm-risk-btn
+ :documentation "The pulmonary risk button.")
+
+ )
+
+ (:default-initargs :height 305)
+
+ (:documentation "The subclass of attribute editor specific to
+tumors.")
+
+ )
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((ae tumor-attribute-editor)
+ &rest initargs)
+
+ "Initializes the user interface for the tumor attribute editor."
+
+ (let* ((frm (fr ae))
+ (frm-win (sl:window frm))
+ (obj (object ae))
+ (dx 5)
+ (bth 25)
+ (att-f (symbol-value *small-font*)) ;; the value, not the symbol
+ (btw (button-width ae))
+ (site-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 2)
+ :label (format nil "Site: ~a" (site obj))
+ initargs))
+ (t-stage-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 3)
+ :label (format nil "T-Stage: ~a"
+ (t-stage obj))
+ initargs))
+ (n-stage-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 4)
+ :label (format nil "N-Stage ~a"
+ (n-stage obj))
+ initargs))
+ (cell-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 5)
+ :label (format nil "Cell type: ~a"
+ (cell-type obj))
+ initargs))
+ (region-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 6)
+ :label (format nil "Region: ~a"
+ (region obj))
+ initargs))
+ (side-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 7)
+ :label (format nil "Side: ~a"
+ (side obj))
+ initargs))
+ (fixed-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 8)
+ :label (format nil "Fixed?: ~a"
+ (fixed obj))
+ initargs))
+ (pulm-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 9)
+ :label (format nil "Pulm Risk: ~a"
+ (pulm-risk obj))
+ initargs)))
+ (setf (site-btn ae) site-b
+ (t-stage-btn ae) t-stage-b
+ (n-stage-btn ae) n-stage-b
+ (cell-type-btn ae) cell-b
+ (region-btn ae) region-b
+ (side-btn ae) side-b
+ (fixed-btn ae) fixed-b
+ (pulm-risk-btn ae) pulm-b)
+ (ev:add-notify obj (sl:button-on site-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu '("Lung"
+ "Nasopharynx"
+ "Body"))))
+ (when selection
+ (setf (site ob) (case selection
+ (0 'lung)
+ (1 'nasopharynx)
+ (2 'body)))
+ (setf (sl:label bt)
+ (format nil "Site: ~a" (site ob))))
+ (setf (sl:on bt) nil)))) ;; popup-menu leaves it on
+ (ev:add-notify obj (sl:button-on t-stage-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu
+ '("T1" "T2" "T3" "T4"))))
+ (when selection
+ (setf (t-stage ob)
+ (case selection (0 'T1) (1 'T2) (2 'T3) (3 'T4)))
+ (setf (sl:label bt)
+ (format nil "T-Stage: ~a" (t-stage ob))))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify obj (sl:button-on n-stage-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu
+ '("N0" "N1" "N2" "N3"))))
+ (when selection
+ (setf (n-stage ob)
+ (case selection (0 'N0) (1 'N1) (2 'N2) (3 'N3)))
+ (setf (sl:label bt)
+ (format nil "N-Stage: ~a" (n-stage ob))))
+ (setf (sl:on bt) nil))))
+
+ ;; Currently, grade not needed by ptvt. May bring back later, though.
+ ;;
+ ;; (ev:add-notify obj (sl:button-on grade-b)
+ ;; #'(lambda (ob bt)
+ ;; (let ((selection (sl:popup-menu '("Grade I"
+ ;; "Grade II"
+ ;; "Grade III"
+ ;; "Grade IV"))))
+ ;; (when selection
+ ;; (setf (grade ob) (case selection
+ ;; (0 'I) (1 'II)
+ ;; (2 'III) (3 'IV)))
+ ;; (setf (sl:label bt)
+ ;; (format nil "Grade ~A" (grade ob))))
+ ;; ;; popup-menu leaves it on
+ ;; (setf (sl:on bt) nil))))
+
+ (ev:add-notify obj (sl:button-on cell-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu
+ '("Squamous Cell"
+ "Lymphoepithelioma"
+ "Small Cell"
+ "Large Cell"
+ "Adenocarcinoma"
+ "Unclassified"))))
+ (when selection
+ (setf (cell-type ob) (case selection
+ (0 'squamous-cell)
+ (1 'lymphoepithelioma)
+ (2 'small-cell)
+ (3 'large-cell)
+ (4 'adenocarcinoma)
+ (5 'unclassified)))
+ (setf (sl:label bt)
+ (format nil "Cell type: ~a"
+ (cell-type ob))))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify obj (sl:button-on region-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu '("Hilum"
+ "Upper Lobe"
+ "Lower Lobe"
+ "Mediastinum"))))
+ (when selection
+ (setf (region ob) (case selection
+ (0 'hilum)
+ (1 'upper-lobe)
+ (2 'lower-lobe)
+ (3 'mediastinum)))
+ (setf (sl:label bt)
+ (format nil "Region: ~a" (region ob))))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify obj (sl:button-on side-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu '("Left" "Right"))))
+ (when selection
+ (setf (side ob) (case selection
+ (0 'left) (1 'right)))
+ (setf (sl:label bt)
+ (format nil "Side: ~a" (side ob))))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify obj (sl:button-on fixed-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu '("Yes" "No"))))
+ (when selection
+ (setf (fixed ob) (case selection
+ (0 'yes) (1 'no)))
+ (setf (sl:label bt)
+ (format nil "Fixed?: ~a" (fixed ob))))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify obj (sl:button-on pulm-b)
+ #'(lambda (ob bt)
+ (let ((selection (sl:popup-menu '("High" "Low"))))
+ (when selection
+ (setf (pulm-risk ob) (case selection
+ (0 'high) (1 'low)))
+ (setf (sl:label bt)
+ (format nil "Pulm Risk: ~a"
+ (pulm-risk ob))))
+ (setf (sl:on bt) nil))))))
+
+;;;-----------------------------------
+
+(defmethod make-attribute-editor ((tum tumor) &rest initargs)
+
+ "make-attribute-editor (tum tumor) &rest initargs
+
+Returns a tumor attribute-editor with specified parameters."
+
+ (apply #'make-instance 'tumor-attribute-editor
+ :object tum :allow-other-keys t
+ initargs))
+
+;;;-----------------------------------
+
+(defmethod destroy :before ((ae tumor-attribute-editor))
+
+ "Releases additional X resources used by this panel."
+
+ (sl:destroy (site-btn ae))
+ (sl:destroy (t-stage-btn ae))
+ (sl:destroy (n-stage-btn ae))
+ (sl:destroy (cell-type-btn ae))
+ (sl:destroy (region-btn ae))
+ (sl:destroy (side-btn ae))
+ (sl:destroy (fixed-btn ae))
+ (sl:destroy (pulm-risk-btn ae)))
+
+;;;-----------------------------------
+
+(defclass target-attribute-editor (attribute-editor)
+
+ ((site-btn :accessor site-btn
+ :documentation "The site button.")
+
+ (req-dose-tln :accessor req-dose-tln
+ :documentation "The required dose textline.")
+
+ (region-btn :accessor region-btn
+ :documentation "The region button.")
+
+ (target-type-btn :accessor target-type-btn
+ :documentation "The target type button.")
+
+ (nodes-btn :accessor nodes-btn
+ :documentation "The nodes button.")
+
+ )
+
+ (:default-initargs :height 215)
+
+ (:documentation "The subclass of attribute editor specific to
+targets.")
+
+ )
+
+;;;-----------------------------------
+
+(defun not-impl (obj btn)
+
+ (declare (ignore obj))
+ (sl:acknowledge "Feature not implemented")
+ (setf (sl:on btn) nil))
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((ae target-attribute-editor)
+ &rest initargs)
+
+ "Initializes the user interface for the target attribute editor."
+
+ (let* ((frm (fr ae))
+ (frm-win (sl:window frm))
+ (obj (object ae))
+ (dx 5)
+ (bth 25)
+ (btw (button-width ae))
+ (att-f (symbol-value *small-font*)) ;; the value, not the symbol
+ (site-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 2)
+ :label "Site"
+ initargs))
+ (req-dose-t (apply #'sl:make-textline btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 3)
+ :label "PD: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 20000.0
+ :info (write-to-string (required-dose obj))
+ initargs))
+ (region-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 4)
+ :label "Region"
+ initargs))
+ (targ-type-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 5)
+ :label (if (target-type obj)
+ (target-type obj)
+ "Targ. type")
+ initargs))
+ (nodes-b (apply #'sl:make-button btw bth
+ :parent frm-win :font att-f
+ :ulc-x dx :ulc-y (bp-y dx bth 6)
+ :label "Nodes"
+ initargs)))
+ (setf (site-btn ae) site-b
+ (req-dose-tln ae) req-dose-t
+ (region-btn ae) region-b
+ (target-type-btn ae) targ-type-b
+ (nodes-btn ae) nodes-b)
+ (ev:add-notify obj (sl:button-on site-b) #'not-impl)
+ (ev:add-notify obj (sl:new-info req-dose-t)
+ #'(lambda (ob tln dose)
+ (declare (ignore tln))
+ (setf (required-dose ob)
+ (coerce (read-from-string dose)
+ 'single-float))))
+ (ev:add-notify obj (sl:button-on region-b) #'not-impl)
+ (ev:add-notify obj (sl:button-on targ-type-b)
+ #'(lambda (ob btn)
+ (let ((selection (sl:popup-menu '("Initial"
+ "Boost"))))
+ (when selection
+ (setf (target-type ob) (case selection
+ (0 "Initial")
+ (1 "Boost")))
+ (setf (sl:label btn) (target-type ob)))
+ (setf (sl:on btn) nil))))
+ (ev:add-notify obj (sl:button-on nodes-b) #'not-impl)))
+
+;;;-----------------------------------
+
+(defmethod make-attribute-editor ((targ target) &rest initargs)
+
+ "make-attribute-editor (targ target) &rest initargs
+
+Returns a target attribute-editor with specified parameters."
+
+ (apply #'make-instance 'target-attribute-editor
+ :object targ :allow-other-keys t
+ initargs))
+
+;;;-----------------------------------
+
+(defmethod destroy :before ((ae target-attribute-editor))
+
+ "Releases additional X resources used by this panel."
+
+ (sl:destroy (site-btn ae))
+ (sl:destroy (req-dose-tln ae))
+ (sl:destroy (region-btn ae))
+ (sl:destroy (target-type-btn ae))
+ (sl:destroy (nodes-btn ae)))
+
+;;;-----------------------------------
+
+(defclass point-attribute-editor (attribute-editor)
+
+ ((id-rdt :accessor id-rdt
+ :documentation "The ID readout")
+
+ (x-tln :accessor x-tln
+ :documentation "The X coordinate textline.")
+
+ (y-tln :accessor y-tln
+ :documentation "The Y coordinate textline.")
+
+ )
+
+ (:default-initargs :height 155)
+
+ (:documentation "The subclass of attribute editor specific to
+points.")
+
+ )
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((ae point-attribute-editor)
+ &rest initargs)
+
+ "Initializes the user interface for the point attribute editor,
+allows the user to interactively modify the point vertex pv's
+attributes, or to displace the mark by a fixed amount in the x & y
+directions."
+
+ (let* ((frm (fr ae))
+ (frm-win (sl:window frm))
+ (obj (object ae))
+ (dx 5)
+ (tlw (- (width ae) (* 2 dx)))
+ (tlh 25)
+ (x-loc (fix-float (x obj) 2))
+ (y-loc (fix-float (y obj) 2))
+ (num-rdt (sl:make-readout tlw tlh :parent frm-win
+ :label "ID: "
+ :ulc-x dx
+ :ulc-y (bp-y dx tlh 2)))
+ (x-tln (sl:make-textline tlw tlh :parent frm-win
+ :label "X loc: "
+ :numeric t
+ :lower-limit -999.9
+ :upper-limit 999.9
+ :ulc-x dx
+ :ulc-y (bp-y dx tlh 3)))
+ (y-tln (sl:make-textline tlw tlh :parent frm-win
+ :label "Y loc: "
+ :numeric t
+ :lower-limit -999.9
+ :upper-limit 999.9
+ :ulc-x dx
+ :ulc-y (bp-y dx tlh 4)))
+ )
+ (setf (sl:info num-rdt) (id obj))
+ (setf (sl:info x-tln) x-loc)
+ (setf (sl:info y-tln) y-loc)
+ (setf (id-rdt ae) num-rdt
+ (x-tln ae) x-tln
+ (y-tln ae) y-tln)
+ (ev:add-notify ae (sl:new-info x-tln)
+ #'(lambda (aed tln info)
+ (declare (ignore tln))
+ (setf (x (object aed))
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify ae (sl:new-info y-tln)
+ #'(lambda (aed tln info)
+ (declare (ignore tln))
+ (setf (y (object aed))
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify ae (new-loc obj)
+ #'(lambda (aed pt loc)
+ (declare (ignore pt))
+ (setf (sl:info (x-tln aed)) (first loc)
+ (sl:info (y-tln aed)) (second loc))))
+ ))
+
+;;;-----------------------------------
+
+(defmethod make-attribute-editor ((pt mark) &rest initargs)
+
+ "make-attribute-editor (pt mark) &rest initargs
+
+Returns a point attribute-editor with specified parameters."
+
+ (apply #'make-instance 'point-attribute-editor
+ :object pt :allow-other-keys t
+ initargs))
+
+;;;-----------------------------------
+
+(defmethod destroy :before ((ae point-attribute-editor))
+
+ "Releases additional X resources used by this panel."
+
+ (sl:destroy (x-tln ae))
+ (sl:destroy (y-tln ae))
+ (sl:destroy (id-rdt ae))
+ ;; remove-notify for above add-notify on point since it persists
+ (ev:remove-notify ae (new-loc (object ae))))
+
+;;;-----------------------------------
+;;; End.
diff --git a/prism/src/auto-extend-panels.cl b/prism/src/auto-extend-panels.cl
new file mode 100644
index 0000000..69d9ec8
--- /dev/null
+++ b/prism/src/auto-extend-panels.cl
@@ -0,0 +1,271 @@
+;;;
+;;; auto-extend-panels
+;;;
+;;; the little panel that sets the parameters for the extended
+;;; autocontour functions in autovolume
+;;;
+;;; 22-Feb-2004 I. Kalet split off from volume-editor module
+;;; 22-Apr-2004 I. Kalet mods to eliminate circular dependencies
+;;; 17-May-2004 I. Kalet further fixes to allow direct update of filmstrip
+;;; 18-Jun-2009 I. Kalet mods to simplify interface with parent volume
+;;; editor panel and autovolume functions.
+;;; 17-Jul-2011 I. Kalet add missing pe arg to generate-internal call,
+;;; must have been dropped in the reorg.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------
+
+(defclass auto-extend-panel ()
+
+ ((volume-editor :accessor volume-editor
+ :initarg :volume-editor
+ :documentation "The volume editor in which this
+ subpanel appears")
+
+ (ulc-x :accessor ulc-x
+ :initarg :ulc-x
+ :documentation "The upper left corner x coordinate of this
+ window in its parent.")
+
+ (ucl-y :accessor ulc-y
+ :initarg :ulc-y
+ :documentation "The upper left corner y coordinate of this
+ window in its parent.")
+
+ (zplus :accessor zplus
+ :documentation "Z+")
+
+ (zminus :accessor zminus
+ :documentation "Z-")
+
+ (mode :accessor mode
+ :initform :replace
+ :documentation "Mode for handling existing contour: a keyword
+symbol, one of :replace, :stop, :skip, :use")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame for this subpanel.")
+
+ (zplus-tln :accessor zplus-tln
+ :documentation "The textline for entering the max z value.")
+
+ (zminus-tln :accessor zminus-tln
+ :documentation "The textline for entering the min z value.")
+
+ (mode-btn :accessor mode-btn
+ :documentation "The button that pops up the menu for the
+mode to handle existing contours when encountered.")
+
+ (clear-btn :accessor clear-btn
+ :documentation "The button that removes the generated
+contours to try again.")
+
+ (extern-btn :accessor extern-btn
+ :documentation "The button that toggles the type of
+ object being contoured, either skin or other.")
+
+ )
+
+ )
+
+;;;----------------------------------
+
+(defun make-auto-extend-panel (vol-ed ulc-x ulc-y)
+
+ (make-instance 'auto-extend-panel
+ :volume-editor vol-ed :ulc-x ulc-x :ulc-y ulc-y))
+
+;;;----------------------------------
+
+(defmethod initialize-instance :after ((pan auto-extend-panel)
+ &rest initargs)
+
+ (let* ((images (images (volume-editor pan)))
+ (btw 150)
+ (bth 25)
+ (frm (sl:make-frame btw (* 3 (+ bth 5))
+ :parent (sl:window (fr (volume-editor pan)))
+ :border-width 0
+ :ulc-x (ulc-x pan)
+ :ulc-y (ulc-y pan)))
+ (frm-win (sl:window frm))
+ (smf (symbol-value *small-font*)) ;; the value, not the symbol
+ (zp-tln (apply #'sl:make-textline (- (/ btw 2) 3) bth
+ :parent frm-win :font smf
+ :ulc-x (+ (/ btw 2) 2) :ulc-y 0
+ :label "Z+ "
+ :numeric t
+ :lower-limit (min-image-z-coord images)
+ :upper-limit (max-image-z-coord images)
+ initargs))
+ (zm-tln (apply #'sl:make-textline (- (/ btw 2) 2) bth
+ :parent frm-win :font smf
+ :ulc-x 0 :ulc-y 0
+ :label "Z- "
+ :numeric t
+ :lower-limit (min-image-z-coord images)
+ :upper-limit (max-image-z-coord images)
+ initargs))
+ (mode-b (apply #'sl:make-button btw bth
+ :parent frm-win :font smf
+ :ulc-x 0 :ulc-y (bp-y 0 bth 1)
+ :label "Mode: Replace"
+ initargs))
+ (clr-b (apply #'sl:make-button (- (/ btw 2) 3) bth
+ :parent frm-win :font smf
+ :ulc-x 0 :ulc-y (bp-y 0 bth 2)
+ :label "Clear" :button-type :momentary
+ initargs))
+ (ext-b (apply #'sl:make-button (- (/ btw 2) 2) bth
+ :parent frm-win :font smf
+ :ulc-x (+ (/ btw 2) 2) :ulc-y (bp-y 0 bth 2)
+ :label "External" :button-type :hold
+ initargs))
+ )
+ (setf (panel-frame pan) frm
+ (zplus-tln pan) zp-tln
+ (zminus-tln pan) zm-tln
+ (mode-btn pan) mode-b
+ (clear-btn pan) clr-b
+ (extern-btn pan) ext-b)
+ (setf (sl:info zp-tln) (max-image-z-coord images)
+ (sl:info zm-tln) (min-image-z-coord images)
+ (zplus pan) (max-image-z-coord images)
+ (zminus pan) (min-image-z-coord images))
+ ;; Add events to allow adjustment of characteristics.
+ ;; and reaction to users. The changing state of buttons and
+ ;; boxes serves two functions: firstly, they allow the user to
+ ;; see what options are chosen, and the panel is passed to
+ ;; the contour-extending routine and used to determine
+ ;; which processes are used for autocontouring.
+ ;; The external contour button can switch back and forth between
+ ;; three modes: "External", "Vertebrae", and "Internal" These modes
+ ;; all use roughly the same code, but with slightly different inputs
+ ;; and paramaters in places.
+ (ev:add-notify pan (sl:new-info zp-tln)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (zplus pnl) (read-from-string info))))
+ (ev:add-notify pan (sl:new-info zm-tln)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (zminus pnl) (read-from-string info))))
+ (ev:add-notify pan (sl:button-on ext-b)
+ #'(lambda (pnl bt)
+ (declare (ignore pnl))
+ (let ((selection (sl:popup-menu '("External"
+ "Inner Organs"
+ "Vertebrae" ))))
+ (when selection
+ (setf (sl:label bt)
+ (case selection
+ (0 "External")
+ (1 "Inner Organs")
+ (2 "Vertebrae")))))
+ (setf (sl:on bt) nil)))
+ ;;the 'clear' button clears ALL contours for the current organ.
+ ;;in case the user wishes to auto-generate the entire group.
+ (ev:add-notify pan (sl:button-on clr-b)
+ #'(lambda (pnl bt)
+ (if (sl:confirm
+ (list
+ "Are you sure you want to clear"
+ (format nil "all contours associated with ~A?"
+ (name (volume (volume-editor pnl))))))
+ ;; delete each contour, and then each
+ ;; filmstrip contour. pstruct updated.
+ (dolist (cont (contours
+ (volume (volume-editor pnl))))
+ (fs-delete-contour (volume (volume-editor pnl))
+ (z cont)
+ (fs (volume-editor pnl)))
+ (setf (contours (volume (volume-editor pnl)))
+ (remove cont
+ (contours (volume
+ (volume-editor pnl)))))
+ (update-pstruct (volume (volume-editor pnl))
+ nil
+ (z cont))))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify pan (sl:button-on mode-b)
+ #'(lambda (pnl bt)
+ (declare (ignore pnl))
+ (let ((selection (sl:popup-menu
+ '("Replace" "Stop" "Use" "Ignore"))))
+ (when selection
+ (setf (sl:label bt)
+ (case selection
+ (0 "Mode: Replace")
+ (1 "Mode: Stop")
+ (2 "Mode: Use")
+ (3 "Mode: Ignore")))))
+ (setf (sl:on bt) nil))))
+ nil)
+
+;;;----------------------------------
+
+(defmethod destroy ((pan auto-extend-panel))
+
+ (sl:destroy (zplus-tln pan))
+ (sl:destroy (zminus-tln pan))
+ (sl:destroy (mode-btn pan))
+ (sl:destroy (clear-btn pan))
+ (sl:destroy (extern-btn pan))
+ (sl:destroy (panel-frame pan)))
+
+;;;----------------------------------
+
+(defun generate-extended-contours (pan new-verts)
+
+ "generate-extended-contours pan new-verts
+
+Based on user button selection in the auto-extend-panel, selects
+and calls the appropriate contour extension routine (external, vertebral,
+internal)."
+
+ (let ((min (zminus pan))
+ (max (zplus pan))
+ (mode (sl:label (extern-btn pan)))
+ (ve (volume-editor pan)))
+ (cond ((equal mode "External")
+ (generate-externals (window ve) (level ve) (fs ve)
+ (volume ve) (images ve)
+ min max))
+ ((equal mode "Vertebrae")
+ (generate-vertebrae (window ve) (level ve) (fs ve)
+ (volume ve) (images ve)
+ min max))
+ (t (generate-internal (window ve) (level ve) (z ve) (fs ve)
+ (pe ve) (volume ve) (images ve)
+ min max new-verts)))))
+
+;;;----------------------------------
+
+(defun max-image-z-coord (images)
+
+ "max-image-z-coord images
+
+Returns the z-coordinate of the image with the largest one."
+
+ (let ((max 0))
+ (dolist (img images max)
+ (if (> (elt (origin img) 2) max)
+ (setq max (elt (origin img) 2))))))
+
+;;;----------------------------------
+
+(defun min-image-z-coord (images)
+
+ "min-image-z-coord images
+
+Returns the z-coordinate of the image with the smallest z coordinate."
+
+ (let ((min 100))
+ (dolist (img images min)
+ (if (< (elt (origin img) 2) min)
+ (setq min (elt (origin img) 2))))))
+
+;;;----------------------------------
+;;; End.
diff --git a/prism/src/auto-extend-panels.cl~ b/prism/src/auto-extend-panels.cl~
new file mode 100644
index 0000000..bfb9dcf
--- /dev/null
+++ b/prism/src/auto-extend-panels.cl~
@@ -0,0 +1,269 @@
+;;;
+;;; auto-extend-panels
+;;;
+;;; the little panel that sets the parameters for the extended
+;;; autocontour functions in autovolume
+;;;
+;;; 22-Feb-2004 I. Kalet split off from volume-editor module
+;;; 22-Apr-2004 I. Kalet mods to eliminate circular dependencies
+;;; 17-May-2004 I. Kalet further fixes to allow direct update of filmstrip
+;;; 18-Jun-2009 I. Kalet mods to simplify interface with parent volume
+;;; editor panel and autovolume functions.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------
+
+(defclass auto-extend-panel ()
+
+ ((volume-editor :accessor volume-editor
+ :initarg :volume-editor
+ :documentation "The volume editor in which this
+ subpanel appears")
+
+ (ulc-x :accessor ulc-x
+ :initarg :ulc-x
+ :documentation "The upper left corner x coordinate of this
+ window in its parent.")
+
+ (ucl-y :accessor ulc-y
+ :initarg :ulc-y
+ :documentation "The upper left corner y coordinate of this
+ window in its parent.")
+
+ (zplus :accessor zplus
+ :documentation "Z+")
+
+ (zminus :accessor zminus
+ :documentation "Z-")
+
+ (mode :accessor mode
+ :initform :replace
+ :documentation "Mode for handling existing contour: a keyword
+symbol, one of :replace, :stop, :skip, :use")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame for this subpanel.")
+
+ (zplus-tln :accessor zplus-tln
+ :documentation "The textline for entering the max z value.")
+
+ (zminus-tln :accessor zminus-tln
+ :documentation "The textline for entering the min z value.")
+
+ (mode-btn :accessor mode-btn
+ :documentation "The button that pops up the menu for the
+mode to handle existing contours when encountered.")
+
+ (clear-btn :accessor clear-btn
+ :documentation "The button that removes the generated
+contours to try again.")
+
+ (extern-btn :accessor extern-btn
+ :documentation "The button that toggles the type of
+ object being contoured, either skin or other.")
+
+ )
+
+ )
+
+;;;----------------------------------
+
+(defun make-auto-extend-panel (vol-ed ulc-x ulc-y)
+
+ (make-instance 'auto-extend-panel
+ :volume-editor vol-ed :ulc-x ulc-x :ulc-y ulc-y))
+
+;;;----------------------------------
+
+(defmethod initialize-instance :after ((pan auto-extend-panel)
+ &rest initargs)
+
+ (let* ((images (images (volume-editor pan)))
+ (btw 150)
+ (bth 25)
+ (frm (sl:make-frame btw (* 3 (+ bth 5))
+ :parent (sl:window (fr (volume-editor pan)))
+ :border-width 0
+ :ulc-x (ulc-x pan)
+ :ulc-y (ulc-y pan)))
+ (frm-win (sl:window frm))
+ (smf (symbol-value *small-font*)) ;; the value, not the symbol
+ (zp-tln (apply #'sl:make-textline (- (/ btw 2) 3) bth
+ :parent frm-win :font smf
+ :ulc-x (+ (/ btw 2) 2) :ulc-y 0
+ :label "Z+ "
+ :numeric t
+ :lower-limit (min-image-z-coord images)
+ :upper-limit (max-image-z-coord images)
+ initargs))
+ (zm-tln (apply #'sl:make-textline (- (/ btw 2) 2) bth
+ :parent frm-win :font smf
+ :ulc-x 0 :ulc-y 0
+ :label "Z- "
+ :numeric t
+ :lower-limit (min-image-z-coord images)
+ :upper-limit (max-image-z-coord images)
+ initargs))
+ (mode-b (apply #'sl:make-button btw bth
+ :parent frm-win :font smf
+ :ulc-x 0 :ulc-y (bp-y 0 bth 1)
+ :label "Mode: Replace"
+ initargs))
+ (clr-b (apply #'sl:make-button (- (/ btw 2) 3) bth
+ :parent frm-win :font smf
+ :ulc-x 0 :ulc-y (bp-y 0 bth 2)
+ :label "Clear" :button-type :momentary
+ initargs))
+ (ext-b (apply #'sl:make-button (- (/ btw 2) 2) bth
+ :parent frm-win :font smf
+ :ulc-x (+ (/ btw 2) 2) :ulc-y (bp-y 0 bth 2)
+ :label "External" :button-type :hold
+ initargs))
+ )
+ (setf (panel-frame pan) frm
+ (zplus-tln pan) zp-tln
+ (zminus-tln pan) zm-tln
+ (mode-btn pan) mode-b
+ (clear-btn pan) clr-b
+ (extern-btn pan) ext-b)
+ (setf (sl:info zp-tln) (max-image-z-coord images)
+ (sl:info zm-tln) (min-image-z-coord images)
+ (zplus pan) (max-image-z-coord images)
+ (zminus pan) (min-image-z-coord images))
+ ;; Add events to allow adjustment of characteristics.
+ ;; and reaction to users. The changing state of buttons and
+ ;; boxes serves two functions: firstly, they allow the user to
+ ;; see what options are chosen, and the panel is passed to
+ ;; the contour-extending routine and used to determine
+ ;; which processes are used for autocontouring.
+ ;; The external contour button can switch back and forth between
+ ;; three modes: "External", "Vertebrae", and "Internal" These modes
+ ;; all use roughly the same code, but with slightly different inputs
+ ;; and paramaters in places.
+ (ev:add-notify pan (sl:new-info zp-tln)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (zplus pnl) (read-from-string info))))
+ (ev:add-notify pan (sl:new-info zm-tln)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (zminus pnl) (read-from-string info))))
+ (ev:add-notify pan (sl:button-on ext-b)
+ #'(lambda (pnl bt)
+ (declare (ignore pnl))
+ (let ((selection (sl:popup-menu '("External"
+ "Inner Organs"
+ "Vertebrae" ))))
+ (when selection
+ (setf (sl:label bt)
+ (case selection
+ (0 "External")
+ (1 "Inner Organs")
+ (2 "Vertebrae")))))
+ (setf (sl:on bt) nil)))
+ ;;the 'clear' button clears ALL contours for the current organ.
+ ;;in case the user wishes to auto-generate the entire group.
+ (ev:add-notify pan (sl:button-on clr-b)
+ #'(lambda (pnl bt)
+ (if (sl:confirm
+ (list
+ "Are you sure you want to clear"
+ (format nil "all contours associated with ~A?"
+ (name (volume (volume-editor pnl))))))
+ ;; delete each contour, and then each
+ ;; filmstrip contour. pstruct updated.
+ (dolist (cont (contours
+ (volume (volume-editor pnl))))
+ (fs-delete-contour (volume (volume-editor pnl))
+ (z cont)
+ (fs (volume-editor pnl)))
+ (setf (contours (volume (volume-editor pnl)))
+ (remove cont
+ (contours (volume
+ (volume-editor pnl)))))
+ (update-pstruct (volume (volume-editor pnl))
+ nil
+ (z cont))))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify pan (sl:button-on mode-b)
+ #'(lambda (pnl bt)
+ (declare (ignore pnl))
+ (let ((selection (sl:popup-menu
+ '("Replace" "Stop" "Use" "Ignore"))))
+ (when selection
+ (setf (sl:label bt)
+ (case selection
+ (0 "Mode: Replace")
+ (1 "Mode: Stop")
+ (2 "Mode: Use")
+ (3 "Mode: Ignore")))))
+ (setf (sl:on bt) nil))))
+ nil)
+
+;;;----------------------------------
+
+(defmethod destroy ((pan auto-extend-panel))
+
+ (sl:destroy (zplus-tln pan))
+ (sl:destroy (zminus-tln pan))
+ (sl:destroy (mode-btn pan))
+ (sl:destroy (clear-btn pan))
+ (sl:destroy (extern-btn pan))
+ (sl:destroy (panel-frame pan)))
+
+;;;----------------------------------
+
+(defun generate-extended-contours (pan new-verts)
+
+ "generate-extended-contours pan new-verts
+
+Based on user button selection in the auto-extend-panel, selects
+and calls the appropriate contour extension routine (external, vertebral,
+internal)."
+
+ (let ((min (zminus pan))
+ (max (zplus pan))
+ (mode (sl:label (extern-btn pan)))
+ (ve (volume-editor pan)))
+ (cond ((equal mode "External")
+ (generate-externals (window ve) (level ve) (fs ve)
+ (volume ve) (images ve)
+ min max))
+ ((equal mode "Vertebrae")
+ (generate-vertebrae (window ve) (level ve) (fs ve)
+ (volume ve) (images ve)
+ min max))
+ (t (generate-internal (window ve) (level ve) (z ve) (fs ve)
+ (volume ve) (images ve)
+ min max new-verts)))))
+
+;;;----------------------------------
+
+(defun max-image-z-coord (images)
+
+ "max-image-z-coord images
+
+Returns the z-coordinate of the image with the largest one."
+
+ (let ((max 0))
+ (dolist (img images max)
+ (if (> (elt (origin img) 2) max)
+ (setq max (elt (origin img) 2))))))
+
+;;;----------------------------------
+
+(defun min-image-z-coord (images)
+
+ "min-image-z-coord images
+
+Returns the z-coordinate of the image with the smallest z coordinate."
+
+ (let ((min 100))
+ (dolist (img images min)
+ (if (< (elt (origin img) 2) min)
+ (setq min (elt (origin img) 2))))))
+
+;;;----------------------------------
+;;; End.
diff --git a/prism/src/autocontour.cl b/prism/src/autocontour.cl
new file mode 100644
index 0000000..a02f554
--- /dev/null
+++ b/prism/src/autocontour.cl
@@ -0,0 +1,401 @@
+;;;
+;;; autocontour
+;;;
+;;; Routines to do an automatic contouring of a set of image data and
+;;; to reduce the number of vertices in a generated contour to a more
+;;; manageable level.
+;;;
+;;; The basic routines here (except reduce-contour) are closely
+;;; translated from the file autocontour.pas, the pascal source, from
+;;; UWPLAN. The reduce-contour code is largely re-implemented
+;;; directly from the article, referenced below.
+;;;
+;;; The sources referenced in the pascal source are as follows:
+;;;
+;;; reduce-contour - Ramer, Urs. An iterative procedure for the
+;;; polygonal approximation of plane curves.
+;;; Computer Graphics and Image processing (1),
+;;; pp 244-256, 1972.
+;;; follow-contour - David W. Brumberg, program 'traceborders',
+;;; UW Computer Science Lab, Sept 1980.
+;;;
+;;; 19-Apr-1993 J. Unger do initial translation.
+;;; 28-May-1993 J. Unger minor fix to elim some compiler msgs.
+;;; 12-May-1994 I. Kalet uncomment code to search for gradient from
+;;; starting point. Also, check for nil contour in reduce-contour
+;;; 28-Jul-1994 J. Unger add some optimization & remove debugging
+;;; stmts.
+;;; 8-Jan-1995 I. Kalet remove proclaim form and extra right paren.
+;;; Nov-1999 J. Zeman add untangle-contour routine
+;;; 12-Dec-1999 J. Zeman remove count from autocontour, allowing contours
+;;; of any number of points.
+;;; 11-Apr-2000 I. Kalet merge back into Prism without using new
+;;; routines.
+;;; 20-Jul-2000 J. Zeman add code to detect whether follow-borders is "stuck"
+;;; and return completed border if so.
+;;; 1-Jan-2009 I. Kalet change declaration of image in follow-border
+;;; to unsigned-byte 8 because we are using mapped images, not raw images.
+;;;
+
+(in-package :prism)
+
+;;;-----------------------------------
+
+(defun rc-distance (p q sin-angle cos-angle tan-angle steep vertical)
+
+ "rc-distance p q sin-angle cos-angle tan-angle steep vertical
+
+Returns the distance of p from the line segment determined by pj
+and pk in the function reduce-contour. The other parameters are
+computed there and passed here to avoid recomputation."
+
+ (let ((rise (- (second q) (second p)))
+ (run (- (first q) (first p))))
+ (if vertical (abs run)
+ (if steep
+ (round (abs (* sin-angle (- run (/ rise tan-angle)))))
+ (round (abs (* cos-angle (- rise (* run tan-angle)))))))))
+
+;;;-----------------------------------
+
+(defun reduce-contour (vertices tolerance)
+
+ "reduce-contour vertices tolerance
+
+Given vertices, a list of (x y) pairs, and tolerance, a maximum
+distance criterion, reduce-contour computes and returns a second list
+of vertices which contains a subset of the points of vertices but
+which closely approximates the contour represented by vertices.
+Tolerance represents the maximum distance of the input contour from
+the output contour - if 0, only redundant collinear points are
+removed. Reference: Urs Ramer, An Iterative Procedure for the
+Polygonal Approximation of Plane Curves, Computer Graphics and Image
+Processing 1, p 244-256, 1972."
+
+ ;; See the reference for a description of the algorithm. We store
+ ;; pointers to sublists of the vertices list on the open-verts and
+ ;; closed-verts list, so that we can recover the contiguous runs of
+ ;; vertices to traverse when making the maximum distance determination
+ ;; for subsets of vertices.
+
+ (if vertices ;; don't attempt to reduce an empty list!
+ (let ((closed-verts nil)
+ (open-verts nil))
+
+ (push vertices closed-verts)
+ (push (last vertices) open-verts)
+
+ ;; loop until open-verts list is empty - return the first elt
+ ;; of each member of closed-verts when done
+ (do ((pj (first (first open-verts)) (first (first open-verts)))
+ (pk (first (first closed-verts)) (first (first closed-verts)))
+ (angle 0.0 0.0)
+ (sin-angle 0.0 0.0)
+ (cos-angle 0.0 0.0)
+ (tan-angle 0.0 0.0)
+ (vertical nil nil)
+ (steep nil nil)
+ (max-dist 0.0 0.0)
+ (max-ptr (first closed-verts) (first closed-verts)))
+ ((null open-verts) (mapcar #'first (reverse closed-verts)))
+
+ (if (= (first pj) (first pk))
+ (setq vertical t)
+ (progn
+ (setq vertical nil)
+ (setq tan-angle (float (/ (- (second pj) (second pk))
+ (- (first pj) (first pk)))))
+ (setq angle (atan tan-angle))
+ (setq sin-angle (sin angle))
+ (setq cos-angle (cos angle))
+ (when (> (abs tan-angle) 1.0)
+ (setq steep t))))
+
+ ;; find the point (p) in this subset of vertices which is
+ ;; furthest from the line determined by pj & pk
+ (do* ((vert-ptr (first closed-verts) (rest vert-ptr))
+ (p (first vert-ptr) (first vert-ptr))
+ (cur-dist 0.0))
+ ((eq vert-ptr (first open-verts)))
+ (setq cur-dist
+ (rc-distance p pk sin-angle cos-angle tan-angle
+ steep vertical))
+ (when (> cur-dist max-dist)
+ (setf max-dist cur-dist)
+ (setf max-ptr vert-ptr)))
+
+ ;; if the max dist is greater than tolerance, push the
+ ;; vertex at this distance onto the open verts list -
+ ;; otherwise, take the last vertex off the open list and put
+ ;; it on the closed list
+ (if (> max-dist tolerance)
+ (push max-ptr open-verts)
+ (push (pop open-verts) closed-verts)))
+ )))
+
+;;;-----------------------------------
+
+(defun follow-border (image xbegin ybegin x1 y1 x2 y2 threshold)
+
+ "follow-border image xbegin ybegin x1 y1 x2 y2 threshold
+
+Follows the isovalue border at the threshold value in image, starting
+from the point (xbegin,ybegin), bounded by the region determined by
+the points (x1,y1) and (x2,y2), and returns the extracted contour."
+
+ (let ((x xbegin)
+ (y ybegin)
+ (result-list nil))
+
+ (declare (fixnum x y xbegin ybegin x1 y1 x2 y2 threshold))
+ (declare (type (simple-array (unsigned-byte 8) 2) image))
+
+ ;; first, search image for the contour
+ (do ((ytop (1- y2))
+ (xtop (1- x2)))
+ ((or (= y ytop) (>= (aref image y x) threshold)))
+ (do ()
+ ((or (= x xtop) (>= (aref image y x) threshold)))
+ (declare (fixnum xtop ytop))
+ (incf x))
+ (when (= x xtop)
+ (incf y)
+ (setq x x1)))
+
+ (when (>= (aref image y x) threshold) ;; must have found contour so follow
+ (let* ((x-border x)
+ (y-border y)
+ (new-thresh (1- (aref image y-border x-border)))
+ (mode :south)
+ (start t)
+ (last-south '(-1 -1)))
+ (declare (fixnum x-border y-border new-thresh))
+ (loop
+ (when (or (/= x x-border)
+ (/= y y-border)) ; (not (equal mode :south))
+ (setq start nil))
+ (case mode
+ (:south
+ ;;check for an infinite loop here.
+ (if (equal (list x y) last-south)
+ (progn ;;(format t "~%Error: Contour stuck. Please Redraw.~%")
+ (return-from follow-border result-list)))
+ (setf last-south (list x y))
+ (setq mode :east)
+ (if (> x x1)
+ (if (> y y1)
+ (cond
+ ((> (aref image (1- y) (1- x)) new-thresh)
+ (setq x (1- x)
+ y (1- y)
+ mode :west))
+ ((> (aref image (1- y) x) new-thresh)
+ (setq y (1- y)
+ mode :south))))
+ (if (> y y1)
+ (cond
+ ((> (aref image (1- y) x) new-thresh)
+ (setq y (1- y)
+ mode :south))))))
+ (:east
+ (setq mode :north)
+ (if (> y y1)
+ (if (< x x2)
+ (cond
+ ((> (aref image (1- y) (1+ x)) new-thresh)
+ (setq x (1+ x)
+ y (1- y)
+ mode :south))
+ ((> (aref image y (1+ x)) new-thresh)
+ (setq x (1+ x)
+ mode :east))))
+ (if (< x x2)
+ (cond
+ ((> (aref image y (1+ x)) new-thresh)
+ (setq x (1+ x)
+ mode :east))))))
+ (:north
+ (setq mode :west)
+ (if (< x x2)
+ (if (< y y2)
+ (cond
+ ((> (aref image (1+ y) (1+ x)) new-thresh)
+ (setq x (1+ x)
+ y (1+ y)
+ mode :east))
+ ((> (aref image (1+ y) x) new-thresh)
+ (setq y (1+ y)
+ mode :north))))
+ (if (< y y2)
+ (cond
+ ((> (aref image (1+ y) x) new-thresh)
+ (setq y (1+ y)
+ mode :north))))))
+ (:west
+ (setq mode :south)
+ (if (< y y2)
+ (if (> x x1)
+ (cond
+ ((> (aref image (1+ y) (1- x)) new-thresh)
+ (setq x (1- x)
+ y (1+ y)
+ mode :north))
+ ((> (aref image y (1- x)) new-thresh)
+ (setq x (1- x)
+ mode :west))))
+ (if (> x x1)
+ (cond
+ ((> (aref image y (1- x)) new-thresh)
+ (setq x (1- x)
+ mode :west)))))))
+ (push (list x y) result-list)
+ (when (and (not start) (= x x-border) (= y y-border))
+ (return)))))
+ result-list))
+
+;;;-----------------------------------
+
+(defvar *use-untangle* nil)
+
+;;;-----------------------------------
+
+(defun autocontour (image xbegin ybegin x1 y1 x2 y2 tolerance)
+
+ "autocontour image xbegin ybegin x1 y1 x2 y2 tolerance
+
+Automatically extracts a contour from image, given a starting point
+xbegin,ybegin on the contour, bounded by the region determined by
+points x1,y1 and x2,y2. First, extracts the contour from the
+image by calling follow-border, and then eliminates extra vertices
+from the contour by calling reduce-contour, with the supplied
+tolerance, and returns this reduced contour."
+
+ (when (and (>= ybegin y1) (< ybegin y2)
+ (>= xbegin x1) (< xbegin x2))
+ (let* ((threshold (1+ (aref image ybegin xbegin)))
+ (temp-contour (follow-border image xbegin ybegin
+ x1 y1 x2 y2 threshold)))
+ (reduce-contour (if *use-untangle*
+ (untangle-contour temp-contour)
+ temp-contour)
+ tolerance))))
+
+;;;----------------------------------
+
+(defun untangle-contour (verts)
+
+ "untangle-contour verts
+
+given vertices, returns a contour in which no point appears
+more than once. Note: this function can be used on a list of
+any sort comparable by #'equal. It will return a list with no
+repetitions, and with values between repetitions removed.
+[1 2 3 4 2 5 6] -> [1 2 5 6]"
+
+ ;;take care of lists with identical first and last verticies
+ (when (equal (first verts) (first(last verts)))
+ (pop verts))
+ (let* ((final nil)
+ (remaining verts)
+ (next-loc 0)
+ (point (first remaining)))
+ (loop until (null remaining)
+ do
+ (setf point (first remaining))
+ (setf final (append final (list (pop remaining))))
+ ;;(format t "~% position: ~%")
+ ;;(time
+ (setf next-loc (position point remaining :test #'equal
+ :from-end t))
+ ;; )
+ ;;(format t "~% defined: ~%")
+ ;;(time
+ ;; (setf next-loc (find-point-in-contour point remaining))
+ ;; )
+ (when next-loc
+ ;;(format t "found ")
+ (setf remaining (subseq remaining (+ 1 next-loc))))
+ )
+ (return-from untangle-contour final)))
+
+;;;---------------------------------
+
+;;this is so much slower than 'equal' that i believe equal works
+;;the same way, and does a better job of it. not using this function
+;;left for debug purposes, but will definitely be removed for final
+;;version.
+
+(defun faster-point-compare (p1 p2)
+
+ "faster-point-compare p1 p2
+
+a quicker way than equal to compare points: checks first
+coordinate. only checks second if first the same. uses eq.
+designed to minimize number of operations on the most common
+case: two points not at all similar."
+
+ (when (not (eq (first p1) (first p2)))
+ (return-from faster-point-compare nil))
+ (return-from faster-point-compare
+ (not (eq (second p1) (second p2)))))
+
+;;;--------------------------------
+
+(defun find-point-in-contour (pt lst)
+
+ "find-point-in-contour pt lst
+
+a quick way to find the point pt, which is known to
+occur in lst. lst represents an unreduced contour: that is,
+points vary by at most one unit x or y from eachother.
+this function written to be faster than 'find' in a very
+specialized case, and takes advantages of known contour
+properties. results are not determined for non-autocontour
+generated point lists."
+
+ ;;30 list items are checked at a time, by seeing how close
+ ;;the number of every 30th item is to the sought-after point,
+ ;;assuming individual points differ by at most one pixel, which is
+ ;;the case for autocontour-generated points.
+
+ ;;special provision for lists of less than 30 length
+ (when (< (length lst) 30)
+ (return-from find-point-in-contour
+ (position pt lst :test #'equal :from-end t)))
+ (let*
+ ((x (first pt))
+ (y (second pt))
+ (length (- (length lst) 1))
+ (pos (- length 15))
+ (distance 0)
+ (found nil)
+ (finished nil))
+ ;;backward search for reoccurance of point.
+ (loop
+ while(not finished)
+ do
+ ;;(format t "in loop")
+ (setf distance (abs (- x (first (elt lst pos)))))
+ (incf distance (abs (- y (second (elt lst pos)))))
+ (when (>= distance 15)
+ ;;(format t "zooming in")
+ ;;have found an area possibly containing the point in question.
+ ;;check in more detail.
+ (setf found (position (list x y) lst
+ :start (- pos 15) :end (+ pos 15)
+ :test #'equal :from-end t))
+ (when found
+ ;;(format t "non dead end* ")
+ (return-from find-point-in-contour found)))
+ ;;(format t "pos = ~A" pos)
+ (setf pos (- pos 15))
+ (when (> 30 pos)
+ ;;just use position on last piece. it has to be in here,
+ ;;due to the circumstances under which this function is
+ ;;called.
+ (return-from find-point-in-contour
+ (position pt lst :end (+ pos 15) :test #'equal
+ :from-end t))))))
+
+;;;-------------------------------------
+;;; End.
diff --git a/prism/src/autovolume.cl b/prism/src/autovolume.cl
new file mode 100644
index 0000000..7ba4e2e
--- /dev/null
+++ b/prism/src/autovolume.cl
@@ -0,0 +1,339 @@
+;;;
+;;; autovolume
+;;;
+;;; Lee Zeman's code to extend the volume editor to do a whole
+;;; collection of contours at one mouse click.
+;;;
+;;; 11-Apr-2000 I. Kalet created from Lee Zeman's version of the
+;;; volume-editor module.
+;;; 11-May-2000 I. Kalet ongoing re-engineering
+;;; 30-Jun-2000 L. Zeman begins to reorganize into more efficient and
+;;; accurate functions. Creates generate-externals.
+;;; 10-Jul-2000 L. Zeman finish generate-*-start functions for more accurate
+;;; contouring.
+;;; 12-Jul-2000 L. Zeman removes minor bug from generate-vertebrae and set
+;;; thresh to return nil if threshing impossible with the given criteria.
+;;; 20-Jul-2000 L. Zeman removes extend-contour-v and extend-contour-h
+;;; routines.
+;;; 25-Jul-2000 L. Zeman removes start-vert-cont and debug clauses,
+;;; adding extentions.
+;;; 7-Sep-2000 L. Zeman finishes testing, removes debugging code, better
+;;; documentation.
+;;; 17-Dec-2000 I. Kalet cosmetic cleanup, pass volume as parameter to
+;;; remove circular dependency with volume editor.
+;;; 1-May-2004 I. Kalet reorganize to eliminate remaining circular
+;;; dependency with easel code, and other peculiar coding quirks.
+;;; Move update-pstruct here from volume-editor. Also use
+;;; legal-contour with new flag, and remove quiet-legal-contour.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------
+
+(defun update-pstruct (pstr verts z)
+
+ "update-pstruct pstr verts z
+
+Replaces the vertices of the contour in pstruct pstr at the plane
+specified by z with the vertices verts, or adds a new contour to pstr
+if no contour previously existed at the given z plane, or deletes the
+existing contour if an old one exist but verts is nil."
+
+ (let ((temp-con (find z (contours pstr)
+ :key #'z
+ :test #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*)))))
+ (cond
+ ((and temp-con verts) (setf (vertices temp-con) verts))
+ (verts (push (make-contour :z z :vertices verts)
+ (contours pstr)))
+ (temp-con (setf (contours pstr)
+ (remove temp-con (contours pstr))))))
+ (ev:announce pstr (new-contours pstr)) ;; so other stuff can update
+ (ev:announce pstr (update-case pstr))) ;; " "
+
+;;;---------------------------------
+
+(defun generate-externals (window level fs vol images z-min z-max)
+
+ "generate-externals window level fs vol images z-min z-max
+
+Attempts to generate an external contour for each image with a z coordinate
+between z-min and z-max, using an already generated image as a guideline.
+Thresholds at the first break."
+
+ ;; deal with each image in turn
+ (dolist (img images)
+ (let ((z (vz (origin img))))
+ (if (and (>= z z-min) (<= z z-max))
+ (let* ((x-start 0)
+ (y-start (round (/ (array-dimension (pixels img) 0) 2)))
+ (ppcm (pix-per-cm img))
+ (x-orig (round (* -1 ppcm (vx (origin img)))))
+ (y-orig (round (* ppcm (vy (origin img)))))
+ ;; note: removing the -1 factor from the y-term makes
+ ;; this work. not sure why.
+ (mapped (sl:map-raw-image (pixels img) window
+ level (range img)))
+ (size (array-dimension mapped 0))
+ (threshed (thresh mapped size size
+ (/ sl:*num-gray-pixels* 8)
+ sl:*num-gray-pixels*))
+ (new-contour nil))
+ ;; start contour in an alternate location if this one will
+ ;; not work.
+ (if (not (equal (aref threshed x-start y-start) 0))
+ (progn (format t " Generating alternate start")
+ (setf x-start 0 y-start 0)))
+ (format t "~%Now contouring z= ~A" z)
+ (setf new-contour
+ (poly:canonical-contour
+ (mapcar #' (lambda (coord-pair)
+ (list (cm-x (first coord-pair) x-orig ppcm)
+ (cm-y (second coord-pair) y-orig ppcm)))
+ (autocontour threshed x-start y-start 0 0 (1- size)
+ (1- size) *ce-sketch-tolerance*))))
+ (if (legal-contour new-contour t) ;; t for quiet operation
+ (progn
+ ;;add new contours in.
+ (update-pstruct vol new-contour z)
+ (fs-delete-contour vol z fs)
+ (fs-add-contour vol
+ (make-contour :z z
+ :vertices new-contour)
+ fs)))))))
+ ;; announce new volumes, to get things updated.
+ (ev:announce vol (new-contours vol))
+ (ev:announce vol (update-case vol)))
+
+;;;---------------------------------
+
+(defun thresh (image cols rows low hi
+ &optional (check-valid? nil) (valid 255) (invalid 0))
+
+ "thresh image cols rows lo hi check-valid?
+
+Thresholds an image passed to it, setting the values of all pixels
+whose original values fall between low and hi to valid (defaults to 255)
+and all other pixels to invalid (defaults to 0). image is an array of
+greyscale numerical values, cols * rows in size. if check-valid? is true,
+thresh will return nil if the threshed image contains no positive pixels."
+
+ (let ((empty t)
+ (final (make-array (list cols rows) :element-type 'number
+ :initial-element invalid)))
+ (dotimes (i cols)
+ (dotimes (j rows)
+ (if (and (>= (aref image i j) low)
+ (<= (aref image i j) hi))
+ (progn (setf empty nil)
+ (setf (aref final i j) valid)))))
+ (if (and check-valid? empty) nil final)))
+
+;;;----------------------------------
+
+(defun generate-vertebrae (window level fs vol images z-min z-max)
+
+ "generate-vertebrae window level fs vol images z-min z-max
+
+Attempts to generate a vertebral contour for each image with a z coordinate
+between z-min and z-max, using an already generated image as a guideline.
+Thresholds at the last break."
+
+ ;; deal with each image in turn
+ (dolist (img images)
+ (let ((z (vz (origin img))))
+ (if (and (>= z z-min) (<= z z-max))
+ (let* ;; set variables relevant to this image
+ ((new-contour nil)
+ (ppcm (pix-per-cm img))
+ (x-orig (round (* -1 ppcm (vx (origin img)))))
+ (y-orig (round (* ppcm (vy (origin img)))))
+ ;; note: removing -1 factor from the y-term makes this work.
+ (mapped (sl:map-raw-image (pixels img) window
+ level (range img)))
+ (size (array-dimension mapped 0))
+ (threshed (thresh mapped size size
+ (* (/ sl:*num-gray-pixels* 8) 7)
+ sl:*num-gray-pixels* t))
+ (x-start (round (/ size 3)))
+ (y-start (round (/ size 4)))
+ )
+ (format t "~%Now contouring z= ~A" z)
+ (if (null threshed) (format t " -- a null")
+ (progn (setf new-contour
+ (poly:canonical-contour
+ (mapcar #'(lambda (coord-pair)
+ (list (cm-x (first coord-pair)
+ x-orig ppcm)
+ (cm-y (second coord-pair)
+ y-orig ppcm)))
+ (autocontour threshed x-start y-start
+ 0 0 (1- size) (1- size)
+ *ce-sketch-tolerance*))))
+ (if (legal-contour new-contour t)
+ (progn
+ ;; add new contours in.
+ (update-pstruct vol new-contour z)
+ (fs-delete-contour vol z fs)
+ (fs-add-contour vol
+ (make-contour
+ :z z
+ :vertices new-contour)
+ fs))))))))
+ ;; announce new volumes, to get things updated.
+ (ev:announce vol (new-contours vol))
+ (ev:announce vol (update-case vol))))
+
+;;;----------------------------------
+
+(defun generate-internal (window level z fs pe vol
+ images z-min z-max vertices)
+
+ "generate-internal window level z fs pe vol images z-min z-max vertices
+
+Attempts to generate an internal contour for each image with a z coordinate
+between z-min and z-max, using an already generated image as a guideline.
+Attempts to determine an appropriate break for thresholding, though not very
+accurate."
+
+ (let* ((threshold 0)
+ (cur-img (find z images :key #'(lambda (im) (vz (origin im)))))
+ (starts (start-int-cont pe cur-img vertices)))
+ (setf threshold (aref (sl:map-raw-image (pixels cur-img)
+ window level (range cur-img))
+ (+ 5 (pix-x (caar vertices) (x-origin pe)
+ (pix-per-cm cur-img)))
+ (pix-y (cadar vertices) (y-origin pe)
+ (pix-per-cm cur-img))))
+ (format t "threshold = ~S" threshold)
+ ;; deal with each image in turn
+ (dolist (img images)
+ (let ((z (vz (origin img))))
+ (if (and (>= z z-min) (<= z z-max))
+ (let* ;; set variables relevant to this image
+ ((new-contour nil)
+ (ppcm (pix-per-cm img))
+ (x-orig (round (* -1 ppcm (vx (origin img)))))
+ (y-orig (round (* ppcm (vy (origin img)))))
+ ;; note: removing -1 factor from the y-term makes this work
+ (mapped (sl:map-raw-image (pixels img) window
+ level (range img)))
+ (size (array-dimension mapped 0))
+ (threshed (thresh mapped size size
+ threshold
+ sl:*num-gray-pixels* t))
+ (x-start (car starts))
+ (y-start (cadr starts)))
+ (format t "~%Now contouring z= ~A" z)
+ (if (null threshed) (format t " -- a null")
+ (progn (setf new-contour
+ (poly:canonical-contour
+ (mapcar #' (lambda (coord-pair)
+ (list (cm-x (first coord-pair)
+ x-orig ppcm)
+ (cm-y (second coord-pair)
+ y-orig ppcm)))
+ (autocontour threshed x-start y-start
+ 0 0 (1- size) (1- size)
+ *ce-sketch-tolerance*))))
+ (if (legal-contour new-contour t)
+ (progn
+ ;;add new contours in.
+ (update-pstruct vol new-contour z)
+ (fs-delete-contour vol z fs)
+ (fs-add-contour vol
+ (make-contour
+ :z z
+ :vertices new-contour)
+ fs))))))))
+ ;; announce new volumes, to get things updated.
+ (ev:announce vol (new-contours vol))
+ (ev:announce vol (update-case vol)))))
+
+;;;----------------------------------
+
+(defun threshold-int-cont (img verts window level x0 y0)
+
+ "threshold-int-cont img verts esl
+
+Determines the Otsu Thresholding point for a given object based
+upon a user-drawn contour, but examining shade values at the corners of
+a contour. X0 and Y0 are the x-origin and y-origin from the contour
+editor."
+
+ (let ((ppcm (pix-per-cm img))
+ (max-thresh 2)
+ (mapped (sl:map-raw-image (pixels img) window level (range img))))
+ (dolist (point verts)
+ (if (> (aref mapped (pix-x (car point) x0 ppcm)
+ (pix-y (cadr point) y0 ppcm)) max-thresh)
+ (setf max-thresh (aref mapped (pix-x (car point) x0 ppcm)
+ (pix-y (cadr point) y0 ppcm)))))
+ max-thresh))
+
+;;;----------------------------------
+
+(defun start-int-cont (pe img vertices)
+
+ "start-int-cont esl img vertices
+
+Examines a contour scan image to guess where the best starting
+place for a specific organ lies. chooses a place a bit to the left of
+the center of the edge of the organ in question."
+
+ (let* ((size (array-dimension (pixels img) 0))
+ (offset (/ size 32))
+ (bounds (contour-bounding-box vertices))
+ (ppcm (pix-per-cm img))
+ (x-orig (x-origin pe))
+ (y-orig (y-origin pe))
+ (x-start (- (pix-x (caar bounds) x-orig ppcm) offset))
+ (y-start (pix-y (/ (+ (cadar bounds) (cadadr bounds)) 2)
+ y-orig ppcm)))
+ (list x-start y-start)))
+
+;;;----------------------------------
+
+(defun non-empty-img (img height width)
+
+ "non-empty-img img height width
+
+Examines an image in the form of an array, to determine whether the
+image is empty (no array value greater than 0)"
+
+ (dotimes (i height)
+ (dotimes (j width)
+ (if (not (eq (aref img i j) 0))
+ (return-from non-empty-img t))))
+ (return-from non-empty-img nil))
+
+;;;----------------------------------
+
+(defun contour-bounding-box (contour)
+
+ "contour-bounding-box contour
+
+Returns the upper left and lower right coordinates of a bounding box
+for the contour."
+
+ (let* ((point (pop contour))
+ (min-x (first point))
+ (min-y (second point))
+ (max-x (first point))
+ (max-y (second point)))
+ (dolist (point contour)
+ (if (< (first point) min-x)
+ (setf min-x (first point)))
+ (if (< (second point) min-y)
+ (setf min-y (second point)))
+ (if (> (first point) max-x)
+ (setf max-x (first point)))
+ (if (> (second point) max-y)
+ (setf max-y (second point))))
+ (list (list min-x min-y) (list max-x max-y))))
+
+;;;----------------------------------
+;;; End.
diff --git a/prism/src/beam-block-graphics.cl b/prism/src/beam-block-graphics.cl
new file mode 100644
index 0000000..8e2c03c
--- /dev/null
+++ b/prism/src/beam-block-graphics.cl
@@ -0,0 +1,80 @@
+;;;
+;;; beam-block-graphics
+;;;
+;;; this module contains the draw methods for blocks.
+;;;
+;;; 30-Sep-1996 I. Kalet created from beam-graphics.
+;;; 24-Jan-1997 I. Kalet eliminate reference to geometry package.
+;;; Also portal is now the list of vertices, not a contour object.
+;;; 10-May-1997 I. Kalet don't move bev-draw-all here - still circular
+;;; indirectly through plans and patients that way.
+;;; 19-Jan-1998 I. Kalet beam transform is now array, not multiple values.
+;;; 23-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 23-Oct-1999 I. Kalet preserve declutter information if beam was
+;;; already in view - the visible attribute of the graphic prim.
+;;; 20-Sep-2002 I. Kalet punt on oblique view and room view.
+;;; 25-May-2009 I. Kalet remove ref to room-view completely.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------
+
+(defun draw-beam-block (blk v b)
+
+ "Draws beam-block blk of beam b into view v."
+
+ (cond ((and (typep v 'beams-eye-view)
+ (eq b (beam-for v)))
+ (draw-primary-block blk v b))
+ ((typep v 'oblique-view) nil)
+ (t (draw-regular-block blk v b))))
+
+;;;----------------------------------------------
+
+(defun draw-regular-block (blk v b)
+
+ "Draws beam-block blk of beam b into view v. Handles all cases
+except a block of a beam in its own beams-eye-view."
+
+ (let* ((prim (find blk (foreground v) :key #'object))
+ (color (sl:color-gc (display-color blk)))
+ (sad (isodist (if (typep v 'beams-eye-view) (beam-for v)
+ b)))
+ (bt (beam-transform b v)))
+ (unless prim
+ (setq prim (make-segments-prim nil color :object blk))
+ (push prim (foreground v)))
+ (setf (color prim) color
+ (points prim) nil)
+ (when (vertices blk)
+ (draw-portal prim (vertices blk) bt sad v))))
+
+;;;----------------------------------------------
+
+(defun draw-primary-block (blk v b)
+
+ "Draws beam-block blk of primary beam b into beam's eye view v."
+
+ (when (vertices blk)
+ ;; start with new gp's each time, to avoid having to look for and
+ ;; disambiguate the segments and rectangles prims, which would be
+ ;; very complicated. But first catch the visible attribute of a
+ ;; beam graphic prim if present.
+ (let ((visible (aif (find blk (foreground v) :key #'object)
+ (visible it) t)))
+ (setf (foreground v) (remove blk (foreground v) :key #'object))
+ (let* ((color (sl:color-gc (display-color blk)))
+ (solid-prim (get-segments-prim blk v color))
+ (marker-prim (get-rectangles-prim blk v color)))
+ (setf (visible solid-prim) visible)
+ (setf (visible marker-prim) visible)
+ (draw-primary-portal solid-prim
+ marker-prim
+ (vertices blk)
+ (* (collimator-angle b) *pi-over-180*)
+ (isodist b)
+ v)))))
+
+;;;----------------------------------------------
+;;; End.
diff --git a/prism/src/beam-block-panels.cl b/prism/src/beam-block-panels.cl
new file mode 100644
index 0000000..4b2d760
--- /dev/null
+++ b/prism/src/beam-block-panels.cl
@@ -0,0 +1,607 @@
+;;;
+;;; beam-block-panels
+;;;
+;;; this module defines the block editing panel and adjunct stuff.
+;;;
+;;; 2-Jun-1994 I. Kalet created, modified a lot.
+;;; 11-Jul-1994 J. Unger transform entered block contours from gantry to
+;;; collimator space, fixing bug.
+;;; 15-Jul-1994 J. Unger fix some labels, make block panel use sfd to
+;;; scale input contours, rescale when sfd changes.
+;;; 21-Jul-1994 J. Unger rename gantry-to-coll & coll-to-gantry to
+;;; rotate-vertices & move to polygons package.
+;;; 01-Aug-1994 J. Unger make some scaling changes to reconform to spec.
+;;; 02-Aug-1994 J. Unger turn contour-editor into block-editor and split
+;;; off into its own module.
+;;; 12-Jan-1995 I. Kalet destroy bev too. Why was it commented out?
+;;; Also, move isodist function to beams. Use here and elsewhere.
+;;; Get beam for the current block from passed parameter, not a block
+;;; attribute. Same for plan-of and patient to pass to bev-draw-all.
+;;; 30-Apr-1995 I. Kalet delete reference to block editor, just use a
+;;; generic contour editor. Set digitizer-mag in contour editor when
+;;; sfd changes, just like mlc panel, in coll-panels.
+;;; 19-Sep-1996 I. Kalet update call to bev-draw-all due to signature
+;;; change, and make textlines numeric that should have been.
+;;; 21-Jan-1997 I. Kalet eliminate table-position.
+;;; 29-Apr-1997 I. Kalet add beam name to title bar of block panel.
+;;; 11-Jun-1998 I. Kalet change :beam to :beam-for in make-view call.
+;;; 23-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 5-Sep-1999 I. Kalet added declutter and DRR buttons, but no DRR yet.
+;;; 28-May-2000 I. Kalet adjust button size and frame size.
+;;; Parametrize font selection.
+;;; 10-Sep-2000 I. Kalet add DRR image display support, by adding the
+;;; bev to the plan view set, with controls here like the view panel.
+;;; 27-Nov-2000 I. Kalet make this into a beam-blocks panel, for all
+;;; the blocks at once, not one panel per block, i.e., make it like the
+;;; volume editor, with all the organs. Also include the block rotate
+;;; button here, and window and level controls for DRR. Separate out
+;;; the name, color and transmission into a block-attribute-editor as
+;;; for pstructs.
+;;; 2-Dec-2000 I. Kalet don't use plan view set to generate
+;;; background, as it introduces unpredictable updates.
+;;; 14-Mar-2001 I. Kalet fix error that leaves old block graphic
+;;; primitive in background view when block is deleted. Allow
+;;; deletion of currently selected block, and allow for no block
+;;; selected.
+;;; 23-Jun-2001 I. Kalet add remove-notify for deleted event for
+;;; blocks set in beam when destroying the block panel.
+;;; 23-Aug-2004 I. Kalet fix erroneous code that pretends to be a
+;;; special beam-view-mediator, use bev-draw-all instead of
+;;; refresh-bev, encapsulate in a local function, blp-update
+;;; 19-Jan-2005 I. Kalet change make-contour-editor to make-planar-editor
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defclass block-panel (generic-panel)
+
+ ((current-block :accessor current-block
+ :initarg :current-block
+ :documentation "The block currently being edited.")
+
+ (beam-of :accessor beam-of
+ :initarg :beam-of
+ :documentation "The beam holding the blocks.")
+
+ (plan-of :accessor plan-of
+ :initarg :plan-of
+ :documentation "The plan of the current beam.")
+
+ (patient-of :accessor patient-of
+ :initarg :patient-of
+ :documentation "The patient - needed for bev-draw-all.")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame for this panel.")
+
+ (delete-b :accessor delete-b
+ :documentation "The delete panel button.")
+
+ (sfd-box :accessor sfd-box
+ :documentation "The source to film distance textline.")
+
+ (filmdist :accessor filmdist
+ :initarg :filmdist
+ :documentation "The source to film distance.")
+
+ (block-rot-b :accessor block-rot-b
+ :documentation "The block rotation button.")
+
+ (image-button :accessor image-button
+ :documentation "The button that toggles display of
+image data in this view.")
+
+ (fg-button :accessor fg-button
+ :documentation "Brings up a popup menu of objects in the
+view to display them or not on a view by view basis.")
+
+ (viewlist-panel :accessor viewlist-panel
+ :initform nil
+ :documentation "Temporarily holds the list of
+objects visible on the screen.")
+
+ (window-control :accessor window-control
+ :documentation "The textline that displays and sets
+the window for the background view's image.")
+
+ (level-control :accessor level-control
+ :documentation "The textline that displays and sets
+the level for the background view's image.")
+
+ (block-sp :accessor block-sp
+ :documentation "The selector panel for blocks.")
+
+ (block-ed :accessor block-ed
+ :documentation "The contour editor for the current block's
+contour.")
+
+ (bev :accessor bev
+ :documentation "A beam's eye view used as background for the
+contour editor.")
+
+ (image-mediator :accessor image-mediator
+ :initform nil
+ :documentation "A single image-view-mediator to
+manage creation of DRR images as necessary for the view background.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "The busy flag for managing updates to
+settings.")
+
+ )
+
+ (:default-initargs :current-block nil :filmdist 100.0)
+
+ (:documentation "A block panel provides for entry and edit of a set
+of shielding blocks for a beam.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod (setf current-block) :before (new-blk (blp block-panel))
+
+ "Disconnects the old block, if present, before setting the new one."
+
+ (declare (ignore new-blk))
+ (if (current-block blp)
+ (ev:remove-notify blp (new-color (current-block blp)))))
+
+;;;---------------------------------------------
+
+(defmethod (setf current-block) :after (new-blk (blp block-panel))
+
+ "Updates the contour editor background and vertices, and connections
+to the new block, after the old one has been deselected. The selector
+panel creates and places the attribute editor."
+
+ (setf (foreground (bev blp))
+ (remove new-blk (foreground (bev blp)) :key #'object))
+ (bev-draw-all (bev blp) (plan-of blp) (patient-of blp) new-blk)
+ (display-view (bev blp))
+ (if new-blk
+ (progn
+ (setf (vertices (block-ed blp))
+ (poly:rotate-vertices (vertices new-blk)
+ (collimator-angle (beam-of blp))))
+ (setf (color (block-ed blp)) (sl:color-gc (display-color new-blk)))
+ (ev:add-notify blp (new-color new-blk)
+ #'(lambda (pan blk col)
+ (declare (ignore blk))
+ (setf (color (block-ed pan)) (sl:color-gc col)))))
+ (setf (vertices (block-ed blp)) nil)))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((blp block-panel) &rest
+ initargs)
+
+ (let* ((bm (beam-of blp))
+ (size large) ;; constant from prism-globals
+ (btw 150)
+ (bth 25)
+ (font (symbol-value *small-font*))
+ (margin 5)
+ (top-y margin)
+ (dy (+ bth margin))
+ (bpfr (apply #'sl:make-frame
+ (+ size btw (* 2 margin)) (+ size bth 10)
+ :title (format nil "Block Editor for ~A"
+ (name bm))
+ initargs))
+ (win (sl:window bpfr))
+ (del-b (apply #'sl:make-button btw bth
+ :font font :label "Delete Panel" :parent win
+ :ulc-x margin :ulc-y top-y
+ initargs))
+ (sfd-t (apply #'sl:make-textline btw bth
+ :font font :label "SFD: " :parent win
+ :ulc-x margin :ulc-y (bp-y top-y dy 1)
+ :numeric t :lower-limit 10.0 :upper-limit 200.0
+ initargs))
+ (blk-rot-b (apply #'sl:make-button btw bth
+ :label "Rotate Blocks"
+ :ulc-x margin :ulc-y (bp-y top-y dy 2)
+ :parent win :font font
+ initargs))
+ (image-b (apply #'sl:make-button btw bth
+ :font font :label "Image" :parent win
+ :ulc-x margin :ulc-y (bp-y top-y dy 3)
+ initargs))
+ (fg-b (apply #'sl:make-button btw bth
+ :font font :label "Objects" :parent win
+ :ulc-x margin :ulc-y (bp-y top-y dy 4)
+ initargs))
+ (win-ctl (apply #'sl:make-sliderbox btw bth 1.0 2047.0 9999.0
+ :parent win
+ :font font :label "Win: "
+ :ulc-x 0 :ulc-y (bp-y top-y dy 5)
+ :border-width 0
+ :display-limits nil
+ initargs))
+ (lev-ctl (apply #'sl:make-sliderbox btw bth 1.0 4095.0 9999.0
+ :parent win
+ :font font :label "Lev: "
+ :ulc-x 0 :ulc-y (bp-y top-y dy 7)
+ :border-width 0
+ :display-limits nil
+ initargs))
+ (blk-sp (make-selector-panel
+ btw 150 "Add a block"
+ (blocks bm)
+ #'(lambda (name)
+ (make-beam-block name
+ :display-color (display-color bm)))
+ #'(lambda (blk)
+ (setf (current-block blp) blk)
+ (let ((bt (button-for blk (block-sp blp))))
+ (setf (sl:allow-button-2 bt) t)
+ (ev:add-notify blp (sl:button-2-on bt)
+ #'(lambda (pan b)
+ (declare (ignore b))
+ (setf (current-block pan) nil)))
+ (ev:add-notify blp (sl:button-off bt)
+ #'(lambda (pan b)
+ (ev:remove-notify
+ pan (sl:button-2-on b))
+ (ev:remove-notify
+ pan (sl:button-off b)))))
+ (make-attribute-editor blk
+ :parent win :font font
+ :width btw
+ :ulc-x margin
+ :ulc-y (bp-y top-y dy 14)))
+ :ulc-x margin
+ :ulc-y (bp-y top-y dy 9)
+ :parent win :font font
+ :use-color t :radio t))
+ (bev (make-view size size 'beams-eye-view :beam-for bm
+ :display-func
+ #'(lambda (vw)
+ (setf (image-cache vw) nil)
+ (draw (image (image-mediator blp)) vw)
+ (display-view vw)
+ (display-planar-editor (block-ed blp)))))
+ (cb (first (coll:elements (blocks bm)))) ;; could be nil
+ (ce (apply #'make-planar-editor
+ :background (sl:pixmap (picture bev))
+ :vertices nil
+ :x-origin (/ size 2) :y-origin (/ size 2)
+ :scale (scale bev)
+ :digitizer-mag (/ (filmdist blp) (isodist bm))
+ :color (sl:color-gc (if cb (display-color cb)
+ (display-color bm)))
+ :ulc-x (+ btw (* 2 margin))
+ :parent win
+ initargs)))
+ ;; install them and connect them up to the collimator settings
+ (setf (delete-b blp) del-b
+ (sl:info sfd-t) (filmdist blp)
+ (sfd-box blp) sfd-t
+ (block-rot-b blp) blk-rot-b
+ (image-button blp) image-b
+ (fg-button blp) fg-b
+ (window-control blp) win-ctl
+ (level-control blp) lev-ctl
+ (block-sp blp) blk-sp
+ (bev blp) bev
+ (block-ed blp) ce
+ (panel-frame blp) bpfr)
+ (ev:add-notify blp (sl:button-on del-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (destroy pan)))
+ (ev:add-notify blp (sl:new-info sfd-t)
+ #'(lambda (pan tl info)
+ (declare (ignore tl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (filmdist pan) (read-from-string info))
+ (setf (digitizer-mag (block-ed pan))
+ (/ (filmdist pan) (isodist (beam-of pan))))
+ (setf (busy pan) nil))))
+ (ev:add-notify blp (sl:button-on blk-rot-b)
+ #'(lambda (pan btn)
+ (let ((blks (coll:elements (blocks (beam-of pan)))))
+ (if blks
+ (let* ((choice (sl:popup-menu
+ '("Rotate 90 degrees"
+ "Rotate 180 degrees"
+ "Rotate 270 degrees")))
+ (angle (when choice (* 90.0 (1+ choice)))))
+ (when choice
+ (dolist (blk (coll:elements
+ (blocks (beam-of pan))))
+ (setf (vertices blk)
+ (poly:rotate-vertices (vertices blk)
+ angle)))
+ (bev-draw-all (bev pan)
+ (plan-of pan)
+ (patient-of pan)
+ (current-block pan))
+ (display-view (bev pan))
+ (setf (vertices (block-ed pan))
+ (poly:rotate-vertices
+ (vertices (current-block pan))
+ (collimator-angle (beam-of pan))))))
+ (sl:acknowledge
+ '("No block added or selected"
+ "Please add or select a block first"))))
+ (setf (sl:on btn) nil)))
+ (setf (image-button bev) (image-button blp))
+ (setf (drr-state bev) (drr-state bev)) ;; to init the button
+ (ev:add-notify blp (sl:button-on (image-button blp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (bev pan)) t)
+ (display-planar-editor (block-ed pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify blp (sl:button-off (image-button blp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (bev pan)) nil)
+ (display-planar-editor (block-ed pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify blp (sl:button-2-on (image-button blp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (case (drr-state (bev pan))
+ ;;'stopped is a noop
+ ('running
+ (setf (drr-state (bev pan)) 'paused))
+ ('paused
+ (setf (drr-state (bev pan)) 'running)
+ (drr-bg (bev pan))))
+ (setf (busy pan) nil))))
+ (ev:add-notify blp (bg-toggled bev)
+ #'(lambda (pan vw)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:on (image-button pan))
+ (background-displayed vw))
+ (setf (busy pan) nil))))
+ (ev:add-notify blp (sl:button-on (fg-button blp))
+ #'(lambda (pan bt)
+ (setf (viewlist-panel pan)
+ (make-instance 'viewlist-panel
+ :refresh-fn #'(lambda (vw)
+ (display-view vw)
+ (display-planar-editor ce))
+ :view (bev pan)))
+ (ev:add-notify pan (deleted (viewlist-panel
+ pan))
+ #'(lambda (pnl vlpnl)
+ (declare (ignore vlpnl))
+ (setf (viewlist-panel pnl) nil)
+ (when (not (busy pnl))
+ (setf (busy pnl) t)
+ (setf (sl:on bt) nil)
+ (setf (busy pnl) nil))))))
+ (ev:add-notify blp (sl:button-off (fg-button blp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (viewlist-panel pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify blp (new-vertices ce)
+ #'(lambda (pan ced new-verts)
+ (declare (ignore ced))
+ (if (current-block pan)
+ (setf (vertices (current-block pan))
+ (poly:rotate-vertices new-verts
+ (- (collimator-angle
+ (beam-of pan)))))
+ (sl:acknowledge
+ '("No block added or selected"
+ "Please add or select a block first")))))
+ (ev:add-notify blp (new-scale ce)
+ #'(lambda (pan ced new-sc)
+ (let ((bev (bev pan)))
+ (setf (scale bev) new-sc)
+ (bev-draw-all bev (plan-of pan) (patient-of pan)
+ (current-block pan))
+ (display-view bev)
+ (display-planar-editor ced))))
+ (ev:add-notify blp (new-origin ce)
+ #'(lambda (pan ced new-org)
+ (let ((bev (bev pan)))
+ (setf (origin bev) new-org)
+ (bev-draw-all bev (plan-of pan) (patient-of pan)
+ (current-block pan))
+ (display-view bev)
+ (display-planar-editor ced))))
+ (setf (sl:setting (window-control blp))
+ (coerce (window bev) 'single-float))
+ (ev:add-notify blp (sl:value-changed (window-control blp))
+ #'(lambda (pan wc win)
+ (declare (ignore wc))
+ (setf (window (bev pan)) (round win))
+ (if (background-displayed (bev pan))
+ (display-planar-editor (block-ed pan)))))
+ (setf (sl:setting (level-control blp))
+ (coerce (level bev) 'single-float))
+ (ev:add-notify blp (sl:value-changed (level-control blp))
+ #'(lambda (pan lc lev)
+ (declare (ignore lc))
+ (setf (level (bev pan)) (round lev))
+ (if (background-displayed (bev pan))
+ (display-planar-editor (block-ed pan)))))
+ (if (image-set (patient-of blp))
+ (setf (image-mediator blp)
+ (make-image-view-mediator (image-set (patient-of blp)) bev)))
+ ;; this is a special beam-view mediator for this view only
+ (flet ((blp-update (pan bm arg)
+ (declare (ignore bm arg))
+ (let ((bev (bev pan)))
+ (setf (drr-state bev) 'stopped)
+ (ev:announce bev (reset-image bev))
+ (bev-draw-all bev (plan-of pan) (patient-of pan)
+ (current-block pan))
+ (display-view bev)
+ (display-planar-editor (block-ed pan)))))
+ (ev:add-notify blp (new-color bm) #'blp-update)
+ (ev:add-notify blp (axis-changed bm) #'blp-update)
+ (ev:add-notify blp (new-coll-set (collimator bm))
+ #'(lambda (pnl coll)
+ (blp-update pnl coll nil)))
+ (ev:add-notify blp (new-id (wedge bm)) #'blp-update)
+ (ev:add-notify blp (new-rotation (wedge bm)) #'blp-update)
+ (ev:add-notify blp (new-gantry-angle bm) #'blp-update)
+ (ev:add-notify blp (new-couch-angle bm) #'blp-update)
+ (ev:add-notify blp (new-couch-lat bm) #'blp-update)
+ (ev:add-notify blp (new-couch-ht bm) #'blp-update)
+ (ev:add-notify blp (new-couch-long bm) #'blp-update)
+ (ev:add-notify blp (new-machine bm)
+ #'(lambda (pnl b mach)
+ (ev:add-notify pnl (new-coll-set (collimator b))
+ #'(lambda (pnl coll)
+ (blp-update pnl coll nil)))
+ (blp-update pnl b mach))))
+ ;; this is to remove the contour of a block that is deleted
+ (ev:add-notify blp (coll:deleted (blocks (beam-of blp)))
+ #'(lambda (pan blkset blk)
+ (declare (ignore blkset))
+ (let ((vw (bev pan)))
+ (setf (foreground vw)
+ (remove blk (foreground vw) :key #'object))
+ (display-view vw)
+ (display-planar-editor (block-ed pan)))))
+ ;; this is to keep the current block consistent
+ (ev:add-notify blp (new-coll-angle bm)
+ #'(lambda (pan bm4 newang)
+ (draw bm4 (bev pan))
+ (display-view (bev pan))
+ (if (current-block pan)
+ (setf (vertices (block-ed pan))
+ (poly:rotate-vertices
+ (vertices (current-block pan)) newang)))))
+ (unless (select-1 blk-sp)
+ (bev-draw-all bev (plan-of blp) (patient-of blp))
+ (display-view bev))
+ (display-planar-editor ce)))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((bp block-panel))
+
+ (let ((vw (bev bp))
+ (bm (beam-of bp)))
+ ;; ensure that there are not any lingering
+ ;; background jobs for this view-panel
+ (remove-bg-drr vw)
+ (when (eq 'running (drr-state vw))
+ (setf (drr-state vw) 'paused))
+ (setf (image-button vw) nil)
+ (ev:remove-notify bp (new-color bm))
+ (ev:remove-notify bp (axis-changed bm))
+ (ev:remove-notify bp (new-coll-set (collimator bm)))
+ (ev:remove-notify bp (new-id (wedge bm)))
+ (ev:remove-notify bp (new-rotation (wedge bm)))
+ (ev:remove-notify bp (new-gantry-angle bm))
+ (ev:remove-notify bp (new-couch-angle bm))
+ (ev:remove-notify bp (new-couch-lat bm))
+ (ev:remove-notify bp (new-couch-ht bm))
+ (ev:remove-notify bp (new-couch-long bm))
+ (ev:remove-notify bp (new-machine bm))
+ (ev:remove-notify bp (new-coll-angle bm))
+ (if (current-block bp)
+ (ev:remove-notify bp (new-color (current-block bp))))
+ (if (image-mediator bp) (destroy (image-mediator bp)))
+ (ev:remove-notify bp (coll:deleted (blocks (beam-of bp))))
+ (destroy vw))
+ (sl:destroy (delete-b bp))
+ (sl:destroy (sfd-box bp))
+ (sl:destroy (block-rot-b bp))
+ (sl:destroy (image-button bp))
+ (if (sl:on (fg-button bp)) (setf (sl:on (fg-button bp)) nil))
+ (sl:destroy (fg-button bp))
+ (sl:destroy (window-control bp))
+ (sl:destroy (level-control bp))
+ (destroy (block-sp bp))
+ (destroy (block-ed bp))
+ (sl:destroy (panel-frame bp)))
+
+;;;---------------------------------------------
+
+(defun make-block-panel (bm pln pat)
+
+ "make-block-panel bm pln pat
+
+returns a block panel for beam bm, in plan pln, for patient pat."
+
+ (make-instance 'block-panel
+ :beam-of bm :plan-of pln :patient-of pat))
+
+;;;---------------------------------------------
+
+(defclass block-attribute-editor (attribute-editor)
+
+ ((trans-box :accessor trans-box
+ :documentation "The textline for the transmission
+factor.")
+ )
+
+ (:default-initargs :height 95)
+
+ (:documentation "The subclass of attribute-editor that is specific
+to beam blocks")
+ )
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((ble block-attribute-editor)
+ &rest initargs)
+
+ "Initializes the user interface for the beam block attribute editor."
+
+ (let* ((frm (fr ble))
+ (frm-win (sl:window frm))
+ (obj (object ble))
+ (dx 5)
+ (bth 25)
+ (btw (button-width ble))
+ (att-f (symbol-value *small-font*)) ;; the value, not the symbol
+ (tran-t (apply #'sl:make-textline btw bth
+ :font att-f :label "Trans: " :parent frm-win
+ :ulc-x dx :ulc-y (bp-y dx bth 2)
+ :numeric t :lower-limit 0.0 :upper-limit 1.0
+ initargs)))
+ (setf (sl:info tran-t) (transmission obj)
+ (trans-box ble) tran-t)
+ (ev:add-notify ble (sl:new-info tran-t)
+ #'(lambda (pan tl info)
+ (declare (ignore tl))
+ (setf (transmission (object pan))
+ (coerce (read-from-string info)
+ 'single-float))))))
+
+;;;---------------------------------------------
+
+(defmethod make-attribute-editor ((blk beam-block) &rest initargs)
+
+ "make-attribute-editor (blk beam-block) &rest initargs
+
+Returns a beam-block-specific attribute-editor with specified parameters."
+
+ (apply #'make-instance 'block-attribute-editor
+ :object blk :allow-other-keys t
+ initargs))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((ble block-attribute-editor))
+
+ (sl:destroy (trans-box ble)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/beam-blocks.cl b/prism/src/beam-blocks.cl
new file mode 100644
index 0000000..c12a60d
--- /dev/null
+++ b/prism/src/beam-blocks.cl
@@ -0,0 +1,121 @@
+;;;
+;;; beam-blocks
+;;;
+;;; this module describes shielding blocks and their functions
+;;;
+;;; 16-May-1994 I. Kalet finally split off from collimators module.
+;;; 2-Jun-1994 I. Kalet add more details.
+;;; 23-Jun-1994 I. Kalet put copy-block here from beams. Change float
+;;; to single-float.
+;;; 19-Oct-1994 J. Unger add new-transmission announcement when trans
+;;; changes.
+;;; 9-Jan-1995 I. Kalet delete beam-for attribute.
+;;; 11-Sep-1995 I. Kalet add new-color event, DON'T SAVE IT.
+;;; 19-Dec-1999 I. Kalet add keyword parameter :copy-name to copy-block
+;;; 22-Feb-2000 I. Kalet replace copy-block with method for copy, and
+;;; just copy straight. If reflection is needed, do it to the copy.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defclass beam-block (generic-prism-object contour)
+
+ ((transmission :type single-float
+ :initarg :transmission
+ :accessor transmission
+ :documentation "The nominal fractional transmission
+through the block.")
+
+ (new-transmission :type ev:event
+ :accessor new-transmission
+ :initform (ev:make-event)
+ :documentation "Announced when the block
+transmission is changed.")
+
+ (new-vertices :type ev:event
+ :accessor new-vertices
+ :initform (ev:make-event)
+ :documentation "Announced when the block vertices are
+updated.")
+
+ (new-color :type ev:event
+ :accessor new-color
+ :initform (ev:make-event)
+ :documentation "Announced when the block display-color
+is updated. The display-color is inherited from class contour.")
+
+ )
+
+ (:default-initargs :name "" :z 0.0 :transmission 0.05)
+
+ (:documentation "Beam-blocks are always attached to some beam. The
+block outline is defined by filling in the slots inherited from class
+contour.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod slot-type ((object beam-block) slotname)
+
+ (case slotname
+ (beam-for :ignore)
+ (otherwise :simple)))
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((blk beam-block))
+
+ (append (call-next-method)
+ '(new-vertices new-transmission new-color)))
+
+;;;---------------------------------------------
+
+(defmethod (setf transmission) :after (new-trans (blk beam-block))
+
+ (ev:announce blk (new-transmission blk) new-trans))
+
+;;;---------------------------------------------
+
+(defmethod (setf vertices) :after (new-verts (blk beam-block))
+
+ (ev:announce blk (new-vertices blk) new-verts))
+
+;;;---------------------------------------------
+
+(defmethod (setf display-color) :after (new-col (blk beam-block))
+
+ (ev:announce blk (new-color blk) new-col))
+
+;;;---------------------------------------------
+
+(defun make-beam-block (block-name &rest initargs)
+
+ (apply #'make-instance 'beam-block
+ :name (if (equal block-name "")
+ (format nil "~A" (gensym "BLOCK-"))
+ block-name)
+ initargs))
+
+;;;---------------------------------------------
+
+(defmethod copy ((blk beam-block))
+
+ "copy (blk beam-block)
+
+Returns an exact copy of the supplied block. If the block vertices
+need to be reflected, do it to the copied new block."
+
+ (make-beam-block (name blk)
+ :transmission (transmission blk)
+ :z (z blk)
+ :vertices (mapcar #'(lambda (pt)
+ (list (first pt)
+ (second pt)))
+ (vertices blk))
+ :display-color (display-color blk)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/beam-dose.cl b/prism/src/beam-dose.cl
new file mode 100644
index 0000000..7b42386
--- /dev/null
+++ b/prism/src/beam-dose.cl
@@ -0,0 +1,1384 @@
+;;;
+;;; beam-dose
+;;;
+;;; The external Photon and Neutron beam dose computation functions
+;;;
+;;; 2-Jan-1997 I. Kalet started, based on work by Gavin Young
+;;; 16-Jan-1997 I. Kalet define functions for both grid and points,
+;;; called by new version of dosecomp module.
+;;; 21-Mar-1997 I. Kalet continuing work...
+;;; 21-Jun-1997 BobGian posting progress-report version - more to do.
+;;; 3-Jul-1997 BobGian update NEARLY-xxx -> poly:NEARLY-xxx .
+;;; 11-Aug-1997 BobGian integrate separately written beam-dose calculation
+;;; code into this file with proper interface conventions.
+;;; 21-Aug-1997 BobGian flush NEARLY-EQUAL. Used only for wedge angles,
+;;; which are maintained by Prism system to be exactly one value from the
+;;; set {0.0, 90.0, 180.0, 270.0} and therefore exact equality works.
+;;; 25-Aug-1997 BobGian change #.(expression (coerce PI 'SINGLE-FLOAT))
+;;; to #.(coerce (expression PI))
+;;; 3-Sep-1997 BobGian completed and began testing.
+;;; 7-Sep-1997 BobGian move clipping code to pathlength.
+;;; 22-Sep-1997 BobGian made BEAM-DOSE return 0.0 if dosepoint is outside pt.
+;;; 7-Oct-1997 BobGian move CONTOUR-ENCLOSES-P to POLYGONS package.
+;;; 25-Oct-1997 BobGian remodel lookup fcns for WEDGE-INFO objects.
+;;; 28-Oct-1997 BobGian dose not scaled by TRAY-FACTOR unless blocks used.
+;;; 30-Oct-1997 BobGian COMPUTE-BEAM-DOSE returns T on success,
+;;; NIL if result is not valid.
+;;; 2-Nov-1997 BobGian Depth of Isocenter below surface now computes
+;;; as negative value if SSD > SAD [isocenter between source and patient].
+;;; 9-Nov-1997 BobGian BLOCK-FACTOR broken - rewrite sector integration
+;;; for it, OUTPUTFACTOR-COL (MLC method), and MLC-OCR-FACTOR.
+;;; 10-Nov-1997 BobGian add decls (THE) for speedup.
+;;; 7-Jan-1998 BobGian change sector integration from min 10 segs and max
+;;; 5.0 degrees/segment to min 1 seg and max 10.0 degrees/segment.
+;;; 22-Jan-1998 BobGian update to major revision including LABELS-defined
+;;; local functions to avoid passing large arg lists, argument-vector for
+;;; passing flonums to avoid flonum boxing, and array declarations to
+;;; inline array accesses and avoid flonum boxing. GRID results still
+;;; stored in ordinary SINGLE-FLOAT 3-D arrays, pending Franz patch
+;;; (ie, special arrays-of-arrays hack used only inside dosecalc, not
+;;; after results returned to rest of Prism).
+;;; 09-Mar-1998 BobGian modest upgrade of dose-calc code.
+;;; 13-Mar-1998 BobGian fix rotation of MLC portal as used for finding
+;;; bounding box in computing equivalent square.
+;;; 22-May-1998 BobGian upgrade to latest version of dose calculation:
+;;; - Reparameterize Arg-Vec (using named slots) to make consistent
+;;; with other users - in PATHLENGTH and clipping code.
+;;; - Optimize PATHLENGTH prologue before main loop is entered.
+;;; - Special-case and inline calculation of portal fieldwidth
+;;; instead of using generic function.
+;;; - Convert clipping code to use Arg-Vec instead of ordinary
+;;; argument-passing conventions.
+;;; - Simplify printing on background window during grid calcs.
+;;; - Contour-containment checked using ENCLOSES? (in "pathlength.cl")
+;;; rather than CONTOUR-ENCLOSES-P (arg-passing consistency).
+;;; - Inline trigonometry using short series expansions for SIN and
+;;; ATAN (only in places where accuracy is not critical).
+;;; - Arg-Vec passed to LABELS-defined internal functions
+;;; (BEAM-DOSE and BLOCK-FACTOR) via lexical environment rather
+;;; than as explicit argument.
+;;; 01-Jun-1998 BobGian simplify call to ENCLOSES? [zero-distance test
+;;; redundant because it is done inside ENCLOSES? anyway].
+;;; 08-Jun-1998 BobGian minor update - PATHLENGTH consistency changes.
+;;; 11-Jun-1998 BobGian Bug fix - raise threshold for degenerate sector
+;;; in block factor sector integration, add angle to test, and move
+;;; test slightly (to where angle is defined).
+;;; 25-Jun-1998 BobGian fix OCR factor to use fanline ratio 2.0 when
+;;; rect coll is on CAX and dosepoint is in shadow region.
+;;; 26-Jun-1998 BobGian pass ORGAN-DENSITY-ARRAY as array rather than
+;;; list - random-access faster. (Needed by PATHLENGTH.)
+;;; 17-Jul-1998 BobGian add Arc-Therapy - forgotten in original!!
+;;; Change of arguments to COMPUTE-BEAM-DOSE - factor patient descriptors
+;;; from COMPUTE-BEAM-DOSE to BUILD-PATIENT-STRUCTURES.
+;;; 13-Aug-1998 BobGian PATHLENGTH returns "dosepoint-inside-patient-p"
+;;; flag (numerical value returned via Arg-Vec) so COMPUTE-BEAM-DOSE
+;;; can set dose outside patient to zero.
+;;; 03-Feb-2000 BobGian cosmetic fixes (case regularization, clarify
+;;; comments about return value from COMPUTE-BEAM-DOSE).
+;;; 08-Feb-2000 BobGian more cosmetic cleanup.
+;;; 02-Mar-2000 BobGian add declarations and rename a few local vars
+;;; in COMPUTE-BEAM-DOSE for consistency with COMPUTE-ELECTRON-DOSE.
+;;; 29-Jun-2000 BobGian cosmetics - comments, whitespace.
+;;; 11-Aug-2000 BobGian remove debug printout accidently left in prev ver.
+;;; 06-Sep-2000 BobGian fix BEAM-DOSE (when clipping blocks to portal)
+;;; to ignore blocks whose VERTICES list is empty.
+;;; 02-Nov-2000 BobGian function name and argument order changes to make
+;;; consistent with new version of dose-calc used in electron code.
+;;; Also simplify termination condition for block-factor and MLC sector
+;;; integration routines.
+;;; 30-May-2001 BobGian - change call interface between photon dose calc and
+;;; pathlength computation to be consistent with new factored scheme used
+;;; in electron dosecalc. Wrap generic arithmetic with THE-declared types.
+;;; Other misc declarations and minor optimizations. Move macro
+;;; definition MONUS to "dosecomp-decls".
+;;; 03-Jun-2001 BobGian fix bug giving non-zero dose for point outside body.
+;;; 22-Dec-2001 BobGian remove erroneous ERROR call when CAX ray misses pt.
+;;; 15-Mar-2002 BobGian parameterize constants used for Pathlength calc.
+;;; 15-Mar-2002 BobGian change "erroneous but OK" conditions to call
+;;; sl:ACKNOWLEDGE rather than ERROR. Some conditions are continuable;
+;;; others abort dosecalc by immediately returning NIL.
+;;; 15-Mar-2002 BobGian PATHLENGTH-RAYTRACE used for "ray out-of-body"
+;;; detection. Former errors on this condition now return gracefully.
+;;; 29-Apr-2002 BobGian PATHLENGTH-RAYTRACE cannot be used alone for
+;;; "ray out-of-body" detection, since it traces full length of normalizing
+;;; distance. Must also integrate to dosepoint for correct test.
+;;; 03-Jan-2003 BobGian:
+;;; Flush macros FAST-SIN and FAST-ATAN - not accurate enough.
+;;; Former arg to BEAM-DOSE now passed in Arg-Vector [it is a pass-through
+;;; to PATHLENGTH-INTEGRATE].
+;;; Update arg-passing and return-value-passing conventions for
+;;; PATHLENGTH-RAYTRACE and PATHLENGTH-INTEGRATE.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 29-Aug-2003 BobGian - remove obsolete version number in change log header.
+;;; 12-Feb-2005 AMSimms - update SINGLE-FLOAT calls (an Allegro specific
+;;; coercion function) to use coerce explicitly
+;;; 6-Jul-2007 I. Kalet replace a few more SINGLE-FLOAT calls that
+;;; Andrew missed.
+;;;
+
+(in-package :prism)
+
+;;; NB: In all below:
+;;;
+;;; All flonums in Prism are SINGLE-FLOATs.
+;;;
+;;; "Pair" means two-list rather than dotted-pair.
+;;;
+;;; A "subcontour" is a contour resulting from the intersection of a portal
+;;; with a block contour. In general, such an intersection may produce
+;;; zero, one, or more subcontours. The general word CONTOUR denotes a
+;;; [non-closed] vertex list. The specific word SUBCONTOUR denotes a
+;;; particular subtype of contour - namely, one of the contours resulting
+;;; from clipping a block contour to the portal contour.
+;;;
+;;; All contours and subcontours are represented as a list of vertices,
+;;; each a "pair" [as above] of X,Y coordinates in the collimator system.
+;;; They are both OPEN contours; that is, the first element is NOT repeated
+;;; as the last - there is an implicit edge from last back to first.
+;;;
+;;; All lists representing contours and subcontours list explicitly and
+;;; once only vertices in the contour. There is an implied edge
+;;; closing the contour from the last back to the first vertex. Block
+;;; CONTOURS can be traversed in either direction. The clipping
+;;; code always generates Clipped Block SUBCONTOURS in the CCW direction.
+;;; This is not required by the sector-integration code but it is so
+;;; assumed because it eliminates need for checks in BLOCK-FACTOR.
+;;;
+;;; Unless specifically indicated otherwise, all CONTOURS and SUBCONTOURS
+;;; are represented with vertices whose coordinates are in the COLLIMATOR
+;;; system and as projected to the ISOCENTER, not the DOSEPOINT plane.
+;;;
+;;; Collimator-system coordinates XC, YC, and ZC of dosepoint in the tech
+;;; report are replaced in this code by XCI, YCI, XCD, YCD, and
+;;; ZCD to make clearer whether we mean dosepoint coordinates in the
+;;; collimator system as projected onto the isocenter plane or at the
+;;; dosepoint plane. Using separate coordinates with scaling done once
+;;; only also avoids repeated rescalings throughout the code.
+;;;
+;;; Coordinates XCI, YCI are X, Y coordinates [orthogonal to central axis]
+;;; of dosepoint in COLLIMATOR system projected to the ISOCENTER plane
+;;; [ie, the plane normal to the central axis]. There is no ZCI coordinate,
+;;; because ZC is the Z coord of dosepoint in the collimator system
+;;; [distance along central axis, with origin at isocenter], and in the
+;;; isocenter plane it would always equal ZERO.
+;;;
+;;; Collimator-system coordinates of the portal are indicated as XCI-, XCI+,
+;;; YCI-, YCI+ [X,Y respectively, minimal or inf versus maximal or sup
+;;; respectively] as projected onto the isocenter plane. Portal boundaries
+;;; are never projected onto the dosepoint plane.
+;;;
+;;; Since collimator-jaw overcentering is not supported, we have that:
+;;; XCI+, YCI+ >= 0.0 and
+;;; XCI-, YCI- <= 0.0 always.
+;;;
+;;; Coordinates XCD, YCD are X, Y coordinates of dosepoint in COLLIMATOR
+;;; system AT THE DOSEPOINT PLANE ["identity projection"]. ZCD is the Z
+;;; coord in collimator system of dosepoint - that is, distance along the
+;;; central axis from isocenter to dosepoint plane.
+;;;
+;;; Patient-system coordinates of dosepoint are XP, YP, ZP.
+;;;
+;;; File-wide abbreviations:
+;;; "DP" for "DosePoint".
+;;; "LU" for "Lookup" (as in "TPR table-lookup").
+
+;;;=============================================================
+;;; Main external photon beam dose calculation function.
+
+(defun compute-beam-dose (bm bms pts gg organ-vertices-list organ-z-extents
+ organ-density-array &aux mach dosedata
+ (num-beams (length bms)))
+
+ "compute-beam-dose bm bms pts gg organ-vertices-list
+ organ-z-extents organ-density-array
+
+computes the dose to each point in PTS, a list of points (MARK objects),
+and all points in the grid specified by GG, a GRID-GEOMETRY, for beam
+BM, stores the doses in the points and/or grid attribute of the beam's
+DOSE-RESULT. One of PTS or GG should be NIL, the other non-NIL.
+Rest of args describe patient's anatomy (beam-independent).
+Returns T on success and NIL if unable to complete."
+
+ ;; Enable all the table lookup functions to reference the beam's machine's
+ ;; DOSE-INFO object [contents of machine's DOSE-DATA slot] as local variable
+ ;; passed to accessor functions. MACHINE of BM calls GET-THERAPY-MACHINE
+ ;; which loads THERAPY-MACHINE object - including DOSE-INFO object in its
+ ;; DOSE-DATA slot - from machine definition file if not already resident.
+ (declare (type list bms pts organ-vertices-list organ-z-extents)
+ (type fixnum num-beams))
+
+ (setq mach (machine bm)
+ dosedata (dose-data mach))
+
+ (prog ((sad (cal-distance mach)) ;Source-to-Isocenter Distance [SAD]
+ (rslt (result bm)) ;Object holding result
+ (beam-name (name bm))
+ (beam-num (the fixnum (1+ (the fixnum (position bm bms :test #'eq)))))
+ (arc-sz (arc-size bm)) ;Total sweep - non-zero for Arc-Therapy
+ (num-arcs 0) ;Number of arc segments in Arc-Therapy
+ (arc-num 0) ;Current arc-segment evaluation number
+ (tpr- at -iso 0.0) ;TPR-AT-ISO for individual beam
+ (avg-tpr- at -iso 0.0) ;Running avg TPR-AT-ISO for Arc-Therapy
+
+ ;; Weighting coefficient for averaging of dose and TPR-AT-ISO
+ ;; when doing Arc-Therapy - or unity for regular beam.
+ (arc-scale-factor 1.0)
+ (coll (collimator bm)) ;Collimator object
+ (portal-vertices) ;Its portal
+ (outputfactor 0.0)
+ (cal*atten*trayfactor*of 0.0) ;Product of factors
+ (dose-multiplier 0.0) ;Temporary factor
+
+ ;; Terms of the Patient-to-Collimator Transform.
+ (pct-r0 0.0) (pct-r1 0.0) (pct-r2 0.0)
+ (pct-r3 0.0) (pct-r4 0.0) (pct-r5 0.0)
+ (pct-r6 0.0) (pct-r7 0.0) (pct-r8 0.0)
+
+ (iso-xp (- (the single-float (couch-lateral bm)))) ;Isocenter coords
+ (iso-yp (- (the single-float (couch-height bm))))
+ (iso-zp (- (the single-float (couch-longitudinal bm))))
+ (src-xp 0.0) (src-yp 0.0) (src-zp 0.0) ;Source coordinates
+
+ (ocr-vector (ocr-table-vector dosedata)) ;OCR tables
+ (ocr-fssmap (ocr-fss-mapper dosedata))
+ (ocr-fss-ar (ocr-fieldsizes dosedata))
+ (ocr-depmap (ocr-depth-mapper dosedata))
+ (ocr-dep-ar (ocr-depths dosedata))
+ (ocr-fanmap (ocr-fanline-mapper dosedata))
+ (ocr-fan-ar (ocr-fanlines dosedata))
+ (ocr-tbl-ar (ocr-table dosedata))
+
+ (tpr-vector (tpr-table-vector dosedata)) ;TPR tables
+ (tpr-fssmap (tpr-fss-mapper dosedata))
+ (tpr-fss-ar (tpr-fieldsizes dosedata))
+ (tpr-depmap (tpr-depth-mapper dosedata))
+ (tpr-dep-ar (tpr-depths dosedata))
+ (tpr-tbl-ar (tpr-table dosedata))
+
+ (tpr0-vector (tpr0-table-vector dosedata)) ;Zero-field TPR tables
+ (tpr0-depmap (tpr0-depth-mapper dosedata))
+ (tpr0-dep-ar (tpr0-depths dosedata))
+ (tpr0-tbl-ar (tpr0-table dosedata))
+
+ (spr-vector (spr-table-vector dosedata)) ;SPR tables
+ (spr-radmap (spr-radius-mapper dosedata))
+ (spr-rad-ar (spr-radii dosedata))
+ (spr-depmap (spr-depth-mapper dosedata))
+ (spr-dep-ar (spr-depths dosedata))
+ (spr-tbl-ar (spr-table dosedata))
+
+ (wedgedata) (wdg-rotation 0.0) ;Wedge Descriptors
+ (wdg-vector) (wdg-depmap) (wdg-dep-ar)
+ (wdg-posmap) (wdg-pos-ar) (wdg-tbl-ar)
+ (wcaf-dep 0.0) (wcaf-fsz 0.0) (wcaf-con 0.0) ;Wedge CAF Coefficients
+
+ (gan-rad (* (the single-float (gantry-angle bm))
+ #.(coerce (/ pi 180.0d0) 'single-float)))
+
+ (clipped-blocks '()) ;Non-null if blocks present
+ (xci- 0.0) (xci+ 0.0) (yci- 0.0) (yci+ 0.0) ;Portal boundaries
+ (wc 0.0) ;Equiv-sq width at isocenter
+
+ (sin-t 0.0) (cos-t 0.0) (sin-g 0.0) (cos-g 0.0)
+ (sin-c 0.0) (cos-c 0.0) (iso-depth 0.0)
+
+ ;; ARG-VEC is SINGLE-FLOAT array with Argv-Size slots
+ ;; for passing args and returning results.
+ (arg-vec (make-array #.Argv-Size :element-type 'single-float)))
+ ;;
+ (declare (type single-float sad iso-xp iso-yp iso-zp wdg-rotation arc-sz
+ src-xp src-yp src-zp pct-r0 pct-r1 pct-r2 pct-r3 pct-r4
+ pct-r5 pct-r6 pct-r7 pct-r8 iso-depth wc arc-scale-factor
+ cal*atten*trayfactor*of gan-rad sin-t cos-t sin-g cos-g
+ sin-c cos-c outputfactor wcaf-dep wcaf-fsz wcaf-con xci-
+ xci+ yci- yci+ dose-multiplier tpr- at -iso avg-tpr- at -iso)
+ (type simple-base-string beam-name)
+ (type (simple-array t 1)
+ ocr-fssmap ocr-depmap ocr-fanmap tpr-fssmap tpr-depmap
+ tpr0-depmap spr-radmap spr-depmap ocr-tbl-ar tpr-tbl-ar
+ spr-tbl-ar)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type (simple-array single-float (3)) tpr0-vector)
+ (type (simple-array single-float (6)) tpr-vector spr-vector)
+ (type (simple-array single-float (9)) ocr-vector)
+ (type (simple-array single-float 1)
+ ocr-fss-ar ocr-dep-ar ocr-fan-ar tpr-fss-ar tpr-dep-ar
+ tpr0-dep-ar tpr0-tbl-ar spr-rad-ar spr-dep-ar)
+ (type fixnum beam-num num-arcs arc-num))
+
+ (when (consp pts)
+ ;; This sets POINTS slot to list of zeros. For Arc-Therapy, these values
+ ;; will get incremented each iteration. Note that we allocate this list
+ ;; only ONCE and increment its elements with each iteration, ie, for each
+ ;; sub-beam being integrated to get the entire arc.
+ ;;
+ ;; For a regular beam, these values will get replaced by calculated dose.
+ ;; Only a single flonum box is wasted in initialization, because each
+ ;; element of the list is a pointer to the SAME boxed flonum.
+ (setf (points rslt) (make-list (length pts) :initial-element 0.0)))
+
+ (when (> arc-sz 0.0) ;Ie, doing Arc-Therapy
+ ;; Original ARC-SZ is size of entire arc in DEGREES.
+ ;; Number of beam evaluations is one greater than NUM-ARCS [fencepost].
+ (setq num-arcs (max (the fixnum (ceiling arc-sz 5.0)) 10))
+ ;; New ARC-SZ is of gantry angle increment for each segment in RADIANS.
+ (setq arc-sz (* (/ arc-sz (coerce num-arcs 'single-float))
+ #.(coerce (/ pi 180.0d0) 'single-float)))
+ ;; ARC-SCALE-FACTOR weights zero-th and last terms in arc integration
+ ;; by half as much as each of the "middle" terms. This is necessary
+ ;; to keep DOSE-MULTIPLIER in sync with ARC-SCALE-FACTOR. Iteration
+ ;; control conditional at end of loop doubles and halves value as needed.
+ (setq arc-scale-factor (/ 0.5 (coerce num-arcs 'single-float))))
+
+ (let ((wdg-object (wedge bm)))
+ ;; FIND returns a WEDGE-INFO object for a wedge ID fitting a wedge
+ ;; on the machine, or NIL for an ID of 0, NIL, or any other value.
+ ;; Therefore, WEDGEDATA = NIL -> no wedge.
+ (when (setq wedgedata (find (id wdg-object) (wedges mach) :key #'id))
+ (setq wcaf-dep (caf-depth-coef wedgedata)) ;Wedge-CAF coefficients
+ (setq wcaf-fsz (caf-fs-coef wedgedata))
+ (setq wcaf-con (caf-constant wedgedata))
+ (setq wdg-vector (profile-table-vector wedgedata)) ;Wedge tables
+ (setq wdg-depmap (profile-depth-mapper wedgedata))
+ (setq wdg-dep-ar (profile-depths wedgedata))
+ (setq wdg-posmap (profile-position-mapper wedgedata))
+ (setq wdg-pos-ar (profile-positions wedgedata))
+ (setq wdg-tbl-ar (profile-table wedgedata))
+ (when (typep (rotation wdg-object) 'single-float)
+ ;; WDG-ROTATION is meaningless if WEDGEDATA is NIL [no wedge].
+ ;; If WEDGEDATA is a WEDGE descriptor, ROTATION slot of WDG-OBJECT
+ ;; can be a SINGLE-FLOAT or might be NIL. Must test.
+ (setq wdg-rotation (rotation wdg-object)))))
+
+ ;; Terms of the Patient-to-Collimator transform, expanded inline
+ ;; and cached since they are used in innermost loops.
+ (let ((trn-rad (* (the single-float (couch-angle bm))
+ #.(coerce (/ pi 180.0d0) 'single-float)))
+ (col-rad (* (the single-float (collimator-angle bm))
+ #.(coerce (/ pi 180.0d0) 'single-float))))
+ (declare (type single-float trn-rad col-rad))
+ (setq sin-t (sin trn-rad)
+ cos-t (cos trn-rad)
+ sin-c (sin col-rad)
+ cos-c (cos col-rad)))
+
+ ;; Will multiply in TRAYFACTOR [if /= 1.0] and OUTPUTFACTOR later.
+ (setq cal*atten*trayfactor*of
+ (* (the single-float
+ (cal-factor dosedata)) ;cGy per MU at iso - usually 1.0
+ (the single-float
+ (atten-factor bm)))) ;Per-beam dosimetrist-provided atten
+
+ ;; COLL-COORDS methods [one for each collimator type] return portal
+ ;; vertices [must be non-empty list] and four place-holder zeros for an
+ ;; MLC and return NIL [non-MLC flag] and four portal rectangular
+ ;; coordinates for all rectangular collimators. PORTAL-VERTICES
+ ;; is used both to convey the MLC portal vertex list [an OPEN contour;
+ ;; first elem NOT repeated as last, and in GANTRY space] and as a
+ ;; multileaf/rectangular collimator flag.
+ (multiple-value-setq (portal-vertices xci- xci+ yci- yci+)
+ (coll-coords coll))
+
+ (cond
+ ((consp portal-vertices)
+ ;; MLC Portal vertices must be transformed from Gantry-space to
+ ;; Collimator-space, since they are defined with respect to the gantry
+ ;; rather than rotating with the collimator. Appropriate transformation
+ ;; is the INVERSE of the collimator rotation - rotate by negative of
+ ;; COLLIMATOR-ANGLE of BM. Vertex coords are as projected onto the
+ ;; isocenter plane, so Z component is zero and are AS SEEN BY THE
+ ;; COLLIMATOR - that is, points which are defined with respect to
+ ;; GANTRY space appear to rotate backwards in COLLIMATOR space as the
+ ;; collimator rotates. We use these portal vertices for two things:
+ ;; MLC width WC derived from equivalent-square area, and MLC-OCR-Factor.
+ (setq portal-vertices
+ (mapcar #'(lambda (vert)
+ (let ((xp (first vert))
+ (yp (second vert)))
+ (declare (type single-float xp yp))
+ (list (+ (* cos-c xp) ;Portal-Vertex X-coord
+ (* sin-c yp))
+ (- (* cos-c yp) ;Portal-Vertex Y-coord
+ (* sin-c xp)))))
+ portal-vertices))
+
+ ;; WC defined by bounding box of MLC using 4A/P formula with
+ ;; [inversely] rotated PORTAL-VERTICES.
+ (let ((xlist (mapcar #'first portal-vertices))
+ (ylist (mapcar #'second portal-vertices)))
+ (let ((wid (- (the single-float (apply #'max xlist))
+ (the single-float (apply #'min xlist))))
+ (len (- (the single-float (apply #'max ylist))
+ (the single-float (apply #'min ylist)))))
+ (declare (type single-float wid len))
+ (setq wc (/ (* 2.0 wid len)
+ (+ wid len)))
+ (unless (> wc 0.0)
+ (error "COMPUTE-BEAM-DOSE [1] MLC WC (from 4A/P) = 0.0")))))
+
+ ;; PORTAL-VERTICES = NIL -> rectangular coll -> blocking allowed.
+ (t (let ((blk-list (coll:elements (blocks bm))))
+ (when (consp blk-list)
+ ;; Blocks actually used - multiply in TRAY-FACTOR from MACHINE
+ ;; object and call block-clipping function. Note that we include
+ ;; TRAY-FACTOR even if no CLIPPED-BLOCKS are in the beam portal.
+ (setq cal*atten*trayfactor*of
+ (* cal*atten*trayfactor*of
+ (the single-float (tray-factor mach))))
+
+ ;; Load args to CLIP-BLOCKS [fixed for duration of call].
+ (setf (aref arg-vec #.Argv-Xci-) xci-)
+ (setf (aref arg-vec #.Argv-Xci+) xci+)
+ (setf (aref arg-vec #.Argv-Yci-) yci-)
+ (setf (aref arg-vec #.Argv-Yci+) yci+)
+
+ (do ((blk) (subcontours)
+ (blks blk-list (cdr blks)))
+ ((null blks))
+
+ ;; ALL CLIPPING IS DONE AT THE ISOCENTER PLANE because this
+ ;; function is called in a dosepoint-independent manner.
+ ;;
+ ;; Set CLIPPED-BLOCKS to a LIST of items, one for each block
+ ;; whose intersection with portal is non-empty. Each item in
+ ;; list is a LIST consisting of the block object [needed by
+ ;; BLOCK-FACTOR] and subcontours representing intersection of
+ ;; the portal with a given block. A block when clipped may
+ ;; yield zero, one, or more subcontours.
+ ;;
+ ;; Each subcontour is a list of vertices [CCW traversal],
+ ;; each a sublist of X and Y collimator coords at isocenter.
+
+ (setq blk (car blks))
+ (when (consp (setq subcontours (vertices blk)))
+ ;; Only clip block if it has vertices.
+ (setq subcontours (clip-blocks subcontours arg-vec))
+ (when (consp subcontours)
+ ;; Only save result if clipped sub-block is non-empty.
+ (push (cons blk subcontours) clipped-blocks))))))
+
+ ;; WC is defined by jaws of rectangular collimator using 4A/P formula
+ ;; and actual portal dimensions in collimator frame, rotated with the
+ ;; collimator. COLL-WIDTH and COLL-LENGTH methods get
+ ;; portal dimensions for all rectangular collimator types.
+ (let ((wid (coll-width coll))
+ (len (coll-length coll)))
+ (declare (type single-float wid len))
+ (setq wc (/ (* 2.0 wid len)
+ (+ wid len)))
+ (unless (> wc 0.0)
+ (error "COMPUTE-BEAM-DOSE [2] VJC WC (from 4A/P) = 0.0")))))
+
+ (setq outputfactor (outputfactor-col coll wc dosedata)
+ cal*atten*trayfactor*of (* cal*atten*trayfactor*of outputfactor))
+
+ ARC-LOOP
+
+ (format t "~&~%Computing ~A dose for beam ~S (~D of ~D~A).~%"
+ (if pts "points" "grid") beam-name beam-num num-beams
+ (if (= num-arcs 0)
+ ""
+ (format nil ", Arc ~D of ~D" arc-num num-arcs)))
+
+ (setq dose-multiplier (* cal*atten*trayfactor*of arc-scale-factor))
+
+ (setq sin-g (sin gan-rad)
+ cos-g (cos gan-rad))
+
+ (setq pct-r0 (+ (* cos-c cos-g cos-t) ; r00
+ (* sin-c sin-t)))
+ (setq pct-r1 (- (* cos-c sin-g))) ; r01
+ (setq pct-r2 (- (* cos-c cos-g sin-t) ; r02
+ (* sin-c cos-t)))
+
+ (setq pct-r3 (- (* cos-c sin-t) ; r10
+ (* sin-c cos-g cos-t)))
+ (setq pct-r4 (* sin-c sin-g)) ; r11
+ (setq pct-r5 (- (+ (* sin-c cos-g sin-t) ; r12
+ (* cos-c cos-t))))
+
+ (setq pct-r6 (* sin-g cos-t)) ; r20
+ (setq pct-r7 cos-g) ; r21
+ (setq pct-r8 (* sin-g sin-t)) ; r22
+
+ ;; Compute SRC coordinates by transforming SOURCE-TO-ISOCENTER
+ ;; vector in collimator coords by COLL-TO-COUCH rotations.
+ (setq src-xp (+ (* cos-t sin-g sad) iso-xp))
+ (setq src-yp (+ (* cos-g sad) iso-yp))
+ (setq src-zp (+ (* sin-t sin-g sad) iso-zp))
+
+ ;; Load argument vector for call to PATHLENGTH-RAYTRACE. Source coords
+ ;; remain fixed for entire call to COMPUTE-BEAM-DOSE. Only DP-X, DP-Y,
+ ;; and DP-Z slots get reloaded as dosepoint changes from
+ ;; one call to next of BEAM-DOSE and PATHLENGTH-RAYTRACE.
+ (let ((scale-factor (/ #.Pathlength-Ray-Maxlength sad)))
+ (declare (type single-float scale-factor))
+ (setf (aref arg-vec #.Argv-Src-X) src-xp)
+ (setf (aref arg-vec #.Argv-Src-Y) src-yp)
+ (setf (aref arg-vec #.Argv-Src-Z) src-zp)
+ (setf (aref arg-vec #.Argv-Dp-X)
+ (+ src-xp (* scale-factor (- iso-xp src-xp))))
+ (setf (aref arg-vec #.Argv-Dp-Y)
+ (+ src-yp (* scale-factor (- iso-yp src-yp))))
+ (setf (aref arg-vec #.Argv-Dp-Z)
+ (+ src-zp (* scale-factor (- iso-zp src-zp)))))
+
+ ;; Find geometric distance from source to isocenter and to patient surface.
+ (let ((ray-alphalist
+ (pathlength-raytrace arg-vec organ-vertices-list organ-z-extents)))
+ (declare (type list ray-alphalist))
+ (unless (consp ray-alphalist)
+ (setf (ssd rslt) -1.0)
+ (setf (tpr-at-iso rslt) -1.0)
+ (sl:acknowledge
+ (format nil "Central-Axis is outside patient in beam ~S (~D of ~D)."
+ beam-name beam-num num-beams))
+ (return-from compute-beam-dose nil))
+ (setq iso-depth (- sad (the single-float (caar ray-alphalist)))))
+
+ (when (and (> num-arcs 0)
+ (< iso-depth 0.0))
+ ;; For Arc-Therapy the isocenter must be inside the patient
+ ;; for all beams in the arc. Set chart flag and punt if not.
+ (setf (ssd rslt) -1.0)
+ (setf (tpr-at-iso rslt) -1.0)
+ (sl:acknowledge
+ (format
+ nil
+ "Isocenter is outside patient in beam ~S (~D of ~D, Arc ~D of ~D)."
+ beam-name beam-num num-beams arc-num num-arcs))
+ (return-from compute-beam-dose nil))
+
+ (labels
+
+ ((beam-dose
+ ( )
+
+ ;; Returns the dose in cGy/MU at point (XP, YP, ZP) in patient
+ ;; coordinates, or equivalently point (XCD, YCD, ZCD) in collimator
+ ;; coordinates, with wedge described by WEDGEDATA [none if NIL],
+ ;; according to equivalent pathlength through anatomy represented
+ ;; by the ORGAN-xxx lists, using precomputed parameters that are not
+ ;; dependent on the point location. CLIPPED-BLOCKS is a list of
+ ;; lists, each a BEAM-BLOCK object followed by the subcontours
+ ;; produced by intersecting that block with the collimator's portal,
+ ;; all as projected to the isocenter plane. Each subcontour
+ ;; is a CCW-traversed clipped block outline. CCW-ness is essential.
+ ;;
+ ;; For rectangular collimators, XCI-, XCI+, YCI-, and YCI+ are portal
+ ;; coordinates in collimator system as projected onto isocenter plane
+ ;; [they don't change as collimator is rotated - they are properties
+ ;; of the COLLIMATOR, not of the GANTRY] and PORTAL-VERTICES is NIL.
+ ;;
+ ;; For MLCs, XCI- etc are dummy placeholders and PORTAL-VERTICES is
+ ;; the vertex list for the collimator - an open, non-empty contour.
+ ;; These vertices are properties of the PATIENT, not of the MLC leaf
+ ;; settings, and therefore they describe the portal as drawn on the
+ ;; anatomy rather than the leaf settings. As the collimator rotates,
+ ;; the portal vertices remain fixed [in GANTRY coordinates] and are
+ ;; approximated by changing leaf settings.
+ ;;
+ ;; Functionality implemented here is specified in
+ ;; Prism Dose Computation Methods, Version 1.2 Technical Report.
+ ;;
+ ;; Names of variables in the body of this function should correspond
+ ;; pretty closely to the names in the TR. See also TR Kalet et.al.
+ ;; Prism Implementation Report, version 1.2 [Except: SAD for F and
+ ;; XCI, XCD etc used for collimator coords - see comments above].
+
+ (let* ((xcd (aref arg-vec #.Argv-Xcd))
+ (ycd (aref arg-vec #.Argv-Ycd))
+ (m (- (the single-float (aref arg-vec #.Argv-Zcd))))
+ (f+m (+ sad m))
+ (divergence (/ f+m sad))
+ (inv-divergence (/ sad f+m))
+ (wd (* wc divergence)) ;Eq Sq Field Size at depth
+ (dpth (+ m iso-depth)) ;Depth of DP along CAX
+ (xci (* xcd inv-divergence)) ;DP proj onto isocenter
+ (yci (* ycd inv-divergence)) ;DP proj onto isocenter
+ ;; Arguments for call to PATHLENGTH-RAYTRACE: XP, YP, and ZP
+ ;; are loaded by call to BEAM-DOSE. Source coords loaded by
+ ;; initial call to PATHLENGTH-RAYTRACE before BEAM-DOSE-calling
+ ;; loop is entered. No args need be loaded now.
+ (ray-alphalist
+ (pathlength-raytrace arg-vec organ-vertices-list
+ organ-z-extents))
+ (equiv-pl 0.0))
+
+ (declare (type single-float xcd ycd m f+m divergence
+ inv-divergence wd dpth xci yci equiv-pl)
+ (type list ray-alphalist))
+
+ ;; If RAY-ALPHALIST is non-NIL, ray intersects body and we can
+ ;; integrate. If PATHLENGTH-INTEGRATE returns T, dosepoint is
+ ;; inside body. If either condition fails, dosepoint is outside
+ ;; and we return zero dose.
+ (cond
+ ((and (consp ray-alphalist)
+ (pathlength-integrate arg-vec ray-alphalist
+ organ-density-array :Heterogeneous))
+ (setq equiv-pl (aref arg-vec #.Argv-Return-1))
+
+ ;; DPTH should be always positive for dosepoints inside patient.
+ ;; Model works only if DPTH >= 0.0; for consistency with Prism1
+ ;; model, DPTH < 0.0 is treated as = 0.0 .
+ (when (< dpth 0.0)
+ (setq dpth 0.0))
+
+ (setf
+ (aref arg-vec #.Argv-Return-0)
+ (* inv-divergence ;Inverse-Square Factor
+ inv-divergence
+ ;; We dispatch on collimator type [via PORTAL-VERTICES]
+ ;; and presence of blocks in beam portal so as to do the
+ ;; fastest computation possible, with no run-time method
+ ;; dispatching, in this inner loop.
+ (the single-float
+ (cond
+ ((consp portal-vertices) ;Multileaf Collimator
+ ;; Spec requires that an MLC must have a non-empty
+ ;; portal vertex list, enabling this arg to be used
+ ;; as a flag to dispatch on collimator type.
+ (* (the single-float
+ (2d-lookup tpr-vector ;TPR Lookup.
+ wd dpth tpr-fss-ar tpr-dep-ar
+ tpr-fssmap tpr-depmap tpr-tbl-ar))
+
+ (the single-float ;MLC-OCR-Factor
+ (do ((v1-nodes portal-vertices (cdr v1-nodes))
+ (v1-node) (v2-nodes) (v2-node) (len-v1 0.0)
+ (len-v2 0.0) (v1x 0.0) (v1y 0.0) (v2x 0.0)
+ (v2y 0.0) (vjx 0.0) (vjy 0.0) (len-vj 0.0)
+ (perp-distance 0.0) (minrad 0.0))
+ ((null v1-nodes)
+
+ ;; Does portal enclose dosepoint?
+ (setf (aref arg-vec #.Argv-Enc-X) xci)
+ (setf (aref arg-vec #.Argv-Enc-Y) yci)
+ (unless (encloses? portal-vertices arg-vec)
+ ;; Distance POSITIVE inside and NEGATIVE
+ ;; outside portal. Subtract neg MINRAD
+ ;; from WC giving fan-line ratio > 1.0 .
+ (setq minrad (- minrad)))
+
+ ;; Find fan-line ratio as fractional
+ ;; half-beamwidth from dosept to nearest pt
+ ;; on collimator portal, scaled to iso plane.
+ (3d-lookup ;OCR Lookup.
+ ocr-vector
+ wc ;Field-Width [full]
+ dpth ;Surface -> dosept dist
+ ;; Fan-line ratio:
+ ;; > 1.0 outside, < 1.0 inside portal.
+ (/ (- wc (* 2.0 minrad)) wc)
+ ocr-fss-ar ocr-dep-ar ocr-fan-ar ocr-fssmap
+ ocr-depmap ocr-fanmap ocr-tbl-ar))
+
+ (declare (type single-float v1x v1y v2x v2y
+ len-v1 len-v2 vjx vjy
+ perp-distance len-vj minrad))
+
+ ;; V1-NODE and V2-NODE are (X Y) coord pairs of
+ ;; vertex at head of V1 and V2 vectors. V1X,
+ ;; V1Y, V2X, V2Y are X and Y coords of vectors
+ ;; V1 and V2 from dosepoint (XCI YCI) [projected
+ ;; on ISO plane] to verts V1-NODE and V2-NODE.
+ ;; VJ [variable not used] is vector from V1-NODE
+ ;; [vertex at tail] to V2-NODE [vertex at head].
+ ;; VJX and VJY are its X and Y coordinates.
+ (cond
+ ((eq v1-nodes portal-vertices)
+ ;; First time must compute everything. On
+ ;; successive iters we pass V2-values to V1.
+ (setq v1-node (car v1-nodes)
+ v1x (- (the single-float
+ (first v1-node))
+ xci)
+ v1y (- (the single-float
+ (second v1-node))
+ yci)
+ len-v1 (sqrt (the (single-float 0.0 *)
+ (+ (* v1x v1x)
+ (* v1y v1y))))
+ minrad len-v1))
+
+ (t (setq v1x v2x
+ v1y v2y
+ len-v1 len-v2)))
+
+ ;; PORTAL-VERTICES is an open CCW contour
+ ;; [first elem NOT repeated], so loop around
+ ;; to get last vertex.
+ (setq v2-nodes (or (cdr v1-nodes)
+ portal-vertices)
+ v2-node (car v2-nodes)
+ v2x (- (the single-float (first v2-node))
+ xci)
+ v2y (- (the single-float (second v2-node))
+ yci))
+
+ (setq len-v2 (sqrt (the (single-float 0.0 *)
+ (+ (* v2x v2x)
+ (* v2y v2y))))
+ vjx (- v2x v1x)
+ vjy (- v2y v1y)
+ len-vj (sqrt (the (single-float 0.0 *)
+ (+ (* vjx vjx)
+ (* vjy vjy)))))
+
+ (when (< len-v2 minrad)
+ (setq minrad len-v2))
+
+ (let ((v1-cross-vj (- (* v1x vjy)
+ (* v1y vjx))))
+ (declare (type single-float v1-cross-vj))
+ (setq perp-distance
+ (cond ((< len-vj 1.0e-5) len-v1)
+ ((< v1-cross-vj 0.0)
+ (/ (- v1-cross-vj) len-vj))
+ (t (/ v1-cross-vj len-vj)))))
+
+ (when (and (< (+ (* v1x vjx) ;V1-DOT-VJ
+ (* v1y vjy))
+ 0.0)
+ (> (+ (* v2x vjx) ;V2-DOT-VJ
+ (* v2y vjy))
+ 0.0)
+ (< perp-distance minrad))
+ (setq minrad perp-distance))))))
+
+ ;; Blocks in beam portal, and therefore must be a
+ ;; rectangular collimator. Compute Block-Factor.
+ (t (monus
+ (* (the single-float
+ (2d-lookup tpr-vector ;TPR Lookup.
+ wd dpth tpr-fss-ar tpr-dep-ar
+ tpr-fssmap tpr-depmap tpr-tbl-ar))
+
+ ;; Rectangular-Coll OCR Factor - X term.
+ (the single-float
+ (cond
+ ((>= xci 0.0)
+ ;; If XCI is positive, do OCR lookup with
+ ;; jaw on that side; full-width fan-line
+ ;; ratio is positive.
+ (3d-lookup ;OCR Lookup.
+ ocr-vector (* xci+ 2.0) dpth
+ (cond ((and (= xci 0.0) ;l'Hospital
+ (= xci+ 0.0))
+ 1.0)
+ ;; Edge on CAX, pt beyond.
+ ((= xci+ 0.0)
+ 2.0)
+ ;; Pt within portal ->
+ ;; OCR fanline meaningful.
+ (t (/ xci xci+)))
+ ocr-fss-ar ocr-dep-ar ocr-fan-ar
+ ocr-fssmap ocr-depmap ocr-fanmap
+ ocr-tbl-ar))
+
+ ;; XCI < 0.0 -> use XCI- jaw. XCI- is also
+ ;; negative [overcentering NOT ALLOWED], so
+ ;; multiplication by -2.0 makes full-width
+ ;; positive. Dividing negative XCI by
+ ;; negative XCI- makes fan-line ratio
+ ;; positive too.
+ (t (3d-lookup ;OCR Lookup.
+ ocr-vector (* xci- -2.0) dpth
+ ;; XCI = 0.0 case excluded by COND
+ ;; one level up from this. Edge on
+ ;; CAX, pt beyond.
+ (cond ((= xci- 0.0)
+ 2.0)
+ ;; Pt within portal.
+ (t (/ xci xci-)))
+ ocr-fss-ar ocr-dep-ar ocr-fan-ar
+ ocr-fssmap ocr-depmap ocr-fanmap
+ ocr-tbl-ar))))
+
+ ;; Rectangular-Coll OCR Factor - Y term. Same
+ ;; sign conventions apply: YCI, YCI-, and YCI+.
+ (the single-float
+ (cond
+ ((>= yci 0.0)
+ (3d-lookup ;OCR Lookup.
+ ocr-vector (* yci+ 2.0) dpth
+ (cond ((and (= yci 0.0) ;l'Hospital
+ (= yci+ 0.0))
+ 1.0)
+ ;; Edge on CAX, pt beyond.
+ ((= yci+ 0.0)
+ 2.0)
+ ;; Pt within portal.
+ (t (/ yci yci+)))
+ ocr-fss-ar ocr-dep-ar ocr-fan-ar
+ ocr-fssmap ocr-depmap ocr-fanmap
+ ocr-tbl-ar))
+
+ (t (3d-lookup ;OCR Lookup.
+ ocr-vector (* yci- -2.0) dpth
+ ;; YCI = 0.0 case excluded by COND
+ ;; one level up from this.
+ ;; Edge on CAX, pt beyond.
+ (cond ((= yci- 0.0)
+ 2.0)
+ ;; Pt within portal.
+ (t (/ yci yci-)))
+ ocr-fss-ar ocr-dep-ar ocr-fan-ar
+ ocr-fssmap ocr-depmap ocr-fanmap
+ ocr-tbl-ar)))))
+
+ ;; Subtract Block-Factor if blocks present.
+ (cond ((consp clipped-blocks)
+ ;; Load args to BLOCK-FACTOR.
+ (setf (aref arg-vec #.Argv-Xci) xci)
+ (setf (aref arg-vec #.Argv-Yci) yci)
+ (setf (aref arg-vec #.Argv-Depth) dpth)
+ (setf (aref arg-vec #.Argv-Div) divergence)
+ (block-factor)
+ (aref arg-vec #.Argv-Return-0))
+ (t 0.0))))))
+
+ ;; INHOMOGENEITY Factor
+ (the single-float
+ (/ (the single-float
+ (2d-lookup tpr-vector ;TPR Lookup.
+ wd equiv-pl tpr-fss-ar tpr-dep-ar
+ tpr-fssmap tpr-depmap tpr-tbl-ar))
+
+ (the single-float
+ (2d-lookup tpr-vector ;TPR Lookup.
+ wd
+ ;; Slant-height, surface to DP
+ (/ (* dpth
+ (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *)
+ (+ (* xcd xcd)
+ (* ycd ycd)
+ (* f+m f+m))))))
+ f+m)
+ tpr-fss-ar tpr-dep-ar tpr-fssmap
+ tpr-depmap tpr-tbl-ar))))
+
+ ;; WEDGE Factor.
+ (the single-float
+ (cond
+ ((null wedgedata) ;No wedge
+ 1.0) ;Unity transmission
+
+ ;; Alina's formula for Wedge CAF.
+ (t (* (+ (* wcaf-dep dpth) ;Depth dependence.
+ (* wcaf-fsz wc) ;Fieldsize dependence.
+ wcaf-con) ;Constant term.
+ (the single-float
+ (2d-lookup ;Wedge Profile Lookup.
+ wdg-vector
+ dpth
+ ;; Equality OK because wedge angles
+ ;; are EXACTLY one of these.
+ (cond
+ ((= wdg-rotation 0.0) yci)
+ ((= wdg-rotation 90.0) (- xci))
+ ((= wdg-rotation 180.0) (- yci))
+ ((= wdg-rotation 270.0) xci)
+ (t (error
+ "COMPUTE-BEAM-DOSE [3] Bad Wedge-Rot: ~S"
+ wdg-rotation)))
+ wdg-dep-ar wdg-pos-ar wdg-depmap wdg-posmap
+ wdg-tbl-ar)))))))))
+
+ ;; Dosepoint outside patient's body - return zero dose.
+ (t (setf (aref arg-vec #.Argv-Return-0) 0.0))))
+
+ ;; Return NIL so no flonum box need be allocated.
+ nil)
+
+ (block-factor
+ (&aux (opacity 0.0) (accum 0.0)
+ (xci (aref arg-vec #.Argv-Xci))
+ (yci (aref arg-vec #.Argv-Yci))
+ (dpth (aref arg-vec #.Argv-Depth))
+ (divergence (aref arg-vec #.Argv-Div)))
+
+ ;; Returns summed block factor for rectangular collimator at dosepoint
+ ;; (XCI YCI), at depth DPTH, using DIVERGENCE factor from isocenter
+ ;; plane to dosepoint plane.
+ (declare (type single-float xci yci dpth divergence opacity accum))
+
+ (dolist (blk clipped-blocks)
+
+ ;; Sector-Integration routine.
+ ;;
+ ;; Note that a single block may give rise to multiple sublists
+ ;; [subcontours] in that block's element in CLIPPED-BLOCKS, because
+ ;; clipping of a block contour to the portal can produce
+ ;; more than one disjoint clipped subcontours.
+ ;;
+ ;; Those blocks totally outside the portal, of course, give rise
+ ;; to no clipped contours, and therefore entries corresponding
+ ;; to them are absent in CLIPPED-BLOCKS.
+ ;;
+ ;; NB: ALL computations done in sector integration are projected
+ ;; onto ISOCENTER plane, with sole exception of the radial argument
+ ;; used in the SPR lookup, which is scaled by DIVERGENCE
+ ;; to be projected onto the DOSEPOINT plane.
+ ;;
+ ;; (CAR BLK) is the beam block object.
+ (setq opacity (- 1.0 (the single-float (transmission (car blk)))))
+
+ ;; (CDR BLK) is list of subcontours [each CCW] for clipped block.
+ (dolist (subcontour (cdr blk))
+
+ (let ((minrad 0.0)
+ (block-scatter 0.0))
+
+ (declare (type single-float minrad block-scatter))
+
+ (do ((v1-nodes subcontour (cdr v1-nodes))
+ (v1-node) (v2-nodes) (v2-node) (len-v1 0.0) (len-v2 0.0)
+ (v1x 0.0) (v1y 0.0) (v2x 0.0) (v2y 0.0) (num-sectors 0)
+ (vjx 0.0) (vjy 0.0) (len-vj 0.0) (v1-cross-vj 0.0)
+ (v1-dot-vj 0.0) (perp-distance 0.0) (theta-j 0.0)
+ (theta-per-sector 0.0))
+ ((null v1-nodes))
+
+ (declare (type single-float v1x v1y v2x v2y len-v1 len-v2
+ theta-j vjx vjy theta-per-sector v1-cross-vj
+ len-vj v1-dot-vj perp-distance)
+ (type fixnum num-sectors))
+
+ ;; V1-NODE and V2-NODE are (X Y) coord pairs of the vertex
+ ;; at head of V1 and V2 vectors, respectively. V1X, V1Y, V2X,
+ ;; V2Y are X and Y coords of vectors V1 and V2 from dosepoint
+ ;; (XCI YCI) to vertices V1-NODE and V2-NODE. VJ [not used]
+ ;; is vector from V1-NODE [vertex at tail] to V2-NODE [vertex
+ ;; at head]. VJX and VJY are its X and Y coordinates.
+ (cond ((eq v1-nodes subcontour)
+ ;; First time must compute everything. On successive
+ ;; iterations we can pass V2-values back to V1.
+ (setq v1-node (car v1-nodes)
+ v1x (- (the single-float (first v1-node)) xci)
+ v1y (- (the single-float (second v1-node)) yci)
+ len-v1 (sqrt (the (single-float 0.0 *)
+ (+ (* v1x v1x)
+ (* v1y v1y))))
+ minrad len-v1))
+ (t (setq v1x v2x
+ v1y v2y
+ len-v1 len-v2)))
+
+ ;; SUBCONTOUR is an open CCW contour - first element NOT
+ ;; repeated. Loop back to get closing last element.
+ (setq v2-nodes (or (cdr v1-nodes) subcontour)
+ v2-node (car v2-nodes)
+ v2x (- (the single-float (first v2-node)) xci)
+ v2y (- (the single-float (second v2-node)) yci))
+
+ (setq len-v2 (sqrt (the (single-float 0.0 *)
+ (+ (* v2x v2x)
+ (* v2y v2y))))
+ vjx (- v2x v1x)
+ vjy (- v2y v1y)
+ len-vj (sqrt (the (single-float 0.0 *)
+ (+ (* vjx vjx)
+ (* vjy vjy))))
+ v1-cross-vj (- (* v1x vjy)
+ (* v1y vjx))
+ v1-dot-vj (+ (* v1x vjx)
+ (* v1y vjy)))
+
+ (when (< len-v2 minrad)
+ (setq minrad len-v2))
+
+ (setq perp-distance (cond ((< len-vj 1.0e-5) len-v1)
+ ((< v1-cross-vj 0.0)
+ (/ (- v1-cross-vj) len-vj))
+ (t (/ v1-cross-vj len-vj))))
+
+ (when (and (< v1-dot-vj 0.0)
+ (> (+ (* v2x vjx) ;V2-DOT-VJ
+ (* v2y vjy))
+ 0.0)
+ (< perp-distance minrad))
+ (setq minrad perp-distance))
+
+ ;; THETA-J and THETA-PER-SECTOR are always POSITIVE.
+ (setq theta-j (the single-float
+ (abs (the single-float
+ (atan (- (* v1x v2y) ;V1-CROSS-V2
+ (* v1y v2x))
+ (+ (* v1x v2x) ;V1-DOT-V2
+ (* v1y v2y)))))))
+
+ ;; If segment is degenerate, the contribution of this sector
+ ;; to integral is zero. Thresholds are experimental.
+ (unless (or (< len-v1 1.0e-5)
+ (< len-v2 1.0e-5)
+ (< len-vj 1.0e-5)
+ (< theta-j 1.0e-6)
+ (< perp-distance 1.0e-5))
+
+ ;; Experiment with the 1 and 10.0d0 here. We currently
+ ;; use min of 1 sector per seg, each at most 10.0 degrees
+ ;; pie-width angle.
+ (setq num-sectors
+ (the fixnum
+ (ceiling theta-j #.(coerce (* pi (/ 10.0d0 180.0d0))
+ 'single-float)))
+ theta-per-sector (/ theta-j
+ (coerce num-sectors
+ 'single-float)))
+
+ (do ((psi (+ (- #.(coerce pi 'single-float)
+ (the single-float
+ (abs (the single-float
+ (atan v1-cross-vj v1-dot-vj)))))
+ (* 0.5 theta-per-sector))
+ (+ psi theta-per-sector))
+ (sector-scatter 0.0)
+ (cnt num-sectors (the fixnum (1- cnt))))
+ ((= cnt 0)
+ ;; SECTOR-SCATTER is always non-negative; thus
+ ;; BLOCK-SCATTER should be INCREMENTED for CCW
+ ;; integration and DECREMENTED for CW integration.
+ (when (< v1-cross-vj 0.0)
+ (setq theta-per-sector (- theta-per-sector)))
+ (incf block-scatter
+ (* sector-scatter theta-per-sector)))
+
+ (declare (type single-float psi sector-scatter)
+ (type fixnum cnt))
+
+ ;; Radial argument for SPR lookup is as projected
+ ;; to DOSEPOINT plane; therefore, we scale radius
+ ;; by DIVERGENCE.
+ (incf sector-scatter ;SECTOR-SCATTER always non-negative.
+ (the single-float
+ (2d-lookup ;SPR Lookup.
+ spr-vector
+ (* (/ perp-distance (sin psi)) divergence)
+ dpth spr-rad-ar spr-dep-ar spr-radmap
+ spr-depmap spr-tbl-ar))))))
+
+ ;; Normalize by 1/2*PI and inline ABS; BLOCK-SCATTER is
+ ;; always non-negative but result of sector integration may
+ ;; be negative if integration proceeded in CW orientation.
+ ;; BLOCK-SCATTER should always be positive.
+ (setq block-scatter (* #.(coerce (/ 1.0d0 (* 2.0d0 pi))
+ 'single-float)
+ (if (>= block-scatter 0.0)
+ block-scatter
+ (- block-scatter))))
+
+ ;; Does closest subcontour enclose dosepoint? Don't test if
+ ;; MINRAD is "near" 0.0 - meaningless.
+ (setf (aref arg-vec #.Argv-Enc-X) xci)
+ (setf (aref arg-vec #.Argv-Enc-Y) yci)
+ (unless (encloses? subcontour arg-vec)
+ ;; Radius is POSITIVE inside and NEGATIVE outside subcontour.
+ (setq minrad (- minrad)))
+
+ (let* ((x-edge (cond ((> xci 0.0) xci+) ;Use upper jaw.
+ ((< xci 0.0) xci-) ;Use lower jaw.
+ ;; DP on axis and upper jaw closer.
+ ((< xci+ (- xci-)) xci+)
+ (t xci-))) ;Use lower jaw.
+ ;; Use same procedure to choose closer jaw in Y direc.
+ (y-edge (cond ((> yci 0.0) yci+)
+ ((< yci 0.0) yci-)
+ ((< yci+ (- yci-))
+ yci+)
+ (t yci-)))
+ ;; Now choose jaw closer to DP.
+ (x-dist (the single-float (abs (- xci x-edge))))
+ (y-dist (the single-float (abs (- yci y-edge))))
+ ;; WN is the field-size HALF-WIDTH, ie, the distance
+ ;; from central axis to collimator jaw on same side as
+ ;; dosepoint, using whichever jaw is closer, or average
+ ;; distance if dosepoint is equidistant from both jaws.
+ (wn (cond ((< x-dist y-dist)
+ ;; X- or X+ jaw closer - use closer X jaw.
+ (the single-float (abs x-edge)))
+ ((< y-dist x-dist)
+ ;; Y- or Y+ jaw closer - use closer Y jaw.
+ (the single-float (abs y-edge)))
+ (t (* 0.5 ;No diff - use average distance.
+ (+ (the single-float (abs x-edge))
+ (the single-float (abs y-edge))))))))
+
+ (declare (type single-float x-edge y-edge x-dist y-dist wn))
+
+ ;; NB: We use a separate table for TPR at zero field size
+ ;; because the TPR0 table is based on circular fields and
+ ;; the TPR table is based on square fields.
+ ;;
+ ;; If dosepoint is more than 1/10 half-width OUTSIDE block
+ ;; shadow, use SCATTER component for PRIMARY. [See AA below.]
+ ;;
+ ;; Otherwise approximate PRIMARY component by treating block
+ ;; edge as a virtual collimator edge and do appropriate OCR
+ ;; lookup with WN to define field width and fan line.
+ (incf accum
+ (the single-float
+ (* opacity
+ (+ (* (the single-float
+ (1d-lookup ;TPR0 Lookup
+ tpr0-vector dpth tpr0-dep-ar
+ tpr0-depmap tpr0-tbl-ar))
+ (cond ((< minrad (* -0.1 wn))
+ ;; See note AA above.
+ block-scatter)
+ ;; See note BB above.
+ (t (the single-float
+ (3d-lookup ;OCR Lookup.
+ ocr-vector (* 2.0 wn) dpth
+ (cond ((= wn 0.0)
+ 1.0)
+ (t (/ (- wn minrad) wn)))
+ ocr-fss-ar ocr-dep-ar ocr-fan-ar
+ ocr-fssmap ocr-depmap ocr-fanmap
+ ocr-tbl-ar)))))
+ ;; SCATTER component from sector integration.
+ block-scatter))))))))
+
+ ;; Pass return value in ARG-VEC.
+ (setf (aref arg-vec #.Argv-Return-0) accum)
+
+ ;; Return NIL so no flonum box need be allocated.
+ nil))
+
+ ;; End of LABELS internal function definitions.
+
+ (cond
+ ((consp pts) ;Compute either Point doses or Grid doses, not both.
+ (do ((input-pts pts (cdr input-pts))
+ (output-pts (points rslt) (cdr output-pts))
+ (pt))
+ ((null input-pts))
+ (setq pt (car input-pts)) ;PT is a MARK object.
+ (let ((xp (x pt))
+ (yp (y pt))
+ (zp (z pt)))
+ (declare (type single-float xp yp zp))
+ (let ((xpi (- xp iso-xp))
+ (ypi (- yp iso-yp))
+ (zpi (- zp iso-zp)))
+ (declare (type single-float xpi ypi zpi))
+ (let ((scale-factor
+ (/ #.Pathlength-Ray-Maxlength
+ (setf (aref arg-vec #.Argv-Raylen)
+ (3d-distance src-xp src-yp src-zp xp yp zp)))))
+ (declare (type single-float scale-factor))
+ (setf (aref arg-vec #.Argv-Dp-X)
+ (+ src-xp (* scale-factor (- xp src-xp))))
+ (setf (aref arg-vec #.Argv-Dp-Y)
+ (+ src-yp (* scale-factor (- yp src-yp))))
+ (setf (aref arg-vec #.Argv-Dp-Z)
+ (+ src-zp (* scale-factor (- zp src-zp))))
+ (setf (aref arg-vec #.Argv-Xcd)
+ (+ (* pct-r0 xpi)
+ (* pct-r1 ypi)
+ (* pct-r2 zpi)))
+ (setf (aref arg-vec #.Argv-Ycd)
+ (+ (* pct-r3 xpi)
+ (* pct-r4 ypi)
+ (* pct-r5 zpi)))
+ (setf (aref arg-vec #.Argv-Zcd)
+ (+ (* pct-r6 xpi)
+ (* pct-r7 ypi)
+ (* pct-r8 zpi)))
+
+ (beam-dose)
+
+ (cond ((= num-arcs 0) ;Regular Beam.
+ (setf (car output-pts)
+ (* dose-multiplier
+ (the single-float
+ (aref arg-vec #.Argv-Return-0)))))
+ (t (incf (the single-float (car output-pts)) ;Arc-Th.
+ (* dose-multiplier
+ (the single-float
+ (aref arg-vec #.Argv-Return-0)))))))))))
+
+ (t (let* ((nx (x-dim gg))
+ (ny (y-dim gg))
+ (nz (z-dim gg))
+ (xp-step (/ (the single-float (x-size gg))
+ (coerce (the fixnum (1- nx)) 'single-float)))
+ (yp-step (/ (the single-float (y-size gg))
+ (coerce (the fixnum (1- ny)) 'single-float)))
+ (zp-step (/ (the single-float (z-size gg))
+ (coerce (the fixnum (1- nz)) 'single-float)))
+ (dose-array (grid rslt))) ;Use pre-made, pre-sized array
+
+ (declare (type single-float xp-step yp-step zp-step)
+ (type (simple-array single-float 3) dose-array)
+ (type fixnum nx ny nz))
+
+ (when (and (> num-arcs 0) ;Doing Arc-Th.
+ (= arc-num 0)) ;Zero-th iter.
+ ;; Arc-Therapy: must initialize DOSE-ARRAY and accumulate dose,
+ ;; Initialize ONLY on zero-th iteration and when doing Arc-Th.
+ (do ((x-idx 0 (the fixnum (1+ x-idx))))
+ ((= x-idx nx))
+ (declare (type fixnum x-idx))
+ (do ((y-idx 0 (the fixnum (1+ y-idx))))
+ ((= y-idx ny))
+ (declare (type fixnum y-idx))
+ (do ((z-idx 0 (the fixnum (1+ z-idx))))
+ ((= z-idx nz))
+ (declare (type fixnum z-idx))
+ (setf (aref dose-array x-idx y-idx z-idx) 0.0)))))
+
+ (do ((x-idx 0 (the fixnum (1+ x-idx)))
+ (xp (x-origin gg) (+ xp xp-step))
+ (y-orig (y-origin gg))
+ (z-orig (z-origin gg))
+ (xpi 0.0) (ypi 0.0) (zpi 0.0)
+ (xpi-r0 0.0) (xpi-r3 0.0) (xpi-r6 0.0)
+ (ypi-r1 0.0) (ypi-r4 0.0) (ypi-r7 0.0))
+ ((= x-idx nx))
+
+ (declare (type single-float xp xpi ypi zpi xpi-r0 xpi-r3
+ xpi-r6 ypi-r1 ypi-r4 ypi-r7 y-orig z-orig)
+ (type fixnum x-idx))
+
+ ;; Progress report every outermost iteration. For Arc-Therapy,
+ ;; this prints beam iteration number as zero through NUM-ARCS.
+ (cond
+ ((= num-arcs 0)
+ (format t "~&Beam ~D of ~D, Plane ~D of ~D.~%"
+ beam-num num-beams (the fixnum (1+ x-idx)) nx))
+ (t (format t
+ "~&Beam ~D of ~D, Arc ~D of ~D, Plane ~D of ~D.~%"
+ beam-num num-beams arc-num num-arcs
+ (the fixnum (1+ x-idx)) nx)))
+
+ (setq xpi (- xp iso-xp)
+ xpi-r0 (* pct-r0 xpi)
+ xpi-r3 (* pct-r3 xpi)
+ xpi-r6 (* pct-r6 xpi))
+
+ (do ((y-idx 0 (the fixnum (1+ y-idx)))
+ (yp y-orig (+ yp yp-step)))
+ ((= y-idx ny))
+ (declare (type single-float yp)
+ (type fixnum y-idx))
+ (setq ypi (- yp iso-yp)
+ ypi-r1 (* pct-r1 ypi)
+ ypi-r4 (* pct-r4 ypi)
+ ypi-r7 (* pct-r7 ypi))
+
+ (do ((z-idx 0 (the fixnum (1+ z-idx)))
+ (zp z-orig (+ zp zp-step))
+ (scale-factor 0.0))
+ ((= z-idx nz))
+ (declare (type single-float zp scale-factor)
+ (type fixnum z-idx))
+ (setq zpi (- zp iso-zp))
+
+ ;; Load args for BEAM-DOSE and PATHLENGTH-RAYTRACE.
+ (setq scale-factor (/ #.Pathlength-Ray-Maxlength
+ (setf (aref arg-vec #.Argv-Raylen)
+ (3d-distance src-xp src-yp
+ src-zp xp yp zp))))
+
+ (setf (aref arg-vec #.Argv-Dp-X)
+ (+ src-xp (* scale-factor (- xp src-xp))))
+ (setf (aref arg-vec #.Argv-Dp-Y)
+ (+ src-yp (* scale-factor (- yp src-yp))))
+ (setf (aref arg-vec #.Argv-Dp-Z)
+ (+ src-zp (* scale-factor (- zp src-zp))))
+
+ ;; Load rest of arg vector for call to BEAM-DOSE.
+ ;; The math is the Pat-to-Coll transform.
+ (setf (aref arg-vec #.Argv-Xcd)
+ (+ xpi-r0 ypi-r1 (* pct-r2 zpi)))
+ (setf (aref arg-vec #.Argv-Ycd)
+ (+ xpi-r3 ypi-r4 (* pct-r5 zpi)))
+ (setf (aref arg-vec #.Argv-Zcd)
+ (+ xpi-r6 ypi-r7 (* pct-r8 zpi)))
+
+ (beam-dose)
+
+ (cond
+ ((= num-arcs 0) ;Regular Beam.
+ (setf (aref dose-array x-idx y-idx z-idx)
+ (* dose-multiplier
+ (the single-float
+ (aref arg-vec #.Argv-Return-0)))))
+ ;; Arc-Therapy.
+ (t (incf (the single-float
+ (aref dose-array x-idx y-idx z-idx))
+ (* dose-multiplier
+ (the single-float
+ (aref arg-vec #.Argv-Return-0))))))))))))
+
+ ;; Compute TPR-AT-ISO for each beam. For Arc-Therapy, average values
+ ;; weighted by ARC-SCALE-FACTOR; for regular beam, compute single value.
+ (setq tpr- at -iso
+ (cond
+ ((< iso-depth 0.0)
+ ;; If isocenter is in front of patient, return a negative
+ ;; value as flag for chart to print message "EXTEND".
+ -1.0)
+
+ ;; Otherwise [normal case], TPR Lookup minus Block-Factor
+ ;; if blocks are used.
+ (t (monus
+ (2d-lookup tpr-vector ;TPR Lookup.
+ wc iso-depth tpr-fss-ar tpr-dep-ar
+ tpr-fssmap tpr-depmap tpr-tbl-ar)
+ (cond ((consp clipped-blocks)
+ ;; Load args to BLOCK-FACTOR. CLIPPED-BLOCKS
+ ;; is passed via lexical environment.
+ (setf (aref arg-vec #.Argv-Xci) 0.0)
+ (setf (aref arg-vec #.Argv-Yci) 0.0)
+ (setf (aref arg-vec #.Argv-Depth) iso-depth)
+ (setf (aref arg-vec #.Argv-Div) 1.0)
+ (block-factor)
+ (aref arg-vec #.Argv-Return-0))
+ (t 0.0))))))
+
+ (cond
+ ((= arc-num 0) ;Static beam or initial iter of Arc-Therapy.
+ ;; For arc-therapy, store SSD computed from ISO-DEPTH on initial
+ ;; iteration [starting beam]. ISO-DEPTH must be >= zero.
+ ;; EQUIV-SQUARE, OUTPUT-COMP don't depend on position within arc.
+ ;;
+ ;; For regular beam, ISO-DEPTH < 0 means SSD > SAD. This is OK.
+ ;; For Arc-Therapy it is not, but we exit early in this case.
+ (setf (ssd rslt) (- sad iso-depth))
+ (setf (equiv-square rslt)
+ (inv-outputfactor coll wc outputfactor dosedata))
+ (setf (output-comp rslt) outputfactor)
+ (cond ((= num-arcs 0) ;Regular Beam.
+ (setf (tpr-at-iso rslt) tpr- at -iso))
+ ;; Arc-Therapy, initial iteration.
+ (t (setq avg-tpr- at -iso (* arc-scale-factor tpr- at -iso))
+ ;; ARC-SCALE-FACTOR was 1/2 of normal value for initial
+ ;; iter. Double it for all the middle iterations.
+ (setq arc-scale-factor (* arc-scale-factor 2.0))
+ (incf gan-rad arc-sz)
+ (setq arc-num (the fixnum (1+ arc-num)))
+ (go ARC-LOOP))))
+
+ ((< arc-num num-arcs) ;Arc-Therapy, middle iterations
+ (incf avg-tpr- at -iso (* arc-scale-factor tpr- at -iso))
+ (incf gan-rad arc-sz)
+ (setq arc-num (the fixnum (1+ arc-num)))
+ (when (= arc-num num-arcs)
+ ;; Halve ARC-SCALE-FACTOR for upcoming last iteration.
+ (setq arc-scale-factor (* arc-scale-factor 0.5)))
+ (go ARC-LOOP))
+
+ (t (setf (tpr-at-iso rslt) ;Arc-Therapy, last iteration
+ (+ avg-tpr- at -iso (* arc-scale-factor tpr- at -iso)))))))
+
+ ;; Return T if computation completes successfully. If something goes wrong,
+ ;; function returns early with NIL indicating failure. Return value sets
+ ;; VALID-POINTS/VALID-GRID flags on return.
+ t)
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/beam-graphics.cl b/prism/src/beam-graphics.cl
new file mode 100644
index 0000000..be0f6fa
--- /dev/null
+++ b/prism/src/beam-graphics.cl
@@ -0,0 +1,480 @@
+;;;
+;;; beam-graphics
+;;;
+;;; code for drawing beam portals in various views - includes code to
+;;; project portals from the collimator coordinate system to the view
+;;; plane, to clip them, and then to draw them.
+;;;
+;;; 18-Sep-1992 I. Kalet created from old prism files
+;;; 02-Dec-1992 J. Unger eliminate table keyword param from draw
+;;; method - use slot in beam, modify project-portal to eliminate
+;;; radian-degree problems.
+;;; 14-Dec-1992 J. Unger modify draw method to operate on view's foreground
+;;; display list, move beam-view-mediator definition and init-instance here.
+;;; 29-Dec-1992 J. Unger change angles to degrees, extend draw method
+;;; for beams into views to work for sag/cor views as well as
+;;; transverse views.
+;;; 08-Jan-1993 J. Unger add 'mag' back into project portal; warning
+;;; msg below.
+;;; 20-Jan-1993 J. Unger modify logic of bev init-inst after method
+;;; and destroy method to handle bev and non-bev's correctly. added
+;;; primary-beam macro.
+;;; 15-Feb-1993 I. Kalet get src-to-center from therapy-machine for
+;;; the beam being drawn. Also, update color attributes in primitives
+;;; when redrawing.
+;;; 11-Apr-1993 I. Kalet modify draw method for bev, since
+;;; beams-eye-view has ref. to beam, not copies of parameters. Delete
+;;; primary-beam macro - eq does it now.
+;;; 5-Sep-1993 I. Kalet move beam-view-mediator code to beam-mediators
+;;; 07-Mar-1994 D. Nguyen modify project-portal to accept a beam transform
+;;; and add get-transverse-beam-transform.
+;;; 28-Mar-1994 J. Unger split off part of get-beam-transform for bev's
+;;; into a function called make-col-pat-xfm, which can be used
+;;; elsewhere.
+;;; 18-Apr-1994 I. Kalet revised for new def. of view origin.
+;;; 17-May-1994 I. Kalet modify project-portal to handle contours that
+;;; do not repeat the first point as the last. Also use collimator
+;;; angle of 0.0 for multileaf collimator portals.
+;;; 3-Jun-1994 I. Kalet draw blocks if any along with beam portal.
+;;; Check if the block has vertices before attempting to draw it.
+;;; 23-Jun-1994 J. Unger add code to draw beam's isocenter and central
+;;; axis in views.
+;;; 07-Jul-1994 J. Unger fixup wedge drawing code.
+;;; 12-Jul-1994 J. Unger move compute-tics & supporting code to misc module.
+;;; 27-Jul-1994 J. Unger fix bug in interpolate-x-y (replace 'eq' w/ '=').
+;;; 24-Aug-1994 J. Unger fix bug where mlc wedge wouldn't rotate in
+;;; orthogonal views.
+;;; 26-Aug-1994 J. Unger make same fix as 8/24 for other beams in bev.
+;;; 18-Sep-1994 J. Unger blocks displayed in their own colors, primary bev
+;;; beams displayed with small distinguishing marks at vertices.
+;;; 03-Oct-1994 J. Unger display central axis only when display-axis attrib
+;;; is true.
+;;; 03-Oct-1994 J. Unger display beam portals as dashed lines, other beam
+;;; accoutrements as solid lines.
+;;; 04-Oct-1994 J. Unger move find-dashed-color to misc module.
+;;; 10-Oct-1994 J. Unger ensure beam & related graphics drawn correctly
+;;; in bev where the beam is not the primary bev beam.
+;;; 12-Jan-1995 I. Kalet remove proclaim form, use isodist function.
+;;; Use table-position from views not from beams.
+;;; 5-Sep-1995 I. Kalet change some macros to functions, add
+;;; declarations for fast arithmetic, eliminate some local variables,
+;;; use pix-x and pix-y, eliminate get-col-pat-transform since it is
+;;; the same as get-transverse-beam-transform at z = 0.0, rewrite
+;;; scale-and-clip-lines for efficiency.
+;;; 8-Oct-1996 I. Kalet split off get-beam-transform methods into
+;;; beam-transforms module, split off block drawing and wedge drawing
+;;; to beam-block-graphics and wedge-graphics, but still draw the
+;;; wedge with the beam here. Consolidate drawing of primary beam
+;;; portal, moved almost all stuff particular to beams-eye-views,
+;;; including marker constants, to bev-graphics module. Put package
+;;; name on find-dashed-color, now in SLIK. Move clipping code to
+;;; pixel-graphics to remove circularity with wedge-graphics. Move
+;;; get-segments-prim and get-rectangles-prim to view-graphics.
+;;; 5-Dec-1996 I. Kalet don't generate new graphic primitives if
+;;; color is sl:invisible.
+;;; 24-Jan-1997 I. Kalet portal function returns only vertices, not
+;;; contour object.
+;;; 1-Mar-1997 I. Kalet update calls to nearly- functions.
+;;; 03-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx.
+;;; 20-Jan-1998 I. Kalet change to array instead of multiple values
+;;; for beam transforms, add lots of declarations.
+;;; 21-Apr-1999 I. Kalet change sl:invisible to 'sl:invisible
+;;; 23-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 23-Oct-1999 I. Kalet preserve declutter information if beam was
+;;; already in view - the visible attribute of the graphic prim.
+;;; 20-Sep-2002 I. Kalet punt on oblique view and room view
+;;; 22-Jun-2007 I. Kalet take out inappropriate locally declare in macros
+;;; 25-May-2009 I. Kalet remove room-view stub method for draw function
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------
+
+(defconstant *central-axis-tic-length* 8)
+(defconstant *isocenter-radius* 8)
+(defconstant *ray-distance* 1000.0)
+(defconstant *z-tol* 0.1)
+
+;;;----------------------------------------------
+
+(defmacro interpolate-x-y (x1 y1 z1 x2 y2 z2 xp yp zp cut-ratio)
+
+ "interpolate-x-y x1 y1 z1 x2 y2 z2 xp yp zp
+
+calculate (and setf) the value of xp and yp, given the line segment
+from (x1,y1,z1) to (x2,y2,z2), with z1 <= zp <= z2"
+
+ `(setf ,cut-ratio (if (= ,z1 ,z2) 0.0
+ (/ (- ,zp ,z1) (- ,z2 ,z1)))
+ ,xp (+ ,x1 (* ,cut-ratio (- ,x2 ,x1)))
+ ,yp (+ ,y1 (* ,cut-ratio (- ,y2 ,y1)))))
+
+;;;----------------------------------------------
+
+(defun project-x-y (x y x-src y-src mag)
+
+ "project-x-y x y x-src y-src mag
+
+given an orgin o (x-src, y-src) and a point p (x,y), return the
+point at the tip of vector (p-o) * mag."
+
+ (declare (single-float x y x-src y-src mag))
+ (list (+ x-src (* mag (- x x-src)))
+ (+ y-src (* mag (- y y-src)))))
+
+;;;----------------------------------------------
+
+(defmacro interpolate-and-project (xa ya za xc yc zc
+ xs ys cut-z z-mag cut-ratio)
+
+ "interpolate-and-project xa ya za xc yc zc xs ys cut-z z-mag
+
+interpolate the point between xa,ya,za and xc,yc,zc using cut-z
+and then return the end point of the vector from xs,ys to
+cut-x,cut-y using z-mag."
+
+ `(progn
+ (setf ,cut-ratio
+ (cond ((= ,za ,zc) 0.0) (t (/ (- ,cut-z ,za) (- ,zc ,za)))))
+ (project-x-y
+ (+ ,xa (* ,cut-ratio (- ,xc ,xa)))
+ (+ ,ya (* ,cut-ratio (- ,yc ,ya)))
+ ,xs ,ys ,z-mag)))
+
+;;;----------------------------------------------
+
+(defmacro ray-endpoint (x-src y-src cut-x cut-y tolerance ray-end-x)
+
+ `(cond
+ ((poly:nearly-equal ,cut-x ,x-src ,tolerance) ;; ray is vertical
+ (list ,x-src (+ ,y-src
+ (if (> ,cut-y ,y-src) *ray-distance*
+ (- *ray-distance*)))))
+ (t
+ (setf ,ray-end-x (+ ,x-src
+ (if (> ,cut-x ,x-src) *ray-distance*
+ (- *ray-distance*))))
+ (list ,ray-end-x
+ (+ ,y-src (* (/ (- ,cut-y ,y-src) (- ,cut-x ,x-src))
+ (- ,ray-end-x ,x-src)))))))
+
+;;;----------------------------------------------
+
+(defun lt (a b)
+
+ (declare (single-float a b))
+ (if (>= b 0.0) (<= a b) (> a b)))
+
+;;;----------------------------------------------
+
+(defconstant *pc-tolerance* 0.99)
+(defconstant *pc-mini-tolerance* .001)
+(defconstant *pc-z-mag* 2.0)
+
+;;;----------------------------------------------
+
+(defun project-contour (pt-list src-x src-y src-z)
+
+ "project-contour pt-list src
+
+Local procedure to do the projection when the source point is
+NOT in the projection plane."
+
+ (declare (single-float src-x src-y src-z))
+ (let* ((prev nil)
+ (next nil)
+ (remainder pt-list)
+ (a-bit-less-than-z (* src-z *pc-tolerance*))
+ (cut-z (* src-z 0.5))
+ (mag-ok (not (poly:nearly-equal cut-z 0.0 *pc-mini-tolerance*)))
+ (xc 0.0) (yc 0.0) (zc 0.0)
+ (cut-ratio 1.0)
+ (out-list nil))
+ (declare (single-float cut-ratio xc yc zc cut-z a-bit-less-than-z))
+ (dolist (pt pt-list)
+ (setq remainder (rest remainder)
+ next (first remainder)
+ xc (first pt)
+ yc (second pt)
+ zc (third pt))
+ (if (lt zc a-bit-less-than-z)
+ ;;then -- z of contour point < z of source -- simple
+ (push (project-x-y xc yc src-x src-y
+ (/ src-z (- src-z zc)))
+ out-list)
+ ;;else -- z of contour point >= z of source -- tricky
+ (when mag-ok
+ (progn
+ ;; previous point
+ (when (and prev (lt (third prev) a-bit-less-than-z))
+ (push (interpolate-and-project
+ (the single-float (first prev))
+ (the single-float (second prev))
+ (the single-float (third prev))
+ xc yc zc src-x src-y cut-z
+ *pc-z-mag* cut-ratio)
+ out-list))
+ ;; next point
+ (when (and next (lt (third next) a-bit-less-than-z))
+ (push (interpolate-and-project
+ (the single-float (first next))
+ (the single-float (second next))
+ (the single-float (third next))
+ xc yc zc src-x src-y cut-z
+ *pc-z-mag* cut-ratio)
+ out-list)))))
+ (setq prev pt))
+ ;;return list of x-y coords
+ out-list))
+
+;;;----------------------------------------------
+
+(defconstant *tc-tolerance* 0.0001)
+
+;;;----------------------------------------------
+
+(defun traverse-contour (pt-list src-x src-y)
+
+ "traverse-contour pt-list src
+
+Local procedure to handle case where beam source lies in plane of
+projection."
+
+ (declare (type single-float src-x src-y))
+ (let* ((cut-x 0.0) (cut-y 0.0)
+ (remainder pt-list)
+ (next nil)
+ (src-x-y (list src-x src-y))
+ (ray-end nil)
+ (outward t)
+ (xc 0.0) (yc 0.0) (zc 0.0)
+ (xn 0.0) (yn 0.0) (zn 0.0)
+ (cut-ratio 1.0) (re 0.0)
+ (out-list nil))
+ (declare (single-float cut-x cut-y cut-ratio xc yc zc xn yn zn re))
+ (dolist (c pt-list)
+ (setq remainder (rest remainder))
+ (setq next (first remainder))
+ (cond (next (setq zc (third c)
+ zn (third next))
+ ;; if crossing, interpolate segment
+ (when (or (and (>= zc 0.0) (<= zn 0.0))
+ (and (<= zc 0.0) (>= zn 0.0)))
+ (setq xc (first c)
+ yc (second c)
+ xn (first next)
+ yn (second next))
+ (interpolate-x-y xc yc zc
+ xn yn zn
+ cut-x cut-y 0.0 cut-ratio)
+ (setq ray-end
+ (ray-endpoint src-x src-y cut-x cut-y
+ *tc-tolerance* re))
+ (cond (outward (push src-x-y out-list)
+ (push ray-end out-list)
+ (setf outward nil))
+ (t (push ray-end out-list)
+ (push src-x-y out-list)
+ (setq outward t)))))))
+ ;; return list of x-y coords
+ out-list))
+
+;;;----------------------------------------------
+
+(defun project-portal (portal src-to-center bt pos)
+
+ "project-portal portal src-to-center bt pos
+
+Projects portal, a list of vertices presumed to be at z = 0.0, from
+distance src-to-center onto the view plane whose beam transform is
+represented in the array bt, at position pos. Returns a list of
+vertices depicting the connected set of segments comprising the
+portal's projection into view plane."
+
+ (declare (type (simple-array single-float (12)) bt)
+ (type single-float src-to-center pos))
+ (let* ((r00 (aref bt 0))
+ (r01 (aref bt 1))
+ (r03 (aref bt 3))
+ (r10 (aref bt 4))
+ (r11 (aref bt 5))
+ (r13 (aref bt 7))
+ (r20 (aref bt 8))
+ (r21 (aref bt 9))
+ (r23 (aref bt 11))
+ (mag (float (/ (- src-to-center pos) src-to-center)))
+ (px 0.0) (py 0.0)
+ (src-x (+ (* (aref bt 2) src-to-center) r03))
+ (src-y (+ (* (aref bt 6) src-to-center) r13))
+ (src-z (+ (* (aref bt 10) src-to-center) r23))
+ (out-list nil))
+ (declare (single-float
+ r00 r01 r03 r10 r11 r13 r20 r21 r23
+ px py src-x src-y src-z mag))
+
+ ;; See Jacky and Kalet, Computerized Medical Imaging and Graphics,
+ ;; Vol. 14, 1990, pp. 97-105, for the algorithm. For efficiency,
+ ;; we code matrix multiplication inline, since many terms are
+ ;; known to be zero.
+ ;; src is the coordinates of the beam source in view space; ie:
+ ;;
+ ;; [ r00 r01 r02 ] [ 0 ] [ couch x ]
+ ;; src = [ r10 r11 r12 ] * [ 0 ] + [ couch y ]
+ ;; [ r20 r21 r22 ] [ src-to-center ] [ couch z ]
+
+ (dolist (pt (append portal (list (first portal))))
+ (setq px (* mag (the single-float (first pt)))
+ py (* mag (the single-float (second pt))))
+ (push (list (+ (* r00 px) (* r01 py) r03)
+ (+ (* r10 px) (* r11 py) r13)
+ (+ (* r20 px) (* r21 py) r23))
+ out-list))
+ (if (poly:nearly-equal src-z 0.0 *z-tol*)
+ (traverse-contour out-list src-x src-y)
+ (project-contour out-list src-x src-y src-z))))
+
+;;;----------------------------------------------
+
+(defun draw-portal (prim portal bt sad v)
+
+ "draw-portal prim portal bt sad v
+
+Draws portal, a list of vertices, into the supplied graphic primitive,
+using beam transform bt, source to axis distance sad, and a number of
+attributes of the primitive's view v."
+
+ (setf (points prim)
+ (append (scale-and-clip-lines
+ (project-portal portal sad bt
+ (if (typep v 'beams-eye-view)
+ (view-position v) 0.0))
+ (scale v) (x-origin v) (y-origin v) 0 0
+ (sl:width (picture v)) (sl:height (picture v)))
+ (points prim))))
+
+;;;----------------------------------------------
+
+(defun draw-isocenter (prim bt scale x-origin y-origin)
+
+ "draw-isocenter prim bt scale x-origin y-origin
+
+Draws an isocenter icon into graphic primitive prim, based upon beam
+transform bt and the provided view plane scale, x-origin, and
+y-origin."
+
+ (declare (single-float scale) (fixnum x-origin y-origin)
+ (type (simple-array single-float (12)) bt))
+ (when (poly:nearly-equal (aref bt 11) 0.0 *z-tol*)
+ (setf (points prim) (append
+ (draw-diamond-icon
+ (list (aref bt 3) (aref bt 7))
+ scale x-origin y-origin *isocenter-radius*)
+ (points prim)))))
+
+;;;----------------------------------------------
+
+(defun draw-central-axis (prim bt sad scale x-origin y-origin)
+
+ "draw-central-axis prim bt sad scale x-origin y-origin
+
+Draws a central axis icon into the graphic primitive prim, based upon
+beam transform bt, source to axis distance sad, and the provided view
+plane scale, x-origin, and y-origin. If the central axis lies in the
+view plane, a line segment with tic marks spaced 1 cm apart is drawn.
+If the central axis crosses through the view plane, a plus sign is
+drawn at the point of intersection, unless the point of intersection
+is the isocenter, in which case nothing is drawn (the drawing of the
+isocenter is handled elsewhere). If the central axis does not
+intersect the plane, nothing is drawn."
+
+ (declare (single-float sad scale) (fixnum x-origin y-origin)
+ (type (simple-array single-float (12)) bt))
+ (let* ((r03 (aref bt 3))
+ (r13 (aref bt 7))
+ (r23 (aref bt 11))
+ (src-x (+ (* (aref bt 2) sad) r03))
+ (src-y (+ (* (aref bt 6) sad) r13))
+ (src-z (+ (* (aref bt 10) sad) r23))
+ (iso-in-plane (poly:nearly-equal r23 0.0 *z-tol*))
+ (src-in-plane (poly:nearly-equal src-z 0.0 *z-tol*)))
+ (declare (single-float r03 r13 r23 src-x src-y src-z))
+ (cond
+ ((and src-in-plane iso-in-plane) ;; axis in plane
+ (let ((end-x (- (* 2.0 r03) src-x))
+ (end-y (- (* 2.0 r13) src-y)))
+ (setf (points prim)
+ (nconc (pixel-segments (list (list src-x src-y end-x end-y))
+ scale x-origin y-origin)
+ (compute-tics src-x src-y end-x end-y
+ scale x-origin y-origin
+ *central-axis-tic-length*)
+ (points prim)))))
+ ((not (poly:nearly-equal src-z r23 *z-tol*)) ; axis crosses plane
+ (unless iso-in-plane
+ (let* ((fac (/ src-z (- src-z r23)))
+ (isec-x (+ src-x (* fac (- r03 src-x))))
+ (isec-y (+ src-y (* fac (- r13 src-y)))))
+ (declare (single-float fac isec-x isec-y))
+ (setf (points prim)
+ (append
+ (draw-plus-icon (list isec-x isec-y)
+ scale x-origin y-origin *isocenter-radius*)
+ (points prim)))))))))
+
+;;;----------------------------------------------
+
+(defmethod draw ((b beam) (v view))
+
+ "draw (b beam) (v view)
+
+Computes the projection of beam b into orthogonal view v and adds two
+graphics primitives, solid and dashed, containing the projected
+segments to v's foreground display list. This includes the drawing of
+the beam's isocenter and central axis, and the wedge. Does NOT draw
+the beam's blocks."
+
+ ;; start with new gp's each time, to avoid having to look for
+ ;; and disambiguate the solid and dashed segment-prims, which
+ ;; would be very complicated. But first catch the visible attribute
+ ;; of a beam graphic prim if present.
+ (let ((visible (aif (find b (foreground v) :key #'object)
+ (visible it) t)))
+ (setf (foreground v) (remove b (foreground v) :key #'object))
+ (unless (eql (display-color b) 'sl:invisible)
+ (let* ((solid-clr (sl:color-gc (display-color b)))
+ (solid-prim (get-segments-prim b v solid-clr))
+ (dashed-prim (get-segments-prim
+ b v (sl:find-dashed-color solid-clr)))
+ (bt (beam-transform b v))
+ (sad (isodist b))
+ (scale (scale v))
+ (x-orig (x-origin v))
+ (y-orig (y-origin v))
+ (pic (picture v))
+ (wdg (wedge b)))
+ (setf (visible solid-prim) visible)
+ (setf (visible dashed-prim) visible)
+ (draw-portal dashed-prim (portal (collimator b)) bt sad v)
+ (draw-isocenter solid-prim bt scale x-orig y-orig)
+ (when (display-axis b)
+ (draw-central-axis solid-prim bt sad scale x-orig y-orig))
+ (unless (zerop (id wdg))
+ (draw-wedge solid-prim
+ (beam-transform b v t)
+ sad
+ (rotation wdg)
+ scale x-orig y-orig
+ (sl:width pic) (sl:height pic)))))))
+
+;;;----------------------------------------------
+
+(defmethod draw ((b beam) (v oblique-view))
+
+ "stub to prevent crashes - just don't draw it until we figure out
+ the transforms."
+
+ )
+
+;;;----------------------------------------------
+;;; End.
diff --git a/prism/src/beam-mediators.cl b/prism/src/beam-mediators.cl
new file mode 100644
index 0000000..28ef9a7
--- /dev/null
+++ b/prism/src/beam-mediators.cl
@@ -0,0 +1,189 @@
+;;;
+;;; beam-mediators
+;;;
+;;; defines beam-view-mediator and support code
+;;;
+;;; 18-Jan-1993 I. Kalet move add-notify code from beams-eye-views
+;;; that updates the beams-eye-view slots to beam-view-mediator
+;;; 15-Feb-1993 I. Kalet add action for new-color announcement and
+;;; new-machine announcement in beam-view-mediator
+;;; 15-Apr-1993 I. Kalet handle new-coll-set announcement from
+;;; collimators
+;;; 22-Jul-1993 I. Kalet put add and remove notify for BEV here in
+;;; beam-view-mediator.
+;;; 5-Sep-1993 I. Kalet split off from beam-graphics module
+;;; 18-Oct-1993 I. Kalet make destroy an :after method, not primary
+;;; 2-Jun-1994 I. Kalet add notifications for beam block insertion,
+;;; deletion, and cleanup when mediator is destroyed.
+;;; 21-Jun-1994 I. Kalet add code to destroy method to delete a beam's
+;;; eye view when its beam is deleted.
+;;; 28-Jun-1994 J. Unger add code to handle view updates when wedge
+;;; rotation changes.
+;;; 3-Oct-1994 J. Unger redraw view when axis-changed.
+;;; 12-Jan-1995 I. Kalet add plan-of here so can remove from beams and
+;;; views.
+;;; 7-Sep-1995 I. Kalet unregister block events in destroy, also
+;;; handle wedge-id and block display-color.
+;;; 8-Oct-1996 I. Kalet fix error in registration for block inserted.
+;;; Provide an :after method for update-view, to draw the blocks.
+;;; Draw the blocks in the initialization also, since the basic
+;;; object-view-mediator will only draw the beam. In initialization
+;;; of the beam-view-mediator, replace the general action for
+;;; refresh-fg with one that draws the blocks as well as the beam.
+;;; 20-May-1997 I. Kalet use plan view set in constructor function
+;;; instead of plan, to avoid circularity with plan definition.
+;;; 11-Mar-2001 I. Kalet update name of BEV when name of beam for that
+;;; view changes.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------
+
+(defclass beam-view-mediator (object-view-mediator)
+
+ ((view-set :initarg :view-set
+ :accessor view-set
+ :documentation "The set of views of the plan containing
+the beam, needed to delete a bev for a beam that is deleted.")
+ )
+
+ (:documentation "This mediator connects a beam with a view.")
+ )
+
+;;;----------------------------------------------
+
+(defun make-beam-view-mediator (beam view vset)
+
+ (make-instance 'beam-view-mediator
+ :object beam :view view :view-set vset))
+
+;;;----------------------------------------------
+
+(defmethod initialize-instance :after ((bvm beam-view-mediator)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (let ((bm (object bvm))
+ (vw (view bvm)))
+ (ev:add-notify bvm (new-coll-angle bm) #'update-view)
+ (ev:add-notify bvm (new-color bm) #'update-view)
+ (ev:add-notify bvm (axis-changed bm) #'update-view)
+ (ev:add-notify bvm (new-coll-set (collimator bm)) #'update-view)
+ (ev:add-notify bvm (new-id (wedge bm)) #'update-view)
+ (ev:add-notify bvm (new-rotation (wedge bm)) #'update-view)
+ (ev:add-notify bvm (new-machine bm)
+ #'(lambda (med b mach)
+ (declare (ignore mach))
+ (ev:add-notify med (new-coll-set (collimator b))
+ #'update-view)
+ (update-view med b)))
+ (ev:add-notify bvm (coll:inserted (blocks bm))
+ #'(lambda (med blk-set blk)
+ (declare (ignore blk-set))
+ (ev:add-notify med (new-vertices blk)
+ #'update-view)
+ (ev:add-notify med (new-color blk)
+ #'update-view)
+ (update-view med blk)))
+ (ev:add-notify bvm (coll:deleted (blocks bm))
+ #'(lambda (med blk-set blk)
+ (declare (ignore blk-set))
+ (let ((mvw (view med)))
+ (setf (foreground mvw)
+ (remove blk (foreground mvw) :key #'object))
+ (display-view mvw))))
+ (ev:add-notify bvm (refresh-fg vw) ;; replaces the general one
+ #'(lambda (med v)
+ (let ((b (object med)))
+ (draw b v) ;; draw the beam and the blocks
+ (dolist (bl (coll:elements (blocks b)))
+ (draw-beam-block bl v b)))))
+ ;; initially register with and draw the blocks
+ (dolist (blk (coll:elements (blocks bm)))
+ (ev:add-notify bvm (new-vertices blk) #'update-view)
+ (ev:add-notify bvm (new-color blk) #'update-view)
+ (draw-beam-block blk vw bm))
+ ;; which view redraw depends on whether it is a BEV for this beam
+ (if (and (typep vw 'beams-eye-view) (eq bm (beam-for vw)))
+ (progn
+ (ev:add-notify vw (new-gantry-angle bm) #'refresh-bev)
+ (ev:add-notify vw (new-couch-angle bm) #'refresh-bev)
+ (ev:add-notify vw (new-couch-lat bm) #'refresh-bev)
+ (ev:add-notify vw (new-couch-ht bm) #'refresh-bev)
+ (ev:add-notify vw (new-couch-long bm) #'refresh-bev)
+ (ev:add-notify vw (new-machine bm) #'refresh-bev)
+ (ev:add-notify vw (new-name bm)
+ #'(lambda (v b newname)
+ (declare (ignore b))
+ (setf (name v)
+ (format nil "BEV for ~A" newname)))))
+ (progn
+ (ev:add-notify bvm (new-gantry-angle bm) #'update-view)
+ (ev:add-notify bvm (new-couch-angle bm) #'update-view)
+ (ev:add-notify bvm (new-couch-lat bm) #'update-view)
+ (ev:add-notify bvm (new-couch-ht bm) #'update-view)
+ (ev:add-notify bvm (new-couch-long bm) #'update-view))
+ )))
+
+;;;----------------------------------------------
+
+(defmethod destroy :before ((bvm beam-view-mediator))
+
+ (let ((bm (object bvm))
+ (vw (view bvm)))
+ (dolist (blk (coll:elements (blocks bm)))
+ (setf (foreground vw)
+ (remove blk (foreground vw) :key #'object)))))
+
+;;;----------------------------------------------
+
+(defmethod destroy :after ((bvm beam-view-mediator))
+
+ (let ((bm (object bvm))
+ (vw (view bvm)))
+ (ev:remove-notify bvm (new-coll-angle bm))
+ (ev:remove-notify bvm (new-color bm))
+ (ev:remove-notify bvm (axis-changed bm))
+ (ev:remove-notify bvm (new-coll-set (collimator bm)))
+ (ev:remove-notify bvm (new-machine bm))
+ (ev:remove-notify bvm (coll:inserted (blocks bm)))
+ (ev:remove-notify bvm (coll:deleted (blocks bm)))
+ (ev:remove-notify bvm (new-id (wedge bm)))
+ (ev:remove-notify bvm (new-rotation (wedge bm)))
+ (dolist (blk (coll:elements (blocks bm)))
+ (ev:remove-notify bvm (new-vertices blk))
+ (ev:remove-notify bvm (new-color blk)))
+ (if (and (typep vw 'beams-eye-view) (eq bm (beam-for vw)))
+ (progn
+ (ev:remove-notify vw (new-gantry-angle bm))
+ (ev:remove-notify vw (new-couch-angle bm))
+ (ev:remove-notify vw (new-couch-lat bm))
+ (ev:remove-notify vw (new-couch-ht bm))
+ (ev:remove-notify vw (new-couch-long bm))
+ (ev:remove-notify vw (new-machine bm))
+ (let ((vs (view-set bvm)))
+ (when (coll:collection-member vw vs) ;; if not deleted
+ (coll:delete-element vw vs)))) ;; then delete it
+ (progn
+ (ev:remove-notify bvm (new-gantry-angle bm))
+ (ev:remove-notify bvm (new-couch-angle bm))
+ (ev:remove-notify bvm (new-couch-lat bm))
+ (ev:remove-notify bvm (new-couch-ht bm))
+ (ev:remove-notify bvm (new-couch-long bm))))))
+
+;;;----------------------------------------------
+
+(defmethod update-view :after ((med beam-view-mediator) obj
+ &rest pars)
+
+ "draws the blocks after the beam is drawn by the primary method."
+
+ (declare (ignore obj pars))
+ (let ((bm (object med))
+ (vw (view med)))
+ (dolist (blk (coll:elements (blocks bm)))
+ (draw-beam-block blk vw bm))))
+
+;;;----------------------------------------------
+;;; End.
diff --git a/prism/src/beam-panels.cl b/prism/src/beam-panels.cl
new file mode 100644
index 0000000..2da7e5a
--- /dev/null
+++ b/prism/src/beam-panels.cl
@@ -0,0 +1,731 @@
+;;;
+;;; beam-panels
+;;;
+;;; The beam panel is defined here because it is too much code to
+;;; include along with the beams themselves, in the beams module.
+;;;
+;;; 18-Sep-1992 I. Kalet created from beams
+;;; 1-Oct-1992 I. Kalet fill in some details
+;;; 6-Oct-1992 I. Kalet fix some inconsistencies
+;;; 13-Oct-1992 I. Kalet add more connections and stuff
+;;; 28-Oct-1992 I. Kalet put read-from-string in notify functions
+;;; 29-Nov-1992 I. Kalet add sliders, move stuff around
+;;; 15-Feb-1993 I. Kalet squeeze margins, add n fractions, add machine
+;;; and color actions.
+;;; 16-Apr-1993 I. Kalet add collimator control panel creation and
+;;; update, adjust size of beam panel to accomodate.
+;;; 22-Apr-1993 I. Kalet add wedge menu
+;;; 30-Dec-1993 I. Kalet fix error causing wrong font in collimator
+;;; panels, when switching beams - didn't set right font in beam panel
+;;; frame.
+;;; 18-Feb-1994 I. Kalet add copy beam functions and buttons, include
+;;; insertion of beam into plan here.
+;;; 02-Mar-1994 J. Unger add textlines to edit atten-factor &
+;;; arc-size.
+;;; 13-May-1994 I. Kalet add error checking to textlines for numbers.
+;;; 31-May-1994 I. Kalet add selector panel for blocks.
+;;; 03-Jun-1994 J. Unger fixup omitted remove-notify error & make default
+;;; atten factor & arc size show up in panel.
+;;; 05-Jun-1994 J. Unger add wedge-orientation button & menu to panel.
+;;; 05-Jun-1994 J. Unger uncomment call to block selector panel
+;;; destroy mthd.
+;;; 30-Jun-1994 I. Kalet make range of couch long. slider -50 to 50
+;;; 22-Jul-1994 J. Unger make beam panel slightly longer to fit coll panel;
+;;; add beam-for param to call to make-collimator-panel.
+;;; 27-Jul-1994 J. Unger add block rotation button.
+;;; 18-Sep-1994 J. Unger make block's color initially beam's color.
+;;; 03-Oct-1994 J. Unger make machine name color yellow.
+;;; 15-Jan-1995 I. Kalet use function isodist instead of inline code.
+;;; Access beam-of on panel, not beam-for of wedge. Pass beam-of to
+;;; make-block-panel. Include plan-of and patient-of here so can
+;;; eliminate back-pointers. Pass plan and patient to block, cutout
+;;; and coll. panels too.
+;;; 7-Sep-1995 I. Kalet add coerce forms to insure single-floats in
+;;; MU, arc size, etc. and to insure fixnum in ntreats.
+;;; 3-Jan-1996 I. Kalet increase couch lateral limits to -50/50.
+;;; 4-May-1997 I. Kalet use label instead of title in sliderboxes
+;;; 10-Jun-1997 I. Kalet machine returns the object, not the name,
+;;; also use color button labels for blocks.
+;;; 16-Sep-1997 I. Kalet explicitly provide machine database
+;;; parameters as they are no longer optional.
+;;; 26-Oct-1997 I. Kalet insure that when changing wedge id, a valid
+;;; wedge rotation is set also.
+;;; 15-Dec-1998 I. Kalet extend ALL couch linear motion limits to
+;;; accomodate CT scans done with patient displaced.
+;;; 25-Jan-2000 I. Kalet display blank for wedge rotation when no wedge.
+;;; 22-Feb-2000 I. Kalet use copy instead of copy-beam, and explicitly
+;;; change gantry etc. in copy beam action functions.
+;;; 26-Mar-2000 I. Kalet final mods to copy 180 function - treat CNTS
+;;; and SL20 differently.
+;;; 28-May-2000 I. Kalet parametrize small font, change labels to
+;;; lower case, widen button column.
+;;; 26-Nov-2000 I. Kalet move block list to beam-block-panel, like
+;;; volume editor, move block rotate button also.
+;;; 6-Jan-2002 I. Kalet change beam name textline to three line textbox
+;;; 14-Feb-2002 I. Kalet pad or truncate each line of beam name to
+;;; exactly 10 characters.
+;;; 14-Mar-2002 I. Kalet limit the beam name to three lines.
+;;; 7-Feb-2004 I. Kalet parametrize couch lateral and longitudinal
+;;; motion limits in prism-globals.
+;;; 25-Aug-2004 I. Kalet add listify call to action for new-name of
+;;; beam, per suggestion from Balto.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defclass beam-panel (generic-panel)
+
+ ((beam-of :initarg :beam-of
+ :accessor beam-of)
+
+ (plan-of :initarg :plan-of
+ :accessor plan-of
+ :documentation "The plan containing the beam.")
+
+ (patient-of :initarg :patient-of
+ :accessor patient-of
+ :documentation "The current patient.")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame containing all the
+dials and sliders...")
+
+ (delete-b :accessor delete-b
+ :documentation "The Delete Panel button.")
+
+ (copy-b :accessor copy-b
+ :documentation "The Copy Here button.")
+
+ (copy-90 :accessor copy-90
+ :documentation "The Copy 90 button.")
+
+ (copy-180 :accessor copy-180
+ :documentation "The Copy 180 button.")
+
+ (copy-270 :accessor copy-270
+ :documentation "The Copy 270 button.")
+
+ (mu-box :accessor mu-box
+ :documentation "Textline for monitor units.")
+
+ (nfrac-box :accessor nfrac-box
+ :documentation "Textline for number of fractions.")
+
+ (name-box :accessor name-box
+ :documentation "Textline for Beam name.")
+
+ (atten-box :accessor atten-box
+ :documentation "Textline for attenuation factor.")
+
+ (arc-box :accessor arc-box
+ :documentation "Textline for arc size.")
+
+ (machine-b :accessor machine-b
+ :documentation "Button for machine selection.")
+
+ (color-b :accessor color-b
+ :documentation "The color selection button.")
+
+ (wedge-sel-b :accessor wedge-sel-b
+ :documentation "The wedge selection button.")
+
+ (wedge-ang-b :accessor wedge-ang-b
+ :documentation "The wedge angle button.")
+
+ (toggle-axis-b :accessor toggle-axis-b
+ :documentation "The button to toggle central axis display.")
+
+ (block-btn :accessor block-btn
+ :documentation "The button to make the block editing panel.")
+
+ (block-pan :accessor block-pan
+ :documentation "The block editing subpanel")
+
+ (coll-db :accessor coll-db
+ :documentation "The dialbox for the collimator angle.")
+
+ (gantry-db :accessor gantry-db
+ :documentation "The dialbox for the gantry angle.")
+
+ (couch-db :accessor couch-db
+ :documentation "The dialbox for the couch angle.")
+
+ (couch-lat-sl :accessor couch-lat-sl
+ :documentation "The slider for the couch lateral
+motion.")
+
+ (couch-long-sl :accessor couch-long-sl
+ :documentation "The slider for the couch longitudinal
+motion.")
+
+ (couch-ht-sl :accessor couch-ht-sl
+ :documentation "The slider for the couch height
+motion.")
+
+ (coll-pan :accessor coll-pan
+ :documentation "The sub-panel for the collimator jaw
+controls.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "The busy bit for controlling updates between
+beam attributes and beam controls.")
+
+ )
+
+ (:documentation "The beam panel provides the dials and sliders to
+control one beam.")
+
+ )
+
+;;;---------------------------------------------
+
+(defun make-beam-panel (a-beam &rest initargs)
+
+ "make-beam-panel a-beam
+
+Returns a beam panel attached to a-beam."
+
+ (apply #'make-instance 'beam-panel :beam-of a-beam initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((bp beam-panel) &rest initargs)
+
+ "This method creates the beam panel and the mediators."
+
+ (let* ((b (beam-of bp))
+ (bpf (symbol-value *small-font*)) ; the value, not the symbol
+ (beam-fr (apply #'sl:make-frame 430 685
+ :title "Prism BEAM Panel"
+ :font bpf initargs))
+ (bp-win (sl:window beam-fr))
+ ;; following code uses the bp-y function defined in
+ ;; prism-objects module - short for button-placement-y
+ (bth 25) ; the button and textline height
+ (btw 130) ; the button and textline width
+ (dx 10) ; left margin
+ (top-y 10) ; where the first button is
+ (mid-y (+ (bp-y top-y bth 5) 75)) ; buttons after name textbox
+ (del-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y top-y :label "Delete Panel"
+ :parent bp-win :font bpf initargs))
+ (cpy-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 1)
+ :label "Copy HERE" :parent bp-win
+ :font bpf initargs))
+ (cpy-90 (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 2)
+ :label "Copy 90" :parent bp-win
+ :font bpf initargs))
+ (cpy-180 (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 3)
+ :label "Copy 180" :parent bp-win
+ :font bpf initargs))
+ (cpy-270 (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 4)
+ :label "Copy 270" :parent bp-win
+ :font bpf initargs))
+ (name-t (apply #'sl:make-textbox 85 70 ;; room for three lines
+ :scroll nil ;; and no more
+ :ulc-x dx :ulc-y (bp-y top-y bth 5)
+ :parent bp-win :font sl:courier-bold-12
+ initargs))
+ (mach-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y mid-y
+ :label (machine-name b)
+ :justify :left :fg-color 'sl:yellow
+ :parent bp-win :font bpf initargs))
+ (mu-t (apply #'sl:make-textline btw bth :label "MU: "
+ :ulc-x dx :ulc-y (bp-y mid-y bth 1)
+ :parent bp-win :font bpf
+ :numeric t :lower-limit 0.0 :upper-limit 10000.0
+ initargs))
+ (nfrac-t (apply #'sl:make-textline btw bth :label "N Fract: "
+ :ulc-x dx :ulc-y (bp-y mid-y bth 2)
+ :parent bp-win :font bpf
+ :numeric t :lower-limit 1 :upper-limit 200
+ initargs))
+ (col-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 3)
+ :label "Beam Color"
+ :fg-color (display-color b)
+ :parent bp-win :font bpf initargs))
+ (wdg-sb (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 4)
+ :label (wedge-label (id (wedge b)) (machine b))
+ :parent bp-win :font bpf initargs))
+ (wdg-ab (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 5)
+ :label (format nil "Wdg Rot: ~a"
+ (if (not (zerop (id (wedge b))))
+ (rotation (wedge b))
+ ""))
+ :parent bp-win :font bpf initargs))
+ (atten-t (apply #'sl:make-textline btw bth :label "Atten: "
+ :ulc-x dx :ulc-y (bp-y mid-y bth 6)
+ :parent bp-win :font bpf
+ :numeric t :lower-limit 0.0 :upper-limit 1.0
+ initargs))
+ (arc-t (apply #'sl:make-textline btw bth :label "Arc size: "
+ :ulc-x dx :ulc-y (bp-y mid-y bth 7)
+ :parent bp-win :font bpf
+ :numeric t :lower-limit 0.0 :upper-limit 360.0
+ initargs))
+ (tog-axis-b (apply #'sl:make-button btw bth
+ :label (if (display-axis b)
+ "Axis ON" "Axis OFF")
+ :ulc-x dx :ulc-y (bp-y mid-y bth 8)
+ :parent bp-win :font bpf
+ initargs))
+ (blk-bt (apply #'sl:make-button btw bth
+ :label "Beam Blocks"
+ :ulc-x dx :ulc-y (bp-y mid-y bth 9)
+ :parent bp-win :font bpf
+ initargs))
+ (dial-r 35) ;; dial radius
+ (db-y 10) ;; dialbox y pos
+ (dsx (+ 20 btw)) ;; dial and slider left boundary
+ (col-d (apply #'sl:make-dialbox dial-r :title "Collim."
+ :ulc-x dsx :ulc-y db-y
+ :angle (collimator-angle b)
+ :parent bp-win :font bpf initargs))
+ (gty-d (apply #'sl:make-dialbox dial-r :title "Gantry"
+ :ulc-x (+ dsx (sl:width col-d)) :ulc-y db-y
+ :angle (gantry-angle b)
+ :parent bp-win :font bpf initargs))
+ (cch-d (apply #'sl:make-dialbox dial-r :title "Couch"
+ :ulc-x (+ dsx (* 2 (sl:width col-d)))
+ :ulc-y db-y
+ :angle (couch-angle b)
+ :parent bp-win :font bpf initargs))
+ (sw 260) ; slider width
+ (sh 30) ; slider height
+ (cht-s (apply #'sl:make-sliderbox sw sh -75.0 75.0 -50.0
+ :label "Couch HT: "
+ :ulc-x dsx :ulc-y 150
+ :setting (couch-height b)
+ :parent bp-win :font bpf initargs))
+ (clat-s (apply #'sl:make-sliderbox sw sh
+ *couch-lat-lower* *couch-lat-upper*
+ -50.0
+ :label "Couch LAT: "
+ :ulc-x dsx :ulc-y 220
+ :setting (couch-lateral b)
+ :parent bp-win :font bpf initargs))
+ (clng-s (apply #'sl:make-sliderbox sw sh
+ *couch-long-lower* *couch-long-upper*
+ -100.0 ;; make sure there is room for larger values
+ :label "Couch LNG: "
+ :ulc-x dsx :ulc-y 290
+ :setting (couch-longitudinal b)
+ :parent bp-win :font bpf initargs))
+ (col-p (apply #'make-collimator-panel (collimator b)
+ :beam-of b
+ :plan-of (plan-of bp)
+ :patient-of (patient-of bp)
+ :ulc-x dsx :ulc-y 360
+ :parent bp-win :font bpf initargs)))
+ (setf (panel-frame bp) beam-fr ; put all the widgets in the slots
+ (delete-b bp) del-b
+ (copy-b bp) cpy-b
+ (copy-90 bp) cpy-90
+ (copy-180 bp) cpy-180
+ (copy-270 bp) cpy-270
+ (mu-box bp) mu-t
+ (sl:info mu-t) (monitor-units b) ; initial contents for MU
+ (nfrac-box bp) nfrac-t
+ (sl:info nfrac-t) (n-treatments b) ; initial contents
+ (name-box bp) name-t
+ ;; initial contents of name textline
+ (sl:info name-t) (listify (name b) 10)
+ (machine-b bp) mach-b
+ (color-b bp) col-b
+ (wedge-sel-b bp) wdg-sb
+ (wedge-ang-b bp) wdg-ab
+ (atten-box bp) atten-t
+ (sl:info atten-t) (atten-factor b)
+ (arc-box bp) arc-t
+ (sl:info arc-t) (arc-size b)
+ (toggle-axis-b bp) tog-axis-b
+ (block-btn bp) blk-bt
+ (coll-db bp) col-d
+ (gantry-db bp) gty-d
+ (couch-db bp) cch-d
+ (couch-ht-sl bp) cht-s
+ (couch-long-sl bp) clng-s
+ (couch-lat-sl bp) clat-s
+ (coll-pan bp) col-p)
+ (ev:add-notify bp (sl:button-on del-b)
+ #'(lambda (pan a) (declare (ignore a)) (destroy pan)))
+ (ev:add-notify b (sl:button-on cpy-b)
+ #'(lambda (bm btn)
+ (declare (ignore btn))
+ (let ((new-beam (copy bm)))
+ (setf (name new-beam)
+ (format nil "~A" (gensym "BEAM-")))
+ (setf (id (wedge new-beam)) 0)
+ (coll:insert-element new-beam
+ (beams (plan-of bp))))))
+ (ev:add-notify b (sl:button-on cpy-90)
+ #'(lambda (bm btn)
+ (declare (ignore btn))
+ (let* ((new-beam (copy bm))
+ (blklist (coll:elements (blocks new-beam))))
+ (setf (name new-beam)
+ (format nil "~A" (gensym "BEAM-")))
+ (dolist (blk blklist)
+ (coll:delete-element blk (blocks new-beam)))
+ (setf (gantry-angle new-beam)
+ (mod (+ (gantry-angle bm) 90.0) 360.0))
+ (setf (id (wedge new-beam)) 0)
+ (if (typep (collimator new-beam) 'portal-coll)
+ (setf (vertices (collimator new-beam))
+ ;; back to 10 by 10
+ '((-5.0 -5.0) (5.0 -5.0)
+ (5.0 5.0) (-5.0 5.0))))
+ (coll:insert-element new-beam
+ (beams (plan-of bp))))))
+ (ev:add-notify b (sl:button-on cpy-180)
+ #'(lambda (bm btn)
+ (declare (ignore btn))
+ (coll:insert-element (reflected-beam bm)
+ (beams (plan-of bp)))))
+ (ev:add-notify b (sl:button-on cpy-270)
+ #'(lambda (bm btn)
+ (declare (ignore btn))
+ (let* ((new-beam (copy bm))
+ (blklist (coll:elements (blocks new-beam))))
+ (setf (name new-beam)
+ (format nil "~A" (gensym "BEAM-")))
+ (dolist (blk blklist)
+ (coll:delete-element blk (blocks new-beam)))
+ (setf (gantry-angle new-beam)
+ (mod (+ (gantry-angle bm) 270.0) 360.0))
+ (setf (id (wedge new-beam)) 0)
+ (if (typep (collimator new-beam) 'portal-coll)
+ (setf (vertices (collimator new-beam))
+ ;; back to 10 by 10
+ '((-5.0 -5.0) (5.0 -5.0)
+ (5.0 5.0) (-5.0 5.0))))
+ (coll:insert-element new-beam
+ (beams (plan-of bp))))))
+ (ev:add-notify bp (new-mu b)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (mu-box pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:new-info mu-t)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (monitor-units (beam-of bp))
+ (coerce (read-from-string info) 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-n-treats b)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (nfrac-box pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:new-info nfrac-t)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (n-treatments (beam-of bp))
+ (round (read-from-string info)))
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-name b)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (name-box pan))
+ (listify info 10))
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:new-info name-t)
+ #'(lambda (pan box)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (name (beam-of bp))
+ (apply #'concatenate 'string
+ (mapcar
+ #'(lambda (str)
+ (replace (make-string
+ 10 :initial-element
+ #\Space) str))
+ (sl:info box))))
+ (setf (busy pan) nil))))
+ (ev:add-notify b (sl:button-on mach-b)
+ #'(lambda (bm btn)
+ (let* ((machines (get-therapy-machine-list
+ *machine-index-directory*))
+ (new-mach (sl:popup-menu machines)))
+ (if new-mach (setf (machine-name bm)
+ (nth new-mach machines))))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify bp (new-machine b)
+ #'(lambda (pan bm mach)
+ (setf (sl:label (machine-b pan)) mach)
+ (let ((cp (coll-pan pan))
+ (coll (collimator bm))
+ (frm (panel-frame pan)))
+ (unless (eq coll (coll-for cp))
+ (destroy cp)
+ (setf (coll-pan pan)
+ (make-collimator-panel
+ coll
+ :beam-of bm
+ :plan-of (plan-of pan)
+ :patient-of (patient-of pan)
+ :ulc-x dsx :ulc-y 360
+ :parent (sl:window frm)
+ :font (sl:font frm)))))))
+ (ev:add-notify b (sl:button-on col-b)
+ #'(lambda (bm btn)
+ (let ((new-col (sl:popup-color-menu)))
+ (if new-col (setf (display-color bm) new-col)))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify bp (new-color b)
+ #'(lambda (pan bm col)
+ (declare (ignore bm))
+ (setf (sl:fg-color (color-b pan)) col)))
+ (ev:add-notify bp (new-id (wedge b))
+ #'(lambda (pan wdg id)
+ (declare (ignore wdg))
+ (setf (sl:label (wedge-sel-b pan))
+ (wedge-label id (machine (beam-of pan))))))
+ (ev:add-notify bp (new-rotation (wedge b))
+ #'(lambda (pan wdg rot)
+ (setf (sl:label (wedge-ang-b pan))
+ (format nil "Wdg Rot: ~a"
+ (if (zerop (id wdg))
+ "" rot)))))
+ (ev:add-notify b (sl:button-on wdg-sb)
+ #'(lambda (bm btn)
+ (let* ((mach (machine bm))
+ (namelist (wedge-names mach))
+ (new-wdg-name (sl:popup-menu namelist)))
+ (when new-wdg-name
+ (let ((newid (wedge-id-from-name
+ (nth new-wdg-name namelist)
+ mach)))
+ (setf (id (wedge bm)) newid)
+ ;; set rotation every time so display updates
+ (setf (rotation (wedge bm))
+ (if (= newid 0) 0.0
+ (if (find (rotation (wedge bm))
+ (wedge-rot-angles newid mach))
+ (rotation (wedge bm))
+ (first (wedge-rot-angles newid mach)))))))
+ (setf (sl:on btn) nil))))
+ (ev:add-notify b (sl:button-on wdg-ab)
+ #'(lambda (bm btn)
+ (let* ((wdg (wedge bm))
+ (id (id wdg)))
+ (if (zerop id)
+ (sl:acknowledge "Please select a wedge first.")
+ (let* ((angles (wedge-rot-angles id (machine bm)))
+ (pos (sl:popup-menu
+ (mapcar #'write-to-string angles)))
+ (ang (when pos (nth pos angles))))
+ (when ang (setf (rotation wdg) ang)))))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify bp (new-arc-size b)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (arc-box pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:new-info arc-t)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (arc-size (beam-of bp))
+ (coerce (read-from-string info) 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-atten-factor b)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (atten-box pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:new-info atten-t)
+ #'(lambda (pan a info)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (atten-factor (beam-of bp))
+ (coerce (read-from-string info) 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-gantry-angle b)
+ #'(lambda (pan a ang)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:angle (gantry-db pan)) ang)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:value-changed gty-d)
+ #'(lambda (pan a ang)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (gantry-angle (beam-of bp)) ang)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-coll-angle b)
+ #'(lambda (pan a ang)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:angle (coll-db pan)) ang)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:value-changed col-d)
+ #'(lambda (pan a ang)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (collimator-angle (beam-of bp)) ang)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-couch-angle b)
+ #'(lambda (pan a ang)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:angle (couch-db pan)) ang)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:value-changed cch-d)
+ #'(lambda (pan a ang)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (couch-angle (beam-of bp)) ang)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-couch-ht b)
+ #'(lambda (pan a val)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (couch-ht-sl pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:value-changed cht-s)
+ #'(lambda (pan a val)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (couch-height (beam-of bp)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-couch-long b)
+ #'(lambda (pan a val)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (couch-long-sl pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:value-changed clng-s)
+ #'(lambda (pan a val)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (couch-longitudinal (beam-of bp)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (new-couch-lat b)
+ #'(lambda (pan a val)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (couch-lat-sl pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:value-changed clat-s)
+ #'(lambda (pan a val)
+ (declare (ignore a))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (couch-lateral (beam-of pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify bp (sl:button-on blk-bt)
+ #'(lambda (pan btn)
+ (setf (block-pan pan) (make-block-panel
+ (beam-of pan) (plan-of pan)
+ (patient-of pan)))
+ (ev:add-notify pan (deleted (block-pan pan))
+ #'(lambda (pnl blpnl)
+ (declare (ignore blpnl))
+ (setf (block-pan pnl) nil)
+ (when (not (busy pnl))
+ (setf (busy pnl) t)
+ (setf (sl:on btn) nil)
+ (setf (busy pnl) nil))))))
+ (ev:add-notify bp (sl:button-off blk-bt)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (block-pan pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify b (sl:button-on tog-axis-b)
+ #'(lambda (bm btn)
+ (setf (display-axis bm) (not (display-axis bm)))
+ (if (display-axis bm)
+ (setf (sl:label tog-axis-b) "Axis ON")
+ (setf (sl:label tog-axis-b) "Axis OFF"))
+ (setf (sl:on btn) nil)))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((bp beam-panel))
+
+ "Releases X resources used by this panel and its children."
+
+ (destroy (coll-pan bp))
+ (sl:destroy (delete-b bp))
+ (sl:destroy (copy-b bp))
+ (sl:destroy (copy-90 bp))
+ (sl:destroy (copy-180 bp))
+ (sl:destroy (copy-270 bp))
+ (sl:destroy (mu-box bp))
+ (sl:destroy (name-box bp))
+ (sl:destroy (atten-box bp))
+ (sl:destroy (arc-box bp))
+ (sl:destroy (nfrac-box bp))
+ (sl:destroy (machine-b bp))
+ (sl:destroy (color-b bp))
+ (sl:destroy (wedge-sel-b bp))
+ (sl:destroy (wedge-ang-b bp))
+ (sl:destroy (toggle-axis-b bp))
+ (if (sl:on (block-btn bp)) (setf (sl:on (block-btn bp)) nil))
+ (sl:destroy (block-btn bp))
+ (sl:destroy (coll-db bp))
+ (sl:destroy (gantry-db bp))
+ (sl:destroy (couch-db bp))
+ (sl:destroy (couch-lat-sl bp))
+ (sl:destroy (couch-long-sl bp))
+ (sl:destroy (couch-ht-sl bp))
+ (sl:destroy (panel-frame bp))
+ (ev:remove-notify bp (new-name (beam-of bp)))
+ (ev:remove-notify bp (new-machine (beam-of bp)))
+ (ev:remove-notify bp (new-mu (beam-of bp)))
+ (ev:remove-notify bp (new-n-treats (beam-of bp)))
+ (ev:remove-notify bp (new-gantry-angle (beam-of bp)))
+ (ev:remove-notify bp (new-coll-angle (beam-of bp)))
+ (ev:remove-notify bp (new-couch-angle (beam-of bp)))
+ (ev:remove-notify bp (new-couch-ht (beam-of bp)))
+ (ev:remove-notify bp (new-couch-long (beam-of bp)))
+ (ev:remove-notify bp (new-couch-lat (beam-of bp)))
+ (ev:remove-notify bp (new-color (beam-of bp)))
+ (ev:remove-notify bp (new-id (wedge (beam-of bp))))
+ (ev:remove-notify bp (new-rotation (wedge (beam-of bp))))
+ (ev:remove-notify bp (new-arc-size (beam-of bp)))
+ (ev:remove-notify bp (new-atten-factor (beam-of bp))))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/beam-transforms.cl b/prism/src/beam-transforms.cl
new file mode 100644
index 0000000..05a6541
--- /dev/null
+++ b/prism/src/beam-transforms.cl
@@ -0,0 +1,421 @@
+;;;
+;;; beam-transforms
+;;;
+;;; code for computing collimator to view space transforms for various
+;;; views.
+;;;
+;;; 18-Sep-1996 I. Kalet split off from beam-graphics module. Change
+;;; signature to eliminate keywords.
+;;; 4-Feb-1997 I. Kalet add coll-to-couch, couch-to-coll and other
+;;; functions, for dose computation, also use in get-beam-transform
+;;; methods. Eliminate table-postion - always 0, 0, 0. Eliminate
+;;; references to geometry package. Make
+;;; get-transverse-beam-transform call coll-to-couch-transform instead
+;;; of duplicating code.
+;;; 19-Jan-1998 I. Kalet add declarations to matrix-multiply
+;;; et.al. and rewrite the beam transform functions to use a simple
+;;; array instead of multiple values.
+;;; 7-Jul-1998 I. Kalet matrix-multiply also returns a simple array
+;;; instead of multiple values.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------
+
+(defun couch-to-coll-transform (tab gan col)
+
+ "COUCH-TO-COLL-TRANSFORM tab gan col
+
+Computes and returns the terms for the couch to collimator space
+matrix transformation for couch angle tab, gantry angle gan and
+collimator angle col. See Prism Implementation Report for diagrams
+and derivation."
+
+ (declare (type single-float tab gan col))
+ (let* ((trn-rad (* tab *pi-over-180*))
+ (gan-rad (* gan *pi-over-180*))
+ (col-rad (* col *pi-over-180*))
+ (sin-t (sin trn-rad))
+ (cos-t (cos trn-rad))
+ (sin-g (sin gan-rad))
+ (cos-g (cos gan-rad))
+ (sin-c (sin col-rad))
+ (cos-c (cos col-rad))
+ (result (make-array 9 :element-type 'single-float)))
+ (declare (type (simple-array single-float (9)) result)
+ (type single-float gan-rad col-rad trn-rad
+ sin-g cos-g sin-c cos-c sin-t cos-t))
+ (setf (aref result 0) (+ (* cos-c cos-g cos-t)
+ (* sin-c sin-t)) ; r00
+ (aref result 1) (- (* cos-c sin-g)) ; r01
+ (aref result 2) (- (* cos-c cos-g sin-t)
+ (* sin-c cos-t)) ; r02
+
+ (aref result 3) (- (* cos-c sin-t)
+ (* sin-c cos-g cos-t)) ; r10
+ (aref result 4) (* sin-c sin-g) ; r11
+ (aref result 5) (- (+ (* sin-c cos-g sin-t)
+ (* cos-c cos-t))) ; r12
+
+ (aref result 6) (* sin-g cos-t) ; r20
+ (aref result 7) cos-g ; r21
+ (aref result 8) (* sin-g sin-t)) ; r22
+ result))
+
+;;;----------------------------------------------
+
+(defun coll-to-couch-transform (tab gan col)
+
+ "COLL-TO-COUCH-TRANSFORM tab gan col
+
+Computes and returns the terms for the collimator to couch space
+matrix transformation for couch angle tab, gantry angle gan and
+collimator angle col. See Prism Implementation Report for diagrams
+and derivation."
+
+ (declare (type single-float tab gan col))
+ (let* ((trn-rad (* tab *pi-over-180*))
+ (gan-rad (* gan *pi-over-180*))
+ (col-rad (* col *pi-over-180*))
+ (sin-t (sin trn-rad))
+ (cos-t (cos trn-rad))
+ (sin-g (sin gan-rad))
+ (cos-g (cos gan-rad))
+ (sin-c (sin col-rad))
+ (cos-c (cos col-rad))
+ (result (make-array 9 :element-type 'single-float)))
+ (declare (type (simple-array single-float (9)) result)
+ (type single-float gan-rad col-rad trn-rad
+ sin-g cos-g sin-c cos-c sin-t cos-t))
+ (setf (aref result 0) (+ (* cos-t cos-g cos-c)
+ (* sin-t sin-c)) ; r00
+ (aref result 1) (- (* sin-t cos-c)
+ (* cos-t cos-g sin-c)) ; r01
+ (aref result 2) (* cos-t sin-g) ; r02
+
+ (aref result 3) (- (* sin-g cos-c)) ; r10
+ (aref result 4) (* sin-g sin-c) ; r11
+ (aref result 5) cos-g ; r12
+
+ (aref result 6) (- (* sin-t cos-g cos-c)
+ (* cos-t sin-c)) ; r20
+ (aref result 7) (- (+ (* sin-t cos-g sin-c)
+ (* cos-t cos-c))) ; r21
+ (aref result 8) (* sin-t sin-g)) ; r22
+ result))
+
+;;;----------------------------------------------
+
+(defun matrix-multiply (xfrm x y z)
+
+ "MATRIX-MULTIPLY xfrm x y z
+
+returns an array, the x, y and z components of a vector resulting from
+multiplying the 3 by 3 array represented by 1-dimensional array xfrm
+by the vector represented by the components x, y, z."
+
+ (declare (type (simple-array single-float (9)) xfrm)
+ (type single-float x y z))
+ (make-array 3 :element-type 'single-float
+ :initial-contents (list
+ (+ (* (aref xfrm 0) x)
+ (* (aref xfrm 1) y)
+ (* (aref xfrm 2) z))
+ (+ (* (aref xfrm 3) x)
+ (* (aref xfrm 4) y)
+ (* (aref xfrm 5) z))
+ (+ (* (aref xfrm 6) x)
+ (* (aref xfrm 7) y)
+ (* (aref xfrm 8) z)))))
+
+;;;----------------------------------------------
+
+(defmethod beam-transform ((b beam) (tv transverse-view)
+ &optional wedge)
+
+ "BEAM-TRANSFORM b tv &optional wedge
+
+Computes and returns the terms for the collimator to view space matrix
+transformation for beam b and transverse view tv. Calls
+transverse-beam-transform to do the actual work, since the result is
+needed for situations that have no view as well as for a view."
+
+ (transverse-beam-transform b (view-position tv) wedge))
+
+;;;----------------------------------------------
+
+(defun transverse-beam-transform (b vp &optional wedge)
+
+ "TRANSVERSE-BEAM-TRANSFORM b vp &optional wedge
+
+Computes and returns the terms for the collimator to view space matrix
+transformation for beam b and position vp assuming a transverse view
+at vp, though there needn't be an actual view present. The transform
+is computed using the coll-to-couch-transform function above, couch
+displacement values, and the specified position, vp. Twelve values
+are returned in a 1-dimensional simple array -- the homogeneous matrix
+entries:
+
+ r00 r01 r02 r03
+ r10 r11 r12 r13
+ r20 r21 r22 r23
+
+the bottom row is not returned, since it is always 0 0 0 1. If the
+keyword wedge parameter is nil (default) and b has a multileaf
+collimator, then the transform returned is computed with a collimator
+angle of 0.0, regardless of the actual collimator angle of b. If
+wedge is non-nil or b has another type of collimator, then b's actual
+collimator angle is used when computing the transformation."
+
+ (let ((matrix (coll-to-couch-transform (couch-angle b)
+ (gantry-angle b)
+ (if (and (not wedge)
+ (typep (collimator b)
+ 'multileaf-coll))
+ 0.0
+ (collimator-angle b))))
+ (result (make-array 12 :element-type 'single-float)))
+ (declare (type single-float vp)
+ (type (simple-array single-float (*)) matrix result))
+ (setf (aref result 0) (aref matrix 0) ; r00
+ (aref result 1) (aref matrix 1) ; r01
+ (aref result 2) (aref matrix 2) ; r02
+ (aref result 3) (- (the single-float (couch-lateral b))) ; r03
+
+ (aref result 4) (aref matrix 3) ; r10
+ (aref result 5) (aref matrix 4) ; r11
+ (aref result 6) (aref matrix 5) ; r12
+ (aref result 7) (- (the single-float (couch-height b))) ; r13
+
+ (aref result 8) (aref matrix 6) ; r20
+ (aref result 9) (aref matrix 7) ; r21
+ (aref result 10) (aref matrix 8) ; r22
+ (aref result 11) (- 0.0 (+ (the single-float
+ (couch-longitudinal b))
+ vp))) ; r23
+ result))
+
+;;;----------------------------------------------
+
+(defmethod beam-transform ((b beam) (cv coronal-view)
+ &optional wedge)
+
+ "BEAM-TRANSFORM b cv &optional wedge
+
+Computes and returns the terms for the collimator to view space matrix
+transformation for beam b and coronal view cv. The transform is
+computed from b's gantry angle, collimator angle, turntable angle, and
+couch displacement values, and cv's position. Twelve values are
+returned in a 1-dimensional simple array -- the homogeneous matrix
+entries:
+
+ r00 r01 r02 r03
+ r10 r11 r12 r13
+ r20 r21 r22 r23
+
+the bottom row is not returned, since it is always 0 0 0 1. If the
+keyword wedge parameter is nil, the default, and b has a multileaf
+collimator, then the transform returned is computed with a collimator
+angle of 0.0, regardless of the actual collimator angle of b. If
+wedge is non-nil or b has another type of collimator, then b's actual
+collimator angle is used when computing the transformation."
+
+ (let* ((gan-ang (* (the single-float (gantry-angle b))
+ *pi-over-180*))
+ (col-ang (if (and (not wedge)
+ (typep (collimator b) 'multileaf-coll))
+ 0.0
+ (* (the single-float (collimator-angle b))
+ *pi-over-180*)))
+ (trn-ang (* (the single-float (couch-angle b))
+ *pi-over-180*))
+ (sin-g (sin gan-ang))
+ (cos-g (cos gan-ang))
+ (sin-c (sin col-ang))
+ (cos-c (cos col-ang))
+ (sin-t (sin trn-ang))
+ (cos-t (cos trn-ang))
+ (result (make-array 12 :element-type 'single-float)))
+ (declare (type single-float
+ gan-ang col-ang trn-ang
+ sin-g cos-g sin-c cos-c sin-t cos-t)
+ (type (simple-array single-float (12)) result))
+ (setf (aref result 0) (+ (* cos-t cos-g cos-c)
+ (* sin-t sin-c)) ; r00
+ (aref result 1) (- (* sin-t cos-c)
+ (* cos-t cos-g sin-c)) ; r01
+ (aref result 2) (* cos-t sin-g) ; r02
+ (aref result 3) (- (the single-float (couch-lateral b))) ; r03
+
+ (aref result 4) (- (* cos-t sin-c)
+ (* sin-t cos-g cos-c)) ; r10
+ (aref result 5) (+ (* sin-t cos-g sin-c)
+ (* cos-t cos-c)) ; r11
+ (aref result 6) (- (* sin-t sin-g)) ; r12
+ (aref result 7) (the single-float (couch-longitudinal b)) ; r13
+
+ (aref result 8) (- (* sin-g cos-c)) ; r20
+ (aref result 9) (* sin-g sin-c) ; r21
+ (aref result 10) cos-g ; r22
+ (aref result 11) (- (+ (the single-float
+ (couch-height b))
+ (the single-float
+ (view-position cv))))) ; r23
+ result))
+
+;;;----------------------------------------------
+
+(defmethod beam-transform ((b beam) (sv sagittal-view)
+ &optional wedge)
+
+ "BEAM-TRANSFORM b sv &optional wedge
+
+Computes and returns the terms for the collimator to view space matrix
+transformation for beam b and sagittal view sv. The transform is
+computed from b's gantry angle, collimator angle, turntable angle, and
+couch displacement values, and sv's position. Twelve values are
+returned in a 1-dimensional simple array -- the homogeneous matrix
+entries:
+
+ r00 r01 r02 r03
+ r10 r11 r12 r13
+ r20 r21 r22 r23
+
+the bottom row is not returned, since it is always 0 0 0 1. If the
+keyword wedge parameter is nil, the default, and b has a multileaf
+collimator, then the transform returned is computed with a collimator
+angle of 0.0, regardless of the actual collimator angle of b. If
+wedge is non-nil or b has another type of collimator, then b's actual
+collimator angle is used when computing the transformation."
+
+
+ (let* ((gan-ang (* (the single-float (gantry-angle b))
+ *pi-over-180*))
+ (col-ang (if (and (not wedge)
+ (typep (collimator b) 'multileaf-coll))
+ 0.0
+ (* (the single-float (collimator-angle b))
+ *pi-over-180*)))
+ (trn-ang (* (the single-float (couch-angle b))
+ *pi-over-180*))
+ (sin-g (sin gan-ang))
+ (cos-g (cos gan-ang))
+ (sin-c (sin col-ang))
+ (cos-c (cos col-ang))
+ (sin-t (sin trn-ang))
+ (cos-t (cos trn-ang))
+ (result (make-array 12 :element-type 'single-float)))
+ (declare (type single-float
+ gan-ang col-ang trn-ang
+ sin-g cos-g sin-c cos-c sin-t cos-t)
+ (type (simple-array single-float (12)) result))
+ (setf (aref result 0) (- (* sin-t cos-g cos-c)
+ (* cos-t sin-c)) ; r00
+ (aref result 1) (- (+ (* sin-t cos-g sin-c)
+ (* cos-t cos-c))) ; r01
+ (aref result 2) (* sin-t sin-g) ; r02
+ (aref result 3) (- (the single-float
+ (couch-longitudinal b))) ; r03
+
+ (aref result 4) (- (* sin-g cos-c)) ; r10
+ (aref result 5) (* sin-g sin-c) ; r11
+ (aref result 6) cos-g ; r12
+ (aref result 7) (- (the single-float (couch-height b))) ; r13
+
+ (aref result 8) (- (+ (* cos-t cos-g cos-c)
+ (* sin-t sin-c))) ; r20
+ (aref result 9) (- (* cos-t cos-g sin-c)
+ (* sin-t cos-c)) ; r21
+ (aref result 10) (- (* cos-t sin-g)) ; r22
+ (aref result 11) (+ (the single-float
+ (couch-lateral b))
+ (the single-float
+ (view-position sv)))) ; r23
+ result))
+
+;;;----------------------------------------------
+
+(defmethod beam-transform ((b beam) (bev beams-eye-view)
+ &optional wedge)
+
+ "BEAM-TRANSFORM b bev &optional wedge
+
+Computes and returns the terms for the collimator to view space matrix
+transformation for beam b and beam's eye view bev. The implication is
+that b is not the primary beam of bev, and b's portal is just to
+appear in the plane of bev. The transform is computed from b's gantry
+and collimator angles, and gantry angle of the primary beam of the
+bev. Twelve values are returned in a 1-dimensional simple array --
+the homogeneous matrix entries:
+
+ t00 t01 t02 t03
+ t10 t11 t12 t13
+ t20 t21 t22 t23
+
+the bottom row is not returned, since it is always 0 0 0 1. If the
+keyword wedge parameter is nil, the default, and b has a multileaf
+collimator, then the transform returned is computed with a collimator
+angle of 0.0, regardless of the actual collimator angle of b. If
+wedge is non-nil or b has another type of collimator, then b's actual
+collimator angle is used when computing the transformation."
+
+ ;; The matrix r below takes points from patient space to gantry
+ ;; space of the beam's eye view; the matrix s takes points from
+ ;; collimator space of the beam b to patient space (i.e. same as a
+ ;; transverse view at z = 0.0). So composing them (rs) yields the
+ ;; terms of a matrix that takes points from b's collimator space to
+ ;; bev's gantry space.
+
+ (let* ((bev-tr (bev-transform bev))
+ (r00 (aref bev-tr 0))
+ (r01 (aref bev-tr 1))
+ (r02 (aref bev-tr 2))
+ (r03 (aref bev-tr 3))
+ (r10 (aref bev-tr 4))
+ (r11 (aref bev-tr 5))
+ (r12 (aref bev-tr 6))
+ (r13 (aref bev-tr 7))
+ (r20 (aref bev-tr 8))
+ (r21 (aref bev-tr 9))
+ (r22 (aref bev-tr 10))
+ (r23 (aref bev-tr 11))
+ (bt (transverse-beam-transform b 0.0 wedge))
+ (s00 (aref bt 0))
+ (s01 (aref bt 1))
+ (s02 (aref bt 2))
+ (s03 (aref bt 3))
+ (s10 (aref bt 4))
+ (s11 (aref bt 5))
+ (s12 (aref bt 6))
+ (s13 (aref bt 7))
+ (s20 (aref bt 8))
+ (s21 (aref bt 9))
+ (s22 (aref bt 10))
+ (s23 (aref bt 11))
+ (result (make-array 12 :element-type 'single-float)))
+ (declare (type (simple-array single-float (12)) bev-tr bt result)
+ (type single-float
+ r00 r01 r02 r03 r10 r11 r12 r13 r20 r21 r22 r23
+ s00 s01 s02 s03 s10 s11 s12 s13 s20 s21 s22 s23))
+ (setf (aref result 0) (+ (* r00 s00) (* r01 s10) (* r02 s20)) ; t00
+ (aref result 1) (+ (* r00 s01) (* r01 s11) (* r02 s21)) ; t01
+ (aref result 2) (+ (* r00 s02) (* r01 s12) (* r02 s22)) ; t02
+ (aref result 3) (+ (* r00 s03) (* r01 s13)
+ (* r02 s23) r03) ; t03
+
+ (aref result 4) (+ (* r10 s00) (* r11 s10) (* r12 s20)) ; t10
+ (aref result 5) (+ (* r10 s01) (* r11 s11) (* r12 s21)) ; t11
+ (aref result 6) (+ (* r10 s02) (* r11 s12) (* r12 s22)) ; t12
+ (aref result 7) (+ (* r10 s03) (* r11 s13)
+ (* r12 s23) r13) ; t13
+
+ (aref result 8) (+ (* r20 s00) (* r21 s10) (* r22 s20)) ; t20
+ (aref result 9) (+ (* r20 s01) (* r21 s11) (* r22 s21)) ; t21
+ (aref result 10) (+ (* r20 s02) (* r21 s12) (* r22 s22)) ; t22
+ (aref result 11) (+ (* r20 s03) (* r21 s13)
+ (* r22 s23) r23)) ; t23
+ result))
+
+;;;----------------------------------------------
+;;; End.
diff --git a/prism/src/beams-eye-views.cl b/prism/src/beams-eye-views.cl
new file mode 100644
index 0000000..e0d7672
--- /dev/null
+++ b/prism/src/beams-eye-views.cl
@@ -0,0 +1,206 @@
+;;;
+;;; beams-eye-views
+;;;
+;;; This is the implementation of Prism beam's eye views.
+;;;
+;;; 18-Jan-1993 I. Kalet from views module, this code written by J.
+;;; Unger. Also move add-notify code that updates the beams-eye-view
+;;; slots to the beam-view-mediator in beam-graphics.
+;;; 15-Feb-1993 I. Kalet add sad slot to cache the sad from the
+;;; machine database.
+;;; 25-Mar-1993 J. Unger move draw method for contours into beams eye views
+;;; here from contours module to break up a file dependency cycle.
+;;; 11-Apr-1993 I. Kalet replace explicit beam parameter copies with
+;;; reference to beam itself.
+;;; 22-Jul-1993 I. Kalet provide stub method for
+;;; generate-image-from-set so that Show Image in BEV does not crash.
+;;; Later this will produce a DRR. Also move refresh notifys to the
+;;; beam-graphics module.
+;;; 5-Sep-1993 I. Kalet move draw method for contours in bev to
+;;; contour-graphics module.
+;;; 18-Apr-1994 I. Kalet change refs to view origin to new ones
+;;; 16-May-1994 I. Kalet add *bev-pix-per-cm* as default scale factor
+;;; for beams-eye-view.
+;;; 12-Jan-1995 I. Kalet use table-position from view, not beam.
+;;; 21-Jan-1997 I. Kalet eliminate table-position, eliminate
+;;; references to geometry package.
+;;; 19-Jan-1998 I. Kalet cache an array for transform, not a bunch of
+;;; slots, one for each coefficient.
+;;; 11-Jun-1998 I. Kalet don't just set the origin, check if the slots
+;;; are bound first.
+;;; 19-Jun-1998 I. Kalet move method for generate-image-from-set to
+;;; medical-images where the others are.
+;;; 12-Aug-1998 I. Kalet add an event to announce that view background
+;;; image needs recomputing, not just window or level.
+;;; 13-Apr-1999 C. Wilcox added drr-state and drr-args slots to
+;;; support background computation of drr's. Added remove-bg-drr
+;;; for same purpose.
+;;; 4-Sep-2000 I. Kalet rearrange events and announcements for OpenGL
+;;; 16-Dec-2000 I. Kalet add a display-func slot to cache a DRR
+;;; incremental display update function, initialize to nil. Also,
+;;; initialize name to include beam name.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------------
+
+(defparameter *bev-pix-per-cm* 15.0
+ "Default scale factor for newly created beams-eye-view.")
+
+;;;----------------------------------------------------
+
+(defclass beams-eye-view (view)
+
+ ((beam-for :type beam
+ :accessor beam-for
+ :initarg :beam-for
+ :documentation "The beam for which this is the beam's eye
+view.")
+
+ (bev-transform :type (simple-array single-float (12))
+ :accessor bev-transform
+ :documentation "The transformation matrix from
+patient coordinate system to gantry coordinate system.")
+
+ (reset-image :type ev:event
+ :accessor reset-image
+ :initform (ev:make-event)
+ :documentation "Announced when something changes the
+view that requires a new background image, not just a window or level,
+e.g., the gantry angle changes for the beam of the view.")
+
+ (drr-args :accessor drr-args
+ :initform nil
+ :documentation "The current args for the iterative drr
+calculation. It is currently defined as a vector with slots:
+ 0: pixels 1: float-array 2: value-function 3: current-row
+ 4: max-calculated-float.")
+
+ (drr-state :type (member 'running 'stopped 'paused)
+ :accessor drr-state
+ :initform 'stopped
+ :documentation "The current state of the iterative drr
+calculation, if drr-state equals 'stopped then drr-args is undefined.")
+
+ (image-button :accessor image-button
+ :initform nil
+ :documentation "The image button in the view panel.")
+
+ (display-func :accessor display-func
+ :initarg :display-func
+ :documentation "A function of one input, the view,
+that handles incremental display updates during DRR calculations.")
+
+ )
+
+ (:documentation "A beam's eye view is a specialization of a view,
+and is associated with a particular beam. The view is projected from
+the beam's source point to a plane perpendicular to the beam's central
+axis at a location along the axis determined by view-position, which
+defaults to 0.0, in which case the plane passes through the isocenter.
+The beam is referenced here so that objects can be drawn in the view,
+and the transformation matrix needed to draw anatomical objects into
+the view is cached here for efficiency.")
+
+ (:default-initargs :scale *bev-pix-per-cm* :display-func nil)
+
+ )
+
+;;;-------------------------------------
+
+(defun compute-pstruct-transform (bev)
+
+ "compute-pstruct-transform bev
+
+Computes and returns the patient to gantry space transformation matrix
+needed to project pstructs into the plane of the beam's eye view, bev.
+This transformation is based on the location and orientation
+attributes of the the beam's eye view, and consists of a simple array
+of twelve terms -- the the homogeneous matrix entries:
+
+ r00 r01 r02 r03
+ r10 r11 r12 r13
+ r20 r21 r22 r23
+
+The bottom row is not computed, since it is always 0 0 0 1."
+
+ (let* ((gan-ang (* (the single-float (gantry-angle (beam-for bev)))
+ *pi-over-180*))
+ (trn-ang (* (the single-float (couch-angle (beam-for bev)))
+ *pi-over-180*))
+ (sin-g (sin gan-ang))
+ (cos-g (cos gan-ang))
+ (sin-t (sin trn-ang))
+ (cos-t (cos trn-ang))
+ (dx (- (the single-float (couch-lateral (beam-for bev)))))
+ (dy (- (the single-float (couch-height (beam-for bev)))))
+ (dz (- (the single-float (couch-longitudinal (beam-for bev)))))
+ (fac (+ (* dx cos-t) (* dz sin-t)))
+ (tmp-array (make-array 12 :element-type 'single-float)))
+ (declare (single-float gan-ang trn-ang sin-g cos-g sin-t cos-t
+ dx dy dz fac)
+ (type (simple-array single-float (12)) tmp-array))
+ (setf (aref tmp-array 0) (* cos-t cos-g)
+ (aref tmp-array 1) (- sin-g)
+ (aref tmp-array 2) (* sin-t cos-g)
+ (aref tmp-array 3) (- (* dy sin-g) (* cos-g fac))
+
+ (aref tmp-array 4) sin-t
+ (aref tmp-array 5) 0.0
+ (aref tmp-array 6) (- cos-t)
+ (aref tmp-array 7) (- (* dz cos-t) (* dx sin-t))
+
+ (aref tmp-array 8) (* cos-t sin-g)
+ (aref tmp-array 9) cos-g
+ (aref tmp-array 10) (* sin-t sin-g)
+ (aref tmp-array 11) (- (+ (* dy cos-g) (* sin-g fac))))
+ (setf (bev-transform bev) tmp-array)))
+
+;;;-------------------------------------
+
+(defun refresh-bev (bev b &rest other-pars)
+
+ "refresh-bev bev b &rest other-pars
+
+indirectly regenerates graphic primitives for everything in view bev,
+ignoring b and any other parameters, and redraws the view."
+
+ (declare (ignore b other-pars))
+ (compute-pstruct-transform bev)
+ (setf (drr-state bev) 'stopped)
+ (ev:announce bev (reset-image bev))
+ (ev:announce bev (refresh-fg bev))
+ (display-view bev))
+
+;;;-------------------------------------
+
+(defmethod initialize-instance :after ((view beams-eye-view)
+ &rest initargs)
+ (declare (ignore initargs))
+ (setf (name view) (format nil "BEV for ~A" (name (beam-for view))))
+ (compute-pstruct-transform view))
+
+;;;---------------------------------------
+
+(defun remove-bg-drr (bev)
+ (sl:dequeue-bg-event #'(lambda(x) (and (eq (first x) 'drr-bg)
+ (eq (second x) bev)))))
+
+;;;---------------------------------------
+
+(defmethod (setf drr-state) :after (new-state (bev beams-eye-view))
+
+ (let ((ib (image-button bev)))
+ (when ib
+ (cond
+ ((eq new-state 'running)
+ (setf (sl:fg-color ib) 'sl:green))
+ ((eq new-state 'paused)
+ (setf (sl:fg-color ib) 'sl:yellow))
+ ((eq new-state 'stopped)
+ (setf (sl:fg-color ib) 'sl:red))
+ (t (setf (sl:fg-color ib) 'sl:white))))))
+
+;;;---------------------------------------
+;;; End.
diff --git a/prism/src/beams.cl b/prism/src/beams.cl
new file mode 100644
index 0000000..73a059e
--- /dev/null
+++ b/prism/src/beams.cl
@@ -0,0 +1,637 @@
+;;;
+;;; beams
+;;;
+;;; Definitions of radiation beams or treatment fields, and their
+;;; methods.
+;;;
+;;; 2-Sep-1992 I. Kalet created from old rtp-objects
+;;; 7-Sep-1992 I. Kalet make collimator classes, and make collimator
+;;; part of beam, instead of a lot of beam subclasses
+;;; 18-Sep-1992 I. Kalet beam panels code moved to beam-panels module
+;;; 29-Nov-1992 I. Kalet add a table-position slot to cache this info
+;;; 29-Dec-1992 I. Kalet add accessor to blocks slot, change machine
+;;; slot type from symbol to string.
+;;; 16-Feb-1993 I. Kalet add initialization of machine slot, and
+;;; new-machine event, don't save new-machine
+;;; 22-Apr-1993 I. Kalet add code for installing different types of
+;;; collimators as needed, add new-wedge event and wedge setf method
+;;; 24-Aug-1993 J. Unger change tray-factor to atten-factor, add
+;;; several more attributes for additional quantities output from
+;;; dose computation program. [TRAY-FACTOR later added back.]
+;;; 11-Oct-1993 J. Unger replace dose-array attribute with dose-result.
+;;; 19-Oct-1993 J. Unger fix not-saved method for beams; remove old
+;;; attrs, make result invalid when relevant attributes of a beam change.
+;;; 26-Oct-1993 I. Kalet change attribute name from dose-result to
+;;; result, don't invalidate result when color changes.
+;;; 22-Dec-1993 J. Unger make inclusion of result attribute in not-saved
+;;; method conditional on value of *save-plan-dose*.
+;;; 3-Jan-1994 I. Kalet make table-position a method, not a slot, put
+;;; in pointer to plan instead of keeping a copy of table-position.
+;;; 18-Feb-1994 I. Kalet implement copy-beam and make more modular
+;;; 5-May-1994 J. Unger split 'valid' into 'valid-points' and 'valid-grid'.
+;;; 16-May-1994 I. Kalet add beam-for initialization in collimator.
+;;; 1-Jun-1994 I. Kalet make blocks a collection, set beam-for of
+;;; each block when inserted into the blocks collection.
+;;; 2-Jun-1994 J. Unger add announcement for change to atten-factor.
+;;; 3-Jun-1994 J. Unger implement rest of copy-beam operations.
+;;; 5-Jun-1994 J. Unger add new-wedge-orient announcement. Also delete the
+;;; beam's wedge &reset wedge angle if the machine changes.
+;;; 23-Jun-1994 I. Kalet change a lot of floats to single-floats etc.
+;;; also move copy-block to beam-blocks.
+;;; 24-Jun-1994 J. Unger change wedge to an object.
+;;; 05-Jul-1994 J. Unger add code to invalidate dose result if any collimator
+;;; attributes change.
+;;; 07-Jul-1994 J. Unger change color to display-color in copy-wedge.
+;;; 07-Jul-1994 J. Unger modify copy-beam to take keyword copy-name param.
+;;; 12-Jul-1994 J. Unger update plan timestamp if collim attrs change.
+;;; 05-Aug-1994 J. Unger make type check in (setf machine) :after method
+;;; more specific.
+;;; 24-Aug-1994 J. Unger fix bug in copy-wedge, adj init-inst so a wedge
+;;; supplied at initialization time is not overwritten.
+;;; 26-Aug-1994 J. Unger fix bug in copy-wedge-rotation.
+;;; 29-Aug-1994 J. Unger fix *another* bug in copy-wedge.
+;;; 04-Sep-1994 J. Unger move/copy components of (setf collimator) to
+;;; (setf plan-of) and (setf machine) methods. Also move creation of
+;;; wedge from init-inst to make-beam.
+;;; 03-Oct-1994 J. Unger add display-axis & axis-changed attributes.
+;;; 04-Oct-1994 J. Unger add keyword to copy-beam to ignore parent plan.
+;;; 19-Oct-1994 J. Unger add add-notifies to invalidate beam's dose results
+;;; & update plan timestamp when a block's vertices or transmission changes.
+;;; Also update plan timestamp when block's name changes.
+;;; 07-Nov-1994 J. Unger fix unintentional timestamp update in copy beam.
+;;; 22-Jan-1995 I. Kalet put isodist function here and use it lots of
+;;; places. Move copy-wedge and copy-wedge-rotation to wedges, and
+;;; reparametrize. Move copy-coll to collimators and reparametrize.
+;;; Remove beam-block method for invalidate-etc. - not needed. The
+;;; beam should be the target of the announcement, not the block.
+;;; Handle wedge updates here with event notification, not setf
+;;; methods in the wedge module. Add update-plan event instead of
+;;; operating on plan-of in setf methods. Don't set beam-for in
+;;; blocks or collimators - no longer a block or collimator attrib.
+;;; Take out table-position - no longer needed. Take out plan-of,
+;;; not needed. Put new-coll-set registration in plans module.
+;;; 11-Sep-1995 I. Kalet don't pass initargs on to the make-wedge
+;;; call, since there should be no relevant parameters in the call to
+;;; make-beam. The new beam will have no wedge. It can be set afterward.
+;;; 5-Jan-1996 I. Kalet delete blocks when new machine has a
+;;; multileaf collimator or is an electron beam, per V1.1 spec.
+;;; 15-Jan-1997 I. Kalet add cal-factor function.
+;;; 3-Mar-1997 I. Kalet delete blocks when changing collimator type
+;;; to srs as well as the portal collim. types, multileaf and electron.
+;;; 5-Jun-1997 I. Kalet in therapy-machine, collimator is now
+;;; collimator-type, make machine return the machine, machine-name
+;;; returns and updates the string in the machine slot.
+;;; 29-Aug-1997 BobGian commented-out CAL-FACTOR function - nowhere
+;;; used.
+;;; 16-Sep-1997 I. Kalet explicitly provide machine database
+;;; parameters, as they are no longer optional.
+;;; 26-Oct-1997 I. Kalet modify for new wedge id semantics and therapy
+;;; machine structure for wedge-info. No need for fancy wedge
+;;; rotation setting, let default be used in make-beam, or value from
+;;; file when using get-object in reading in case data. Similarly
+;;; when changing machine.
+;;; 19-Dec-1999 I. Kalet copy-block now takes keyword parameter :copy-name
+;;; 30-Jan-2000 I. Kalet always delete wedge when copying a beam
+;;; 22-Feb-2000 I. Kalet change copy-beam to just copy, defer policies to
+;;; places where needed.
+;;; 29-Mar-2000 I. Kalet implement copy 180 as reflected-beam function,
+;;; treat CNTS and SL20 differently.
+;;; 11-Jul-2000 I. Kalet correct misplaced parentheses error in block
+;;; reflection code in reflect-beam.
+;;; 13-Dec-2000 I. Kalet add drr-cache, so need not recompute pixels
+;;; for views, MLC panel and block panel.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defclass beam (generic-prism-object)
+
+ ((machine :type string
+ :initarg :machine
+ :initform (first (get-therapy-machine-list
+ *machine-index-directory*))
+ :accessor machine-name
+ :documentation "The unique string naming the type of
+machine used for this beam, e.g., Clinac 2500 6MV, obtained from the
+machine database by therapy machine access functions. The
+machine-name accessor returns and updates the string, and the machine
+function returns the machine corresponding to the name.")
+
+ (new-machine :type ev:event
+ :accessor new-machine
+ :initform (ev:make-event))
+
+ (gantry-angle :type single-float
+ :accessor gantry-angle
+ :initarg :gantry-angle)
+
+ (new-gantry-angle :type ev:event
+ :accessor new-gantry-angle
+ :initform (ev:make-event))
+
+ (arc-size :type single-float
+ :initarg :arc-size
+ :accessor arc-size)
+
+ (new-arc-size :type ev:event
+ :accessor new-arc-size
+ :initform (ev:make-event))
+
+ (collimator :initarg :collimator
+ :accessor collimator
+ :documentation "The collimator is an object, an
+instance of one of the various types of collimators that can be on a
+machine. This is an alternate to making a series of beam subclasses
+with different types of collimators.")
+
+ (collimator-angle :type single-float
+ :initarg :collimator-angle
+ :accessor collimator-angle)
+
+ (new-coll-angle :type ev:event
+ :accessor new-coll-angle
+ :initform (ev:make-event))
+
+ (monitor-units :type single-float
+ :initarg :monitor-units
+ :accessor monitor-units)
+
+ (new-mu :type ev:event
+ :accessor new-mu
+ :initform (ev:make-event))
+
+ (n-treatments :type integer
+ :initarg :n-treatments
+ :accessor n-treatments)
+
+ (new-n-treats :type ev:event
+ :accessor new-n-treats
+ :initform (ev:make-event))
+
+ (couch-lateral :type single-float
+ :initarg :couch-lateral
+ :accessor couch-lateral)
+
+ (new-couch-lat :type ev:event
+ :accessor new-couch-lat
+ :initform (ev:make-event))
+
+ (couch-longitudinal :type single-float
+ :initarg :couch-longitudinal
+ :accessor couch-longitudinal)
+
+ (new-couch-long :type ev:event
+ :accessor new-couch-long
+ :initform (ev:make-event))
+
+ (couch-height :type single-float
+ :initarg :couch-height
+ :accessor couch-height)
+
+ (new-couch-ht :type ev:event
+ :accessor new-couch-ht
+ :initform (ev:make-event))
+
+ (couch-angle :type single-float
+ :initarg :couch-angle
+ :accessor couch-angle)
+
+ (new-couch-angle :type ev:event
+ :accessor new-couch-angle
+ :initform (ev:make-event))
+
+ (wedge :type wedge
+ :initarg :wedge
+ :initform (make-wedge)
+ :accessor wedge
+ :documentation "The beam's wedge object.")
+
+ (atten-factor :type single-float
+ :initarg :atten-factor
+ :accessor atten-factor
+ :documentation "A factor between 0.0 and 1.0 which is
+is used in dose computation to attenuate the strength of the beam.")
+
+ (new-atten-factor :type ev:event
+ :accessor new-atten-factor
+ :initform (ev:make-event)
+ :documentation "Announced when the attenuation factor
+changes.")
+
+ (blocks :accessor blocks
+ :initform (coll:make-collection)
+ :documentation "A collection of beam-block objects")
+
+ (display-color :initarg :display-color
+ :accessor display-color)
+
+ (new-color :type ev:event
+ :accessor new-color
+ :initform (ev:make-event))
+
+ (update-plan :type ev:event
+ :accessor update-plan
+ :initform (ev:make-event))
+
+ (result :type dose-result
+ :initarg :result
+ :accessor result
+ :initform (make-dose-result)
+ :documentation "The result of computing dose from this beam
+is stored in the beam's result.")
+
+ (display-axis :type (member t nil)
+ :initarg :display-axis
+ :accessor display-axis
+ :documentation "A boolean attribute which, when non-nil,
+causes the beam's central axis and tic marks to appear in a view when the
+beam's isocenter lies in the plane of the view.")
+
+ (axis-changed :type ev:event
+ :accessor axis-changed
+ :initform (ev:make-event))
+
+ (drr-cache :accessor drr-cache
+ :initform nil
+ :documentation "A place to cache the pixel array for a
+DRR for this beam, so it can appear in several places without
+recomputing.")
+
+ )
+
+ (:default-initargs :gantry-angle 0.0
+ :arc-size 0.0
+ :collimator-angle 0.0
+ :monitor-units 100.0
+ :n-treatments 1
+ :couch-lateral 0.0
+ :couch-longitudinal 0.0
+ :couch-height 0.0
+ :couch-angle 0.0
+ :atten-factor 1.0
+ :display-color 'sl:red
+ :display-axis t)
+
+ (:documentation "Class beam defines the generic treatment parameters
+for a beam, without specifics about the collimator type. The wedge
+slot identifies which wedge object is in use from the set available
+for the machine in question. If arc-size is 0 the beam is a fixed
+field, otherwise gantry-angle specifies the starting point of the
+moving field.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod machine ((bm beam))
+
+ "returns the actual machine, not the string naming it."
+
+ (get-therapy-machine (machine-name bm)
+ *therapy-machine-database*
+ *machine-index-directory*))
+
+;;;---------------------------------------------
+
+(defmethod slot-type ((object beam) slotname)
+
+ (case slotname
+ (blocks :collection)
+ ((collimator result wedge) :object)
+ (plan-of :ignore)
+ (otherwise :simple)))
+
+(defmethod not-saved ((object beam))
+
+ (append (call-next-method)
+ '(new-machine new-gantry-angle new-arc-size new-coll-angle
+ new-mu new-n-treats new-couch-lat new-couch-long
+ new-couch-ht new-couch-angle new-color axis-changed
+ new-atten-factor result update-plan drr-cache)))
+
+;;;---------------------------------------------
+
+(defmethod invalidate-results ((bm beam) &rest ignored)
+
+ "invalidate-results (bm beam) &rest ignored
+
+An action function that invalidates a beam's dose results and
+announces update-plan event. Called in response to various changes to
+beam attributes, and attributes of a beam's component objects."
+
+ (declare (ignore ignored))
+ (setf (valid-grid (result bm)) nil)
+ (setf (valid-points (result bm)) nil)
+ (ev:announce bm (update-plan bm)))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((b beam) &rest initargs)
+
+ "this method makes sure that addition of a block to beam b
+invalidates b's dose results, and registers changes in the block's
+parameters."
+
+ (declare (ignore initargs))
+ (ev:add-notify b (coll:inserted (blocks b))
+ #'(lambda (bm blkset blk)
+ (declare (ignore blkset))
+ (invalidate-results bm)
+ (ev:add-notify bm (new-vertices blk)
+ #'invalidate-results)
+ (ev:add-notify bm (new-transmission blk)
+ #'invalidate-results)
+ (ev:add-notify bm (new-name blk)
+ #'(lambda (bm ann val)
+ (declare (ignore ann val))
+ (ev:announce bm (update-plan bm))))))
+ (ev:add-notify b (coll:deleted (blocks b))
+ #'(lambda (bm blkset blk)
+ (declare (ignore blkset))
+ (invalidate-results bm)
+ (ev:remove-notify bm (new-vertices blk))
+ (ev:remove-notify bm (new-transmission blk))
+ (ev:remove-notify bm (new-name blk)))))
+
+;;;---------------------------------------------
+
+(defun make-beam (beam-name &rest initargs)
+
+ "make-beam beam-name &rest initargs
+
+returns a new instance of a beam, with specified parameters, but no
+wedge and no blocks."
+
+ (let ((b (apply #'make-instance 'beam
+ :name (if (equal beam-name "")
+ (format nil "~A" (gensym "BEAM-"))
+ beam-name)
+ initargs)))
+ (setf (collimator b) ;; after method does event registration
+ (apply #'make-instance
+ (collimator-type (machine b))
+ :allow-other-keys t
+ initargs))
+ (ev:add-notify b (new-id (wedge b)) ;; wedge is initialized above
+ #'invalidate-results)
+ (ev:add-notify b (new-rotation (wedge b))
+ #'invalidate-results)
+ b))
+
+;;;---------------------------------------------
+
+(defmethod (setf name) :after (new-name (bm beam))
+
+ (declare (ignore new-name))
+ (ev:announce bm (update-plan bm)))
+
+;;;---------------------------------------------
+
+(defmethod (setf machine-name) :after (new-mach (b beam))
+
+ "If collimator type has changed, create new collimator and set
+reasonable values based on old. Also set wedge ID to 0."
+
+ ;; invalidating dose here covers when the collimator type changes,
+ ;; so we don't have to repeat this in a (setf collimator) method.
+ (invalidate-results b)
+ (setf (drr-cache b) nil)
+ (let ((new-coll-type (collimator-type (machine b)))
+ (old-coll (collimator b)))
+ (unless (eql (type-of old-coll) new-coll-type)
+ (setf (collimator b) (replace-coll old-coll new-coll-type))
+ (typecase (collimator b)
+ (portal-coll
+ (dolist (blk (coll:elements (blocks b)))
+ (coll:delete-element blk (blocks b))))))
+ (setf (id (wedge b)) 0))
+ (ev:announce b (new-machine b) new-mach))
+
+;;;---------------------------------------------
+
+(defmethod (setf gantry-angle) :after (new-angle (b beam))
+
+ (invalidate-results b)
+ (setf (drr-cache b) nil)
+ (ev:announce b (new-gantry-angle b) new-angle))
+
+;;;---------------------------------------------
+
+(defmethod (setf arc-size) :after (new-size (b beam))
+
+ (invalidate-results b)
+ (ev:announce b (new-arc-size b) new-size))
+
+;;;---------------------------------------------
+
+(defmethod (setf collimator-angle) :after (new-angle (b beam))
+
+ (invalidate-results b)
+ (ev:announce b (new-coll-angle b) new-angle))
+
+;;;---------------------------------------------
+
+(defmethod (setf collimator) :after (new-coll (b beam))
+
+ (ev:add-notify b (new-coll-set new-coll)
+ #'invalidate-results))
+
+;;;---------------------------------------------
+
+(defmethod (setf monitor-units) :after (new-units (b beam))
+
+ (ev:announce b (update-plan b))
+ (ev:announce b (new-mu b) new-units))
+
+;;;---------------------------------------------
+
+(defmethod (setf n-treatments) :after (new-n (b beam))
+
+ (ev:announce b (update-plan b))
+ (ev:announce b (new-n-treats b) new-n))
+
+;;;---------------------------------------------
+
+(defmethod (setf couch-lateral) :after (new-value (b beam))
+
+ (setf (drr-cache b) nil)
+ (invalidate-results b)
+ (ev:announce b (new-couch-lat b) new-value))
+
+;;;---------------------------------------------
+
+(defmethod (setf couch-longitudinal) :after (new-value (b beam))
+
+ (setf (drr-cache b) nil)
+ (invalidate-results b)
+ (ev:announce b (new-couch-long b) new-value))
+
+;;;---------------------------------------------
+
+(defmethod (setf couch-height) :after (new-value (b beam))
+
+ (setf (drr-cache b) nil)
+ (invalidate-results b)
+ (ev:announce b (new-couch-ht b) new-value))
+
+;;;---------------------------------------------
+
+(defmethod (setf couch-angle) :after (new-angle (b beam))
+
+ (setf (drr-cache b) nil)
+ (invalidate-results b)
+ (ev:announce b (new-couch-angle b) new-angle))
+
+;;;---------------------------------------------
+
+(defmethod (setf display-color) :after (new-c (b beam))
+
+ (ev:announce b (new-color b) new-c))
+
+;;;---------------------------------------------
+
+(defmethod (setf display-axis) :after (new-val (b beam))
+
+ (ev:announce b (axis-changed b) new-val))
+
+;;;---------------------------------------------
+
+(defmethod (setf atten-factor) :after (new-val (b beam))
+
+ (invalidate-results b)
+ (ev:announce b (new-atten-factor b) new-val))
+
+;;;---------------------------------------------
+
+(defun isodist (bm)
+
+ "isodist bm
+
+The source to axis distance of the beam bm."
+
+ (cal-distance (machine bm)))
+
+;;;---------------------------------------------
+
+(defmethod copy ((bm beam))
+
+ "copy bm
+
+creates a copy of the beam bm, including the blocks and the wedge. If
+a more complex copy protocol, i.e., reflecting the blocks, is desired,
+explicitly modify the new, copied, beam afterward."
+
+ (let ((new-b (make-beam (name bm)
+ :machine (machine-name bm)
+ :gantry-angle (gantry-angle bm)
+ :arc-size (arc-size bm)
+ :collimator-angle (collimator-angle bm)
+ :monitor-units (monitor-units bm)
+ :n-treatments (n-treatments bm)
+ :couch-lateral (couch-lateral bm)
+ :couch-longitudinal (couch-longitudinal bm)
+ :couch-height (couch-height bm)
+ :couch-angle (couch-angle bm)
+ :atten-factor (atten-factor bm))))
+ (setf (collimator new-b) (copy (collimator bm)))
+ (setf (id (wedge new-b)) (id (wedge bm)))
+ (setf (rotation (wedge new-b)) (rotation (wedge bm)))
+ (dolist (blk (coll:elements (blocks bm)))
+ (coll:insert-element (copy blk) (blocks new-b)))
+ new-b))
+
+;;;---------------------------------------------
+
+(defun reflected-beam (bm)
+
+ "reflected-beam bm
+
+returns a copy of bm, reflected 180 degrees, with a rather complex
+protocol concerning collimator rotation and settings."
+
+ (let* ((new-beam (copy bm))
+ (blklist (coll:elements (blocks new-beam)))
+ (col-angle (collimator-angle new-beam))
+ (reflect-y nil))
+ (setf (name new-beam) (format nil "~A" (gensym "BEAM-")))
+ (setf (gantry-angle new-beam)
+ (mod (+ (gantry-angle bm) 180.0) 360.0))
+ ;; this is the hairy part
+ (typecase (collimator new-beam)
+ (symmetric-jaw-coll (if (and (member col-angle '(90.0 270.0))
+ (zerop (id (wedge new-beam))))
+ (setf reflect-y t)
+ (unless (zerop col-angle)
+ (setf (collimator-angle new-beam)
+ (- 360.0 col-angle)))))
+ (combination-coll (if (and (member col-angle '(90.0 270.0))
+ (zerop (id (wedge new-beam))))
+ (setf reflect-y t)
+ (let ((tmp (x-inf (collimator new-beam))))
+ (setf (x-inf (collimator new-beam))
+ (x-sup (collimator new-beam))
+ (x-sup (collimator new-beam)) tmp)
+ (unless (zerop col-angle)
+ (setf (collimator-angle new-beam)
+ (- 360.0 col-angle))))))
+ (variable-jaw-coll (if (and (member col-angle '(90.0 270.0))
+ (zerop (id (wedge new-beam))))
+ (let ((tmp (y-inf (collimator new-beam))))
+ (setf (y-inf (collimator new-beam))
+ (y-sup (collimator new-beam))
+ (y-sup (collimator new-beam)) tmp
+ reflect-y t))
+ (let ((tmp (x-inf (collimator new-beam))))
+ (setf (x-inf (collimator new-beam))
+ (x-sup (collimator new-beam))
+ (x-sup (collimator new-beam)) tmp)
+ (unless (zerop col-angle)
+ (setf (collimator-angle new-beam)
+ (- 360.0 col-angle))))))
+ (cnts-coll (if (member col-angle '(90.0 270.0))
+ (let ((tmp (y-inf (collimator new-beam))))
+ (setf (y-inf (collimator new-beam))
+ (y-sup (collimator new-beam))
+ (y-sup (collimator new-beam)) tmp
+ reflect-y t))
+ (let ((tmp (x-inf (collimator new-beam))))
+ (setf (x-inf (collimator new-beam))
+ (x-sup (collimator new-beam))
+ (x-sup (collimator new-beam)) tmp)
+ (unless (zerop col-angle)
+ (setf (collimator-angle new-beam)
+ (- 360.0 col-angle))))))
+ (multileaf-coll (cond ((member col-angle '(90.0 270.0))
+ (if (= (id (wedge new-beam)) 5) ;; internal wedge
+ (setf (collimator-angle new-beam)
+ (- 360.0 col-angle))))
+ ((member col-angle '(0.0 180.0))
+ (unless (member (id (wedge new-beam)) '(0 5))
+ (setf (collimator-angle new-beam)
+ (mod (+ (collimator-angle new-beam) 180)
+ 360))))
+ (t (setf (collimator-angle new-beam)
+ (- 360.0 col-angle))))
+ (setf (vertices (collimator new-beam))
+ (mapcar #'(lambda (pt)
+ (list (- (first pt)) (second pt)))
+ (vertices (collimator new-beam)))))
+ (electron-coll (setf (vertices (collimator new-beam))
+ (mapcar #'(lambda (pt)
+ (list (- (first pt)) (second pt)))
+ (vertices (collimator new-beam))))))
+ (setf (id (wedge new-beam)) 0)
+ ;; reflect either the x or y coordinates of the block vertices
+ (dolist (blk blklist)
+ (setf (vertices blk)
+ (if reflect-y
+ (mapcar #'(lambda (pt) (list (first pt) (- (second pt))))
+ (vertices blk))
+ (mapcar #'(lambda (pt) (list (- (first pt)) (second pt)))
+ (vertices blk)))))
+ new-beam))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/bev-draw-all.cl b/prism/src/bev-draw-all.cl
new file mode 100644
index 0000000..d461e12
--- /dev/null
+++ b/prism/src/bev-draw-all.cl
@@ -0,0 +1,36 @@
+;;;
+;;; bev-draw-all
+;;;
+;;; contains the bev-draw-all function in order to break circularity
+;;; through beam-mediators.
+;;;
+;;; 10-May-1997 I. Kalet created
+;;; 2-Dec-2000 I. Kalet take out display-view - redundant call
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defun bev-draw-all (bev pln pat &optional omit)
+
+ "bev-draw-all bev pln pat &optional omit
+
+draws the organs etc. from pat, beams from pln into view bev, omitting
+the object specified by omit, either a beam or a block, then refreshes
+the view pixmap."
+
+ (compute-pstruct-transform bev)
+ ;; create all the primitives from all the objects
+ (dolist (tar (coll:elements (targets pat))) (draw tar bev))
+ (dolist (tum (coll:elements (findings pat))) (draw tum bev))
+ (dolist (org (coll:elements (anatomy pat))) (draw org bev))
+ (dolist (pt (coll:elements (points pat))) (draw pt bev))
+ (dolist (bm (coll:elements (beams pln)))
+ (unless (eq omit bm)
+ (draw bm bev)
+ (dolist (blk (coll:elements (blocks bm)))
+ (unless (eq omit blk)
+ (draw-beam-block blk bev bm))))))
+
+;;;----------------------------------------------
diff --git a/prism/src/bev-graphics.cl b/prism/src/bev-graphics.cl
new file mode 100644
index 0000000..a161af7
--- /dev/null
+++ b/prism/src/bev-graphics.cl
@@ -0,0 +1,342 @@
+;;;
+;;; bev-graphics
+;;;
+;;; Defines draw methods for contours and volumes in beams-eye-views
+;;;
+;;; 1-Apr-1994 I. Kalet extracted from contour-graphics and
+;;; volume-graphics to reduce dependencies.
+;;; 18-Apr-1994 I. Kalet changed refs to view origin
+;;; 25-Apr-1994 J. Unger add draw method for points into bev
+;;; 1-Jun-1994 I. Kalet add bev-draw-all here, taken from coll-panels
+;;; 7-Jul-1994 J. Unger add drawing of points to bev-draw-all.
+;;; 7-Sep-1994 J. Unger reorder drawing in bev-draw-all so tumor drawn
+;;; last, and appears 'above' organs.
+;;; 10-Oct-1994 J. Unger fix omission in mark bev draw method that caused
+;;; points not to draw correctly for bev planes off the isocenter.
+;;; 12-Jan-1995 I. Kalet use isodist function. Pass plan and patient to
+;;; bev-draw-all.
+;;; 5-Sep-1995 I. Kalet eliminate some local variables to improve
+;;; performance. Also, absorb draw method for contour in bev into
+;;; draw method for pstruct, and rearrange code for speed.
+;;; 9-Oct-1996 I. Kalet explicitly draw blocks in
+;;; bev-draw-all, since the beam draw method does not do it anymore.
+;;; Also, make parameters to bev-draw-all required, not keywords.
+;;; Also, move draw method for beams-eye-view and other beam in
+;;; beams-eye-view code here from beam-graphics. Add package name for
+;;; find-dashed-color, now in SLIK. Move marker constants here from
+;;; beam-graphics, used only here.
+;;; 5-Dec-1996 I. Kalet don't generate graphic primitives if color is
+;;; invisible
+;;; 12-Dec-1996 I. Kalet pass vertices, not portal, to draw-bev-wedge
+;;; 24-Jan-1997 I. Kalet eliminate reference to geometry package. Also
+;;; portal is now just the vertices, not a contour object.
+;;; 10-May-1997 I. Kalet move bev-draw-all from here to separate file
+;;; to eliminate circularity.
+;;; 20-Jan-1998 I. Kalet beam transform now array, not multiple
+;;; values, and array cached in bev, not individual slots.
+;;; 21-Apr-1999 I. Kalet change sl:invisible to 'sl:invisible.
+;;; 23-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 23-Oct-1999 I. Kalet preserve declutter information if beam was
+;;; already in view - the visible attribute of the graphic prim.
+;;; 30-Jul-2002 I. Kalet slight mod for point method to keep
+;;; consistent with addition of :around general method.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defconstant *bev-marker-radius* 2 "Determines the size of markers along
+the primary beam's portal outline (and those of its blocks) in a bev.")
+
+(defconstant *bev-marker-size* (* 2 *bev-marker-radius*) "Twice the radius")
+
+;;;--------------------------------------
+
+(defmethod draw ((pstr pstruct) (bev beams-eye-view))
+
+ "draw (pstr pstruct) (bev beams-eye-view)
+
+This method draws all the contours in the pstruct into a beam's eye
+view."
+
+ (if (eql (display-color pstr) 'sl:invisible)
+ (setf (foreground bev) (remove pstr (foreground bev) :key #'object))
+ (let* ((prim (find pstr (foreground bev) :key #'object))
+ (color (sl:color-gc (display-color pstr)
+ (sl:colormap (picture bev))))
+ (bev-tr (bev-transform bev))
+ (r00 (aref bev-tr 0))
+ (r01 (aref bev-tr 1))
+ (r02 (aref bev-tr 2))
+ (r03 (aref bev-tr 3))
+ (r10 (aref bev-tr 4))
+ (r11 (aref bev-tr 5))
+ (r12 (aref bev-tr 6))
+ (r13 (aref bev-tr 7))
+ (r20 (aref bev-tr 8))
+ (r21 (aref bev-tr 9))
+ (r22 (aref bev-tr 10))
+ (r23 (aref bev-tr 11))
+ (sid (isodist (beam-for bev)))
+ (diffpix (* (the single-float (scale bev))
+ (- sid (the single-float (view-position bev)))))
+ (xorig (x-origin bev))
+ (yorig (y-origin bev))
+ (fac 0.0))
+ (declare (single-float r00 r01 r02 r03 r10 r11 r12 r13
+ r20 r21 r22 r23 sid diffpix fac)
+ (fixnum xorig yorig)
+ (type (simple-array single-float (12)) bev-tr))
+ (unless prim
+ (setq prim (make-lines-prim nil color :object pstr))
+ (push prim (foreground bev)))
+ (setf (color prim) color
+ (points prim) nil)
+ (dolist (con (contours pstr))
+ ;; no need to have separate draw method for contour in bev -
+ ;; just do it all right here for efficiency.
+ (let* ((px 0.0)
+ (py 0.0)
+ (pz (z con))
+ (z0 (+ (* r02 pz) r03)) ;; cache loop invariants
+ (z1 (+ (* r12 pz) r13))
+ (z2 (+ (* r22 pz) r23))
+ (pix-list nil))
+ (declare (single-float px py pz z0 z1 z2))
+ (dolist (pt (vertices con))
+ (setq px (first pt)
+ py (second pt))
+ (setq fac (/ diffpix (- sid (+ (* r20 px) (* r21 py) z2))))
+ (push (- yorig (round (* fac (+ (* r10 px) (* r11 py) z1))))
+ pix-list) ;; push y first
+ (push (+ xorig (round (* fac (+ (* r00 px) (* r01 py) z0))))
+ pix-list)) ;; then x
+ (push (nconc pix-list (list (first pix-list) (second pix-list)))
+ (points prim)))))))
+
+;;;--------------------------------------
+
+(defmethod draw ((pt mark) (bev beams-eye-view))
+
+ "draw (pt mark) (bev beams-eye-view)
+
+This method draws a point in a beam's eye view."
+
+ (let* ((s-prim (find-if #'(lambda (prim)
+ (and (eq (object prim) pt)
+ (typep prim 'segments-prim)))
+ (foreground bev)))
+ (c-prim (find-if #'(lambda (prim)
+ (and (eq (object prim) pt)
+ (typep prim 'characters-prim)))
+ (foreground bev)))
+ (color (sl:color-gc (display-color pt)
+ (sl:colormap (picture bev))))
+ (bev-tr (bev-transform bev))
+ (px (x pt))
+ (py (y pt))
+ (pz (z pt))
+ (sid (isodist (beam-for bev)))
+ (fac (/ (- sid (the single-float (view-position bev)))
+ (- sid (+ (* (aref bev-tr 8) px)
+ (* (aref bev-tr 9) py)
+ (* (aref bev-tr 10) pz)
+ (aref bev-tr 11)))))
+ (ppcm (scale bev)))
+ (declare (single-float px py pz sid fac ppcm)
+ (type (simple-array single-float (12)) bev-tr))
+ (unless s-prim
+ (setq s-prim (make-segments-prim nil color :object pt))
+ (push s-prim (foreground bev))
+ (setq c-prim (make-characters-prim nil nil nil color :object pt))
+ (push c-prim (foreground bev)))
+ (setf (color s-prim) color)
+ (setf (color c-prim) color)
+ (setf (characters c-prim) (write-to-string (id pt)))
+ (multiple-value-bind (hatchmark x-anchor y-anchor)
+ (pixel-point (+ (* (aref bev-tr 0) px)
+ (* (aref bev-tr 1) py)
+ (* (aref bev-tr 2) pz)
+ (aref bev-tr 3))
+ (+ (* (aref bev-tr 4) px)
+ (* (aref bev-tr 5) py)
+ (* (aref bev-tr 6) pz)
+ (aref bev-tr 7))
+ (* ppcm fac)
+ (x-origin bev)
+ (y-origin bev))
+ (setf (points s-prim) hatchmark)
+ (setf (x c-prim) x-anchor)
+ (setf (y c-prim) y-anchor))))
+
+;;;----------------------------------------------
+
+(defmethod draw ((b beam) (v beams-eye-view))
+
+ "draw (b beam) (v beams-eye-view)
+
+Computes the projection of beam b into beams-eye-view v and adds two
+graphics primitives, solid and dashed, containing the projected
+segments to v's foreground display list. This includes the drawing of
+the beam's isocenter and central axis, and the wedge. Does NOT draw
+the beam's blocks."
+
+ (if (eql (display-color b) 'sl:invisible)
+ (setf (foreground v) (remove b (foreground v) :key #'object))
+ (if (eq b (beam-for v)) (draw-primary-beam-into-bev b v)
+ (progn
+ ;; start with new gp's each time, to avoid having to look for
+ ;; and disambiguate the solid and dashed segment-prims, which
+ ;; would be very complicated, but first catch the visible
+ ;; attribute of a beam graphic prim if present.
+ (let ((visible (aif (find b (foreground v) :key #'object)
+ (visible it) t)))
+ (setf (foreground v) (remove b (foreground v) :key #'object))
+ (let* ((pic (picture v))
+ (solid-clr (sl:color-gc (display-color b)
+ (sl:colormap pic)))
+ (solid-prim (get-segments-prim b v solid-clr))
+ (dashed-prim (get-segments-prim
+ b v
+ (sl:find-dashed-color solid-clr)))
+ (bt (beam-transform b v))
+ (sad (isodist (beam-for v)))
+ (scale (* (scale v) (/ (- sad (the single-float
+ (view-position v)))
+ sad)))
+ (x-orig (x-origin v))
+ (y-orig (y-origin v))
+ (wdg (wedge b)))
+ (setf (visible solid-prim) visible)
+ (setf (visible dashed-prim) visible)
+ (draw-portal dashed-prim (portal (collimator b)) bt sad v)
+ (draw-isocenter solid-prim bt scale x-orig y-orig)
+ (when (display-axis b)
+ (draw-central-axis solid-prim bt sad scale x-orig y-orig))
+ (unless (zerop (id wdg))
+ (draw-wedge solid-prim
+ (beam-transform b v t)
+ sad
+ (rotation wdg)
+ scale x-orig y-orig
+ (sl:width pic) (sl:height pic)))))))))
+
+;;;----------------------------------------------
+
+(defun draw-primary-beam-into-bev (b v)
+
+ "draw-primary-beam-into-bev b v
+
+Draws beam b into view v. The view is assumed to be a beam's eye
+view, and the beam is assumed to be the primary beam for the view.
+Draws the wedge also."
+
+ ;; start with new gp's each time, to avoid having to look for and
+ ;; disambiguate the solid and dashed segment-prims, which would be
+ ;; very complicated. But first catch the visible attribute of a
+ ;; beam graphic prim if present.
+ (let ((visible (aif (find b (foreground v) :key #'object)
+ (visible it) t)))
+ (setf (foreground v) (remove b (foreground v) :key #'object))
+ (let* ((pic (picture v))
+ (solid-clr (sl:color-gc (display-color b)
+ (sl:colormap pic)))
+ (solid-prim (get-segments-prim b v solid-clr))
+ (dashed-prim (get-segments-prim
+ b v (sl:find-dashed-color solid-clr)))
+ (marker-prim (get-rectangles-prim b v solid-clr))
+ (col-ang (* (the single-float (collimator-angle b))
+ *pi-over-180*))
+ (adj-col-ang (if (typep (collimator b) 'multileaf-coll)
+ 0.0
+ col-ang))
+ (portal (portal (collimator b)))
+ (sad (isodist b))
+ (wdg (wedge b))
+ (scale (scale v))
+ (x0 (x-origin v))
+ (y0 (y-origin v)))
+ (setf (visible solid-prim) visible)
+ (setf (visible dashed-prim) visible)
+ (setf (visible marker-prim) visible)
+ (draw-primary-portal dashed-prim marker-prim
+ portal adj-col-ang sad v)
+ ;; draw isocenter plus sign in middle of view
+ (setf (points solid-prim)
+ (append (draw-plus-icon '(0.0 0.0) scale x0 y0 *isocenter-radius*)
+ (points solid-prim)))
+ (unless (zerop (id wdg))
+ (draw-bev-wedge solid-prim
+ portal
+ (mapcar #'vertices (coll:elements (blocks b)))
+ col-ang sad
+ (rotation wdg)
+ (view-position v)
+ scale x0 y0
+ (sl:width pic) (sl:height pic))))))
+
+;;;----------------------------------------------
+
+(defun get-bev-markers (verts)
+
+ "get-bev-markers verts
+
+Returns a list of (ulc-x ulc-y width height) 4-tuples, suitable for
+insertion into a rectangles-prim's rectangles list, and subsequent
+drawing by clx:draw-rectangles."
+
+ (do ((vts verts (nthcdr 4 vts))
+ (rects nil))
+ ((null vts) rects)
+ ;; push the four components of the tuple onto rects, backwards
+ (push *bev-marker-size* rects)
+ (push *bev-marker-size* rects)
+ (push (- (the fixnum (second vts)) *bev-marker-radius*)
+ rects)
+ (push (- (the fixnum (first vts)) *bev-marker-radius*)
+ rects)))
+
+;;;----------------------------------------------
+
+(defun draw-primary-portal (b-prim m-prim portal col-ang sad bev)
+
+ "draw-primary-portal b-prim m-prim portal col-ang sad bev
+
+Draws portal for object obj into view bev's foreground, in color clr,
+using collimator angle col-ang and source-to-axis distance sad. The
+portal drawn is a beam portal contour or block contour for the primary
+beam in a beam's eye view."
+
+ (let* ((sin-c (sin col-ang))
+ (cos-c (cos col-ang))
+ (pt-x 0.0) (pt-y 0.0)
+ (xt 0.0) (yt 0.0)
+ (old-xt 0.0) (old-yt 0.0)
+ (last-pt (first (last portal)))
+ (last-x (first last-pt))
+ (last-y (second last-pt))
+ (fac (/ (- sad (the single-float (view-position bev)))
+ sad))
+ (proj-list nil)
+ (verts nil))
+ (declare (single-float sin-c cos-c pt-x pt-y xt yt old-xt old-yt
+ last-x last-y fac))
+ (setq old-xt (* fac (- (* last-x cos-c) (* last-y sin-c)))
+ old-yt (* fac (+ (* last-x sin-c) (* last-y cos-c))))
+ (dolist (pt portal)
+ (setq pt-x (first pt)
+ pt-y (second pt)
+ xt (* fac (- (* pt-x cos-c) (* pt-y sin-c)))
+ yt (* fac (+ (* pt-x sin-c) (* pt-y cos-c))))
+ (push (list old-xt old-yt xt yt) proj-list)
+ (setq old-xt xt old-yt yt))
+ (setf verts (pixel-segments proj-list
+ (scale bev)
+ (x-origin bev)
+ (y-origin bev)))
+ (setf (points b-prim) verts)
+ (setf (rectangles m-prim) (get-bev-markers verts))))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/brachy-coord-panels.cl b/prism/src/brachy-coord-panels.cl
new file mode 100644
index 0000000..055dc71
--- /dev/null
+++ b/prism/src/brachy-coord-panels.cl
@@ -0,0 +1,977 @@
+;;;
+;;; brachy-coord-panels
+;;;
+;;; replaces ortho-film-entry as it contains all the little subpanels
+;;; for each kind of coordinate entry mode, that appear on the brachy
+;;; panel, in the new arrangement of everything on one brachy panel.
+;;;
+;;; 1-Aug-2002 I. Kalet created from code earlier (temporarily)
+;;; located in brachy-panels.
+;;; 12-Aug-2002 I. Kalet add actions for AP and Right Lat buttons in
+;;; ortho-coord-panel
+;;; 19-Sep-2002 I. Kalet fix error in digitizer prompt box code, widen
+;;; some boxes, narrow others, change label from "Next" to "Enter"
+;;; 13-Oct-2002 I. Kalet add support for line sources
+;;; 29-Jan-2003 I. Kalet create common parent class, coord-panel, add
+;;; events to allow synch of current and end-source.
+;;; 31-Jan-2005 A. Simms add :allow-other-keys to make-coord-entry-panel
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+;;; generic coordinate entry subpanel
+;;;---------------------------------------------
+
+(defclass coord-panel ()
+
+ ((defaults-panel :accessor defaults-panel
+ :initarg :defaults-panel
+ :documentation "The brachy-update-panel containing
+the defaults for new sources.")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The frame for this panel")
+
+ (line-sources :accessor line-sources
+ :initarg :line-sources
+ :documentation "The collection containing all the
+line sources")
+
+ (seeds :accessor seeds
+ :initarg :seeds
+ :documentation "The collection containing all the seeds.")
+
+ (entry-mode :accessor entry-mode
+ :initarg :entry-mode
+ :documentation "The entry mode, a symbol specifying the
+coordinate entry mode currently active, either seeds or line-sources.")
+
+ (end-source :accessor end-source
+ :initarg :end-source
+ :initform 1
+ :documentation "Last source number to enter.")
+ (end-tln :accessor end-tln)
+ (new-end :accessor new-end
+ :initform (ev:make-event)
+ :documentation "Announced when end source no. is changed,
+ so can preserve current and end across entry mode changes")
+
+ (current :accessor current
+ :initarg :current
+ :initform 1
+ :documentation "Source number of source being entered.")
+ (current-tln :accessor current-tln)
+ (new-current :accessor new-current
+ :initform (ev:make-event)
+ :documentation "Announced when current source no. is changed,
+ so can preserve current and end across entry mode changes")
+
+ (next-btn :accessor next-btn)
+ )
+ )
+
+;;;---------------------------------------------
+
+(defmethod (setf end-source) :after (new-id (pnl coord-panel))
+ (ev:announce pnl (new-end pnl) new-id))
+
+(defmethod (setf current) :after (new-id (pnl coord-panel))
+ (ev:announce pnl (new-current pnl) new-id))
+
+;;;---------------------------------------------
+
+(defmethod destroy ((pan coord-panel))
+
+ ;; remove notifies not needed
+ (sl:destroy (end-tln pan))
+ (sl:destroy (current-tln pan))
+ (sl:destroy (next-btn pan))
+ (sl:destroy (panel-frame pan)))
+
+;;;---------------------------------------------
+;;; X, Y, Z coordinate entry subpanel
+;;;---------------------------------------------
+
+(defclass xyz-coord-panel (coord-panel)
+
+ ((x :accessor x :initform 0.0)
+ (x-tln :accessor x-tln)
+ (y :accessor y :initform 0.0)
+ (y-tln :accessor y-tln)
+ (z :accessor z :initform 0.0)
+ (z-tln :accessor z-tln)
+ ;; for line sources need end 2
+ (x2 :accessor x2 :initform 0.0)
+ (x2-tln :accessor x2-tln)
+ (y2 :accessor y2 :initform 0.0)
+ (y2-tln :accessor y2-tln)
+ (z2 :accessor z2 :initform 0.0)
+ (z2-tln :accessor z2-tln)
+ )
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-coord-entry-panel (mode (method (eql 'xyz))
+ source-data-panel line-coll seed-coll
+ &rest initargs)
+
+ (apply #'make-instance 'xyz-coord-panel
+ :defaults-panel source-data-panel
+ :line-sources line-coll :seeds seed-coll
+ :entry-mode mode
+ :allow-other-keys t
+ initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((pan xyz-coord-panel) &rest initargs)
+
+ (let* ((fr (apply #'sl:make-frame 260 95 :ulc-x 185 :ulc-y 45 initargs))
+ (bpf (symbol-value *small-font*))
+ (btw 80)
+ (bth 25)
+ (dx 5)
+ (dx2 90)
+ (dx3 175)
+ (top-y 5)
+ (win (sl:window fr))
+ (line-mode (eql (entry-mode pan)
+ 'line-sources)) ;; boolean for convenience
+ (curr-tl (sl:make-textline btw bth
+ :ulc-x dx :ulc-y top-y
+ :font bpf :parent win
+ :numeric t :lower-limit 1 :upper-limit 1000
+ :label "Curr: "))
+ (end-tl (sl:make-textline btw bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 1)
+ :font bpf :parent win
+ :numeric t :lower-limit 1 :upper-limit 1000
+ :label "End: "))
+ (next-b (sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 2)
+ :font bpf :parent win
+ :button-type :momentary
+ :label "Enter"))
+ (x-tl (sl:make-textline btw bth
+ :ulc-x dx2 :ulc-y top-y
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "X: "))
+ (y-tl (sl:make-textline btw bth
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 1)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Y: "))
+ (z-tl (sl:make-textline btw bth
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 2)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Z: "))
+ (x2-tl (if line-mode
+ (sl:make-textline btw bth
+ :ulc-x dx3 :ulc-y top-y
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "X2: ")))
+ (y2-tl (if line-mode
+ (sl:make-textline btw bth
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 1)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Y2: ")))
+ (z2-tl (if line-mode
+ (sl:make-textline btw bth
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 2)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Z2: ")))
+ )
+ (setf (panel-frame pan) fr
+ (end-tln pan) end-tl
+ (current-tln pan) curr-tl
+ (x-tln pan) x-tl
+ (y-tln pan) y-tl
+ (z-tln pan) z-tl
+ (x2-tln pan) x2-tl
+ (y2-tln pan) y2-tl
+ (z2-tln pan) z2-tl
+ (next-btn pan) next-b)
+ (setf (sl:info end-tl) (end-source pan)
+ (sl:info curr-tl) (current pan)
+ (sl:info x-tl) (x pan)
+ (sl:info y-tl) (y pan)
+ (sl:info z-tl) (z pan))
+ (when line-mode
+ (setf (sl:info x2-tl) (x2 pan)
+ (sl:info y2-tl) (y2 pan)
+ (sl:info z2-tl) (z2 pan)))
+ (ev:add-notify pan (sl:new-info end-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (end-source pnl)
+ (round (read-from-string info)))))
+ (ev:add-notify pan (sl:new-info curr-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (current pnl)
+ (round (read-from-string info)))))
+ (ev:add-notify pan (sl:new-info x-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (x pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info y-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (y pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info z-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (z pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (when line-mode
+ (ev:add-notify pan (sl:new-info x2-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (x2 pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info y2-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (y2 pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info z2-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (z2 pnl)
+ (coerce (read-from-string info) 'single-float)))))
+ (ev:add-notify pan (sl:button-on next-b)
+ #'(lambda (pnl btn)
+ (declare (ignore btn))
+ (let* ((line-mode (eql (entry-mode pnl) 'line-sources))
+ (coll (if line-mode (line-sources pnl)
+ (seeds pnl)))
+ (oldsrc (find (current pnl) (coll:elements coll)
+ :key #'id))
+ (newxyz (list (x pnl) (y pnl) (z pnl)))
+ (newxyz2 (if line-mode
+ (list (x2 pnl) (y2 pnl) (z2 pnl)))))
+ (if oldsrc
+ (if line-mode
+ (setf (end-1 oldsrc) newxyz
+ (end-2 oldsrc) newxyz2)
+ (setf (location oldsrc) newxyz))
+ (let ((defaults (defaults-panel pnl)))
+ (coll:insert-element
+ (if line-mode (make-line-source
+ ""
+ :id (current pnl)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :end-1 newxyz :end-2 newxyz2)
+ (make-seed ""
+ :id (current pnl)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :location newxyz))
+ coll))))
+ (unless (= (current pnl) (end-source pnl))
+ (incf (current pnl))
+ (setf (sl:info (current-tln pan)) (current pnl)))
+ ))
+ ))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((pan xyz-coord-panel))
+
+ ;; remove notifies not needed
+
+ (sl:destroy (x-tln pan))
+ (sl:destroy (y-tln pan))
+ (sl:destroy (z-tln pan))
+ (when (eql (entry-mode pan) 'line-sources)
+ (sl:destroy (x2-tln pan))
+ (sl:destroy (y2-tln pan))
+ (sl:destroy (z2-tln pan))))
+
+;;;---------------------------------------------
+;;; ortho-coordinate entry subpanel
+;;;---------------------------------------------
+
+(defclass ortho-coord-panel (coord-panel)
+
+ ((digitizing :accessor digitizing
+ :initform nil
+ :documentation "True if digitizer in use.")
+ (digitizer-btn :accessor digitizer-btn)
+
+ (ap-flag :accessor ap-flag
+ :initform t
+ :documentation "True if using AP rather than PA view.")
+ (ap-button :accessor ap-button)
+
+ (lat-flag :accessor lat-flag
+ :initform t
+ :documentation "True if using right lateral film.")
+ (lat-button :accessor lat-button)
+
+ (ap-mag :accessor ap-mag
+ :initform 1.0
+ :documentation "The AP or PA film magnification factor.")
+ (ap-tln :accessor ap-tln)
+
+ (lat-mag :accessor lat-mag
+ :initform 1.0
+ :documentation "The lateral film magnification factor.")
+ (lat-tln :accessor lat-tln)
+
+ (x-ap :accessor x-ap :initform 0.0)
+ (x-ap-tln :accessor x-ap-tln)
+ (y-ap :accessor y-ap :initform 0.0)
+ (y-ap-tln :accessor y-ap-tln)
+ (x-lat :accessor x-lat :initform 0.0)
+ (x-lat-tln :accessor x-lat-tln)
+ (y-lat :accessor y-lat :initform 0.0)
+ (y-lat-tln :accessor y-lat-tln)
+
+ ;; for line sources need end 2
+ (x2-ap :accessor x2-ap :initform 0.0)
+ (x2-ap-tln :accessor x2-ap-tln)
+ (y2-ap :accessor y2-ap :initform 0.0)
+ (y2-ap-tln :accessor y2-ap-tln)
+ (x2-lat :accessor x2-lat :initform 0.0)
+ (x2-lat-tln :accessor x2-lat-tln)
+ (y2-lat :accessor y2-lat :initform 0.0)
+ (y2-lat-tln :accessor y2-lat-tln)
+ )
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-coord-entry-panel (mode (method (eql 'ortho-film))
+ source-data-panel line-coll seed-coll
+ &rest initargs)
+
+ (apply #'make-instance 'ortho-coord-panel
+ :defaults-panel source-data-panel
+ :line-sources line-coll :seeds seed-coll
+ :entry-mode mode
+ initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((pan ortho-coord-panel)
+ &rest initargs)
+
+ (let* ((fr (apply #'sl:make-frame 345 125 :ulc-x 185 :ulc-y 45 initargs))
+ (bpf (symbol-value *small-font*))
+ (btw-s 70)
+ (btw-m 80)
+ (btw-l 90)
+ (bth 25)
+ (dx 5)
+ (dx2 80)
+ (dx3 175)
+ (dx4 260)
+ (top-y 5)
+ (win (sl:window fr))
+ (line-mode (eql (entry-mode pan)
+ 'line-sources)) ;; boolean for convenience
+ (curr-tl (sl:make-textline btw-s bth
+ :ulc-x dx :ulc-y top-y
+ :font bpf :parent win
+ :numeric t :lower-limit 1 :upper-limit 1000
+ :label "Curr: "))
+ (end-tl (sl:make-textline btw-s bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 1)
+ :font bpf :parent win
+ :numeric t :lower-limit 1 :upper-limit 1000
+ :label "End: "))
+ (next-b (sl:make-button btw-s bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 2)
+ :font bpf :parent win
+ :button-type :momentary
+ :label "Enter"))
+ (dig-b (sl:make-button btw-s bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 3)
+ :font bpf :parent win
+ :label "Digitizer"))
+ (ap-b (sl:make-button btw-l bth
+ :ulc-x dx2 :ulc-y top-y
+ :font bpf :parent win
+ :button-type :momentary
+ :label "AP"))
+ (ap-mag-tl (sl:make-textline btw-l bth
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 1)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit 0.5
+ :upper-limit 5.0
+ :label "AP Mag: "))
+ (lat-b (sl:make-button btw-l bth
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 2)
+ :font bpf :parent win
+ :button-type :momentary
+ :label "Right Lat"))
+ (lat-mag-tl (sl:make-textline btw-l bth
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 3)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit 0.5
+ :upper-limit 5.0
+ :label "Lat Mag: "))
+ (ap-x-tl (sl:make-textline btw-m bth
+ :ulc-x dx3 :ulc-y top-y
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "AP X: "))
+ (ap-y-tl (sl:make-textline btw-m bth
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 1)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "AP Y: "))
+ (lat-x-tl (sl:make-textline btw-m bth
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 2)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Lat X: "))
+ (lat-y-tl (sl:make-textline btw-m bth
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 3)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Lat Y: "))
+ ;; when entry-mode is line-sources add x2, y2 etc.
+ (ap-x2-tl (if line-mode
+ (sl:make-textline btw-m bth
+ :ulc-x dx4 :ulc-y top-y
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "AP X2: ")))
+ (ap-y2-tl (if line-mode
+ (sl:make-textline btw-m bth
+ :ulc-x dx4 :ulc-y (bp-y top-y bth 1)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "AP Y2: ")))
+ (lat-x2-tl (if line-mode
+ (sl:make-textline btw-m bth
+ :ulc-x dx4 :ulc-y (bp-y top-y bth 2)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Lat X2: ")))
+ (lat-y2-tl (if line-mode
+ (sl:make-textline btw-m bth
+ :ulc-x dx4 :ulc-y (bp-y top-y bth 3)
+ :font bpf :parent win
+ :numeric t
+ :lower-limit -100.0
+ :upper-limit 100.0
+ :label "Lat Y2: ")))
+ )
+ (setf (panel-frame pan) fr
+ (end-tln pan) end-tl
+ (current-tln pan) curr-tl
+ (ap-button pan) ap-b
+ (lat-button pan) lat-b
+ (ap-tln pan) ap-mag-tl
+ (lat-tln pan) lat-mag-tl
+ (x-ap-tln pan) ap-x-tl
+ (y-ap-tln pan) ap-y-tl
+ (x-lat-tln pan) lat-x-tl
+ (y-lat-tln pan) lat-y-tl
+ (x2-ap-tln pan) ap-x2-tl
+ (y2-ap-tln pan) ap-y2-tl
+ (x2-lat-tln pan) lat-x2-tl
+ (y2-lat-tln pan) lat-y2-tl
+ (next-btn pan) next-b
+ (digitizer-btn pan) dig-b)
+ (setf (sl:info end-tl) (end-source pan)
+ (sl:info curr-tl) (current pan)
+ (sl:info ap-mag-tl) (ap-mag pan)
+ (sl:info lat-mag-tl) (lat-mag pan)
+ (sl:info ap-x-tl) (x-ap pan)
+ (sl:info ap-y-tl) (y-ap pan)
+ (sl:info lat-x-tl) (x-lat pan)
+ (sl:info lat-y-tl) (y-lat pan))
+ (when line-mode
+ (setf (sl:info ap-x2-tl) (x2-ap pan)
+ (sl:info ap-y2-tl) (y2-ap pan)
+ (sl:info lat-x2-tl) (x2-lat pan)
+ (sl:info lat-y2-tl) (y2-lat pan)))
+ (ev:add-notify pan (sl:new-info end-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (end-source pnl)
+ (round (read-from-string info)))))
+ (ev:add-notify pan (sl:new-info curr-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (current pnl)
+ (round (read-from-string info)))))
+ (ev:add-notify pan (sl:button-on ap-b)
+ #'(lambda (pnl btn)
+ (setf (ap-flag pnl) (not (ap-flag pnl)))
+ (setf (sl:label btn) (if (ap-flag pnl) "AP" "PA"))))
+ (ev:add-notify pan (sl:button-on lat-b)
+ #'(lambda (pnl btn)
+ (setf (lat-flag pnl) (not (lat-flag pnl)))
+ (setf (sl:label btn)
+ (if (lat-flag pnl) "Right Lat" "Left Lat"))))
+ (ev:add-notify pan (sl:new-info ap-mag-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (ap-mag pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info lat-mag-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (lat-mag pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info ap-x-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (x-ap pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info ap-y-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (y-ap pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info lat-x-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (x-lat pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info lat-y-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (y-lat pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (when line-mode
+ (ev:add-notify pan (sl:new-info ap-x2-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (x2-ap pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info ap-y2-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (y2-ap pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info lat-x2-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (x2-lat pnl)
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify pan (sl:new-info lat-y2-tl)
+ #'(lambda (pnl tln info)
+ (declare (ignore tln))
+ (setf (y2-lat pnl)
+ (coerce (read-from-string info) 'single-float)))))
+ (ev:add-notify pan (sl:button-on next-b)
+ #'(lambda (pnl btn)
+ (declare (ignore btn))
+ (let* ((line-mode (eql (entry-mode pnl) 'line-sources))
+ (coll (if line-mode (line-sources pnl)
+ (seeds pnl)))
+ (oldsrc (find (current pnl) (coll:elements coll)
+ :key #'id))
+ (newxyz (xyz-from-ortho pnl))
+ (newxyz2 (xyz2-from-ortho pnl)))
+
+ (if oldsrc
+ (if line-mode
+ (setf (end-1 oldsrc) newxyz
+ (end-2 oldsrc) newxyz2)
+ (setf (location oldsrc) newxyz))
+ (let ((defaults (defaults-panel pnl)))
+ (coll:insert-element
+ (if line-mode
+ (make-line-source
+ ""
+ :id (current pnl)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :end-1 newxyz
+ :end-2 newxyz2
+ :ap-flag (ap-flag pnl)
+ :ap-mag (ap-mag pnl)
+ :lat-flag (lat-flag pnl)
+ :lat-mag (lat-mag pnl)
+ :raw-ap-coords (list (x-ap pnl)
+ (y-ap pnl)
+ (x2-ap pnl)
+ (y2-ap pnl))
+ :raw-lat-coords (list (x-lat pnl)
+ (y-lat pnl)
+ (x2-lat pnl)
+ (y2-lat pnl)))
+ (make-seed ""
+ :id (current pnl)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :location newxyz
+ :ap-flag (ap-flag pnl)
+ :ap-mag (ap-mag pnl)
+ :lat-flag (lat-flag pnl)
+ :lat-mag (lat-mag pnl)
+ :raw-ap-coords (list (x-ap pnl)
+ (y-ap pnl))
+ :raw-lat-coords (list (x-lat pnl)
+ (y-lat pnl))))
+ coll))))
+ (unless (= (current pnl) (end-source pnl))
+ (incf (current pnl))
+ (setf (sl:info (current-tln pan)) (current pnl)))
+ ))
+ (ev:add-notify pan (sl:button-on dig-b)
+ #'(lambda (pnl btn)
+ (if (digitizer-present)
+ (brachy-ortho-digitize pnl)
+ (sl:acknowledge "Digitzer not available"))
+ (setf (sl:on btn) nil)
+ ))
+ ))
+
+;;;---------------------------------------------
+
+(defun xyz-from-ortho (panel)
+
+ "returns demagnified x,y and averaged z from ortho film coords."
+
+ (let* ((ap-mag (ap-mag panel))
+ (lat-mag (lat-mag panel))
+ (x (/ (x-ap panel) ap-mag))
+ (y (/ (y-lat panel) lat-mag))
+ ;; remember that z+ is toward the feet
+ (z-ap (- (/ (y-ap panel) ap-mag)))
+ (z-lat (/ (x-lat panel) lat-mag)))
+ (unless (ap-flag panel) (setq x (- x)))
+ (unless (lat-flag panel) (setq z-lat (- z-lat)))
+ (list x y (/ (+ z-ap z-lat) 2.0))))
+
+;;;---------------------------------------------
+
+(defun xyz2-from-ortho (panel)
+
+ "returns demagnified x2,y2 and averaged z2 from ortho film coords."
+
+ (let* ((ap-mag (ap-mag panel))
+ (lat-mag (lat-mag panel))
+ (x (/ (x2-ap panel) ap-mag))
+ (y (/ (y2-lat panel) lat-mag))
+ ;; remember that z+ is toward the feet
+ (z-ap (- (/ (y2-ap panel) ap-mag)))
+ (z-lat (/ (x2-lat panel) lat-mag)))
+ (unless (ap-flag panel) (setq x (- x)))
+ (unless (lat-flag panel) (setq z-lat (- z-lat)))
+ (list x y (/ (+ z-ap z-lat) 2.0))))
+
+;;;---------------------------------------------
+
+(defun brachy-ortho-digitize (panel)
+
+ (sl:push-event-level)
+ (digit-calibrate)
+ (let ((prompt-box (sl:make-textbox 300 60
+ :title "Digitizer directions"))
+ (start-no (current panel)) ;; so can reset it for Lat film
+ (line-mode (eql (entry-mode panel) 'line-sources))
+ state x0 y0 x y)
+
+ ;; create raw ap window
+
+ (loop
+ (setf (sl:info prompt-box)
+ (list (format nil "Place the ~A film on the digitizer"
+ (if (ap-flag panel) "AP" "PA"))
+ "Please digitize the origin"))
+ (multiple-value-setq (state x0 y0) (digitize-point))
+ (when (eql state :point) (return)))
+ (loop
+ (setf (sl:info prompt-box)
+ (list (format nil "Digitize Source ~A" (current panel))))
+ (multiple-value-setq (state x y) (digitize-point))
+ (case state
+ (:point
+ (setf (x-ap panel) (- x x0) (y-ap panel) (- y y0))
+ (setf (sl:info (x-ap-tln panel)) (x-ap panel)
+ (sl:info (y-ap-tln panel)) (y-ap panel))
+ (if (not line-mode)
+ (let ((oldsrc (find (current panel)
+ (coll:elements (seeds panel))
+ :key #'id)))
+ (if oldsrc
+ (setf (x-lat panel)
+ (or (first (raw-lat-coords oldsrc)) 0.0)
+ (y-lat panel)
+ (or (second (raw-lat-coords oldsrc)) 0.0)
+
+ ;; update panel display?
+
+ (location oldsrc) (xyz-from-ortho panel)
+ (ap-flag oldsrc) (ap-flag panel)
+ (ap-mag oldsrc) (ap-mag panel)
+ (raw-ap-coords oldsrc) (list (x-ap panel)
+ (y-ap panel)))
+ (let ((defaults (defaults-panel panel)))
+ (coll:insert-element ;; check for entry-mode here
+ (make-seed ""
+ :id (current panel)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :location (xyz-from-ortho panel)
+ ;; just set AP stuff here
+ :ap-flag (ap-flag panel)
+ :ap-mag (ap-mag panel)
+ :raw-ap-coords (list (x-ap panel)
+ (y-ap panel)))
+ (seeds panel))))
+ ;; (draw-raw-source src (ap-view mp) :ap))
+ )
+ ;; augment for line sources - digitize end 2 also
+ (loop
+ (setf (sl:info prompt-box)
+ (list (format nil "Digitize Source ~A, End 2" (current panel))))
+ (multiple-value-setq (state x y) (digitize-point))
+ (if (eql state :point)
+ (progn
+ (setf (x2-ap panel) (- x x0) (y2-ap panel) (- y y0))
+ (setf (sl:info (x2-ap-tln panel)) (x2-ap panel)
+ (sl:info (y2-ap-tln panel)) (y2-ap panel))
+ (let ((oldsrc (find (current panel)
+ (coll:elements (line-sources panel))
+ :key #'id)))
+ (if oldsrc
+ (setf (x-lat panel)
+ (or (first (raw-lat-coords oldsrc)) 0.0)
+ (y-lat panel)
+ (or (second (raw-lat-coords oldsrc)) 0.0)
+ (x2-lat panel)
+ (or (third (raw-lat-coords oldsrc)) 0.0)
+ (y2-lat panel)
+ (or (fourth (raw-lat-coords oldsrc)) 0.0)
+
+ ;; update panel display?
+
+ (end-1 oldsrc) (xyz-from-ortho panel)
+ (end-2 oldsrc) (xyz2-from-ortho panel)
+ (ap-flag oldsrc) (ap-flag panel)
+ (ap-mag oldsrc) (ap-mag panel)
+ (raw-ap-coords oldsrc) (list (x-ap panel)
+ (y-ap panel)
+ (x2-ap panel)
+ (y2-ap panel)))
+ (let ((defaults (defaults-panel panel)))
+ (coll:insert-element ;; check for entry-mode here
+ (make-line-source ""
+ :id (current panel)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :end-1 (xyz-from-ortho panel)
+ :end-2 (xyz2-from-ortho panel)
+ ;; just set AP stuff here
+ :ap-flag (ap-flag panel)
+ :ap-mag (ap-mag panel)
+ :raw-ap-coords
+ (list (x-ap panel)
+ (y-ap panel)
+ (x2-ap panel)
+ (y2-ap panel)))
+ (line-sources panel)))))
+ (return)))))
+ (if (= (current panel) (end-source panel))
+ (return)
+ (progn
+ (incf (current panel))
+ (setf (sl:info (current-tln panel)) (current panel)))))
+ (:done (return))
+ ))
+
+ ;; remove ap window??
+
+ ;; reset current and repeat for lat film
+ (setf (current panel) start-no
+ (sl:info (current-tln panel)) (current panel))
+
+ ;; create raw lateral window or reuse ap window
+
+ (loop
+ (setf (sl:info prompt-box)
+ (list (format nil "Place the ~A film on the digitizer"
+ (if (lat-flag panel) "Right lateral" "Left lateral"))
+ "Please digitize the origin"))
+ (multiple-value-setq (state x0 y0) (digitize-point))
+ (when (eql state :point) (return)))
+ (loop
+ (setf (sl:info prompt-box)
+ (list (format nil "Digitize Source ~A" (current panel))))
+ (multiple-value-setq (state x y) (digitize-point))
+ (case state
+ (:point
+ (setf (x-lat panel) (- x x0) (y-lat panel) (- y y0))
+ (setf (sl:info (x-lat-tln panel)) (x-lat panel)
+ (sl:info (y-lat-tln panel)) (y-lat panel))
+ (if (not line-mode)
+ (let ((oldsrc (find (current panel)
+ (coll:elements (seeds panel))
+ :key #'id)))
+ (if oldsrc
+ (setf (x-ap panel) (or (first (raw-ap-coords oldsrc)) 0.0)
+ (y-ap panel) (or (second (raw-ap-coords oldsrc)) 0.0)
+
+ ;; update panel display?
+
+ (location oldsrc) (xyz-from-ortho panel)
+ (lat-flag oldsrc) (lat-flag panel)
+ (lat-mag oldsrc) (lat-mag panel)
+ (raw-lat-coords oldsrc) (list (x-lat panel)
+ (y-lat panel)))
+ (let ((defaults (defaults-panel panel)))
+ (coll:insert-element
+ (make-seed ""
+ :id (current panel)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :location (xyz-from-ortho panel)
+ ;; just set Lateral stuff here
+ :lat-flag (lat-flag panel)
+ :lat-mag (lat-mag panel)
+ :raw-lat-coords (list (x-lat panel)
+ (y-lat panel)))
+ (seeds panel))))
+
+ ;; (draw-raw-source src (lat-view mp) :lat))
+ )
+ ;; line sources - digitize end 2 also
+ (loop
+ (setf (sl:info prompt-box)
+ (list (format nil "Digitize Source ~A, End 2" (current panel))))
+ (multiple-value-setq (state x y) (digitize-point))
+ (if (eql state :point)
+ (progn
+ (setf (x2-lat panel) (- x x0) (y2-lat panel) (- y y0))
+ (setf (sl:info (x2-lat-tln panel)) (x2-lat panel)
+ (sl:info (y2-lat-tln panel)) (y2-lat panel))
+ (let ((oldsrc (find (current panel)
+ (coll:elements (line-sources panel))
+ :key #'id)))
+ (if oldsrc
+ (setf (x-ap panel)
+ (or (first (raw-ap-coords oldsrc)) 0.0)
+ (y-ap panel)
+ (or (second (raw-ap-coords oldsrc)) 0.0)
+ (x2-ap panel)
+ (or (third (raw-ap-coords oldsrc)) 0.0)
+ (y2-ap panel)
+ (or (fourth (raw-ap-coords oldsrc)) 0.0)
+
+ ;; update panel display?
+
+ (end-1 oldsrc) (xyz-from-ortho panel)
+ (end-2 oldsrc) (xyz2-from-ortho panel)
+ (lat-flag oldsrc) (lat-flag panel)
+ (lat-mag oldsrc) (lat-mag panel)
+ (raw-lat-coords oldsrc) (list (x-lat panel)
+ (y-lat panel)
+ (x2-lat panel)
+ (y2-lat panel)))
+ (let ((defaults (defaults-panel panel)))
+ (coll:insert-element
+ (make-line-source ""
+ :id (current panel)
+ :source-type (src-type defaults)
+ :activity (src-strength defaults)
+ :treat-time (app-time defaults)
+ :end-1 (xyz-from-ortho panel)
+ :end-2 (xyz2-from-ortho panel)
+ ;; just set LAT stuff here
+ :lat-flag (lat-flag panel)
+ :lat-mag (lat-mag panel)
+ :raw-lat-coords
+ (list (x-lat panel)
+ (y-lat panel)
+ (x2-lat panel)
+ (y2-lat panel)))
+ (line-sources panel)))))
+ (return)))))
+
+ (if (= (current panel) (end-source panel))
+ (return)
+ (progn
+ (incf (current panel))
+ (setf (sl:info (current-tln panel)) (current panel)))))
+ (:done (return))
+ ))
+ (sl:destroy prompt-box))
+ (sl:pop-event-level))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((pan ortho-coord-panel))
+
+ (sl:destroy (ap-button pan))
+ (sl:destroy (lat-button pan))
+ (sl:destroy (ap-tln pan))
+ (sl:destroy (lat-tln pan))
+ (sl:destroy (x-ap-tln pan))
+ (sl:destroy (y-ap-tln pan))
+ (sl:destroy (x-lat-tln pan))
+ (sl:destroy (y-lat-tln pan))
+ ;; destroy end-2 stuff if entry-mode is line-sources
+ (when (eql (entry-mode pan) 'line-sources)
+ (sl:destroy (x2-ap-tln pan))
+ (sl:destroy (y2-ap-tln pan))
+ (sl:destroy (x2-lat-tln pan))
+ (sl:destroy (y2-lat-tln pan)))
+ (sl:destroy (digitizer-btn pan)))
+
+;;;---------------------------------------------
+
+(defmethod make-coord-entry-panel (mode (method t)
+ source-data-panel line-coll seed-coll
+ &rest initargs)
+
+ (declare (ignore mode source-data-panel line-coll seed-coll))
+ (format t "~%No method for entry type ~A~%" method)
+ nil)
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/brachy-dose-panels.cl b/prism/src/brachy-dose-panels.cl
new file mode 100644
index 0000000..aadd85b
--- /dev/null
+++ b/prism/src/brachy-dose-panels.cl
@@ -0,0 +1,466 @@
+;;;
+;;; brachy-dose-panels (formerly seed-spreadsheet)
+;;;
+;;; Definitions of mini-spreadsheet for brachy dose display and for
+;;; setting uniform time and activities where applicable
+;;;
+;;; 17-Apr-2000 I. Kalet created.
+;;; 23-Apr-2000 I. Kalet refinements to basic design - add more
+;;; columns and add scroll arrows.
+;;; 11-May-2000 I. Kalet parametrize application time and activity
+;;; upper and lower limits.
+;;; 1-Apr-2002 I. Kalet take out textlines for setting time and
+;;; activity, not useful since rarely uniform. Other fixes missing in
+;;; previous version. Take out delete button, other mods to put
+;;; directly on brachy panel instead of separate window.
+;;; 5-May-2002 I. Kalet adapt for possibility of button-off events
+;;; 28-Jul-2002 I. Kalet don't make seed spreadsheet a subclass of
+;;; generic-panel, it is not needed, but then make destroy method primary
+;;; 12-Aug-2002 I. Kalet initialize "set time" button, make
+;;; renormalization updates more efficient with "hold" flag (not yet
+;;; working) and add registrations for points added and deleted.
+;;; 13-Oct-2002 I. Kalet add line source doses and rename file
+;;; 29-Dec-2002 I. Kalet add remove-notify for points insertion,
+;;; deletion and name change when panel is destroyed.
+;;; 2-Nov-2003 I. Kalet remove use of #. reader macro from
+;;; *brachy-dose-cells* to allow compile without loading first
+;;; 1-Dec-2003 I. Kalet use backquote in array initialization instead
+;;; of quote, to allow eval of parameters.
+;;; 20-Jul-2004 I. Kalet put in Balto's fix to brachy-dose-refresh, to
+;;; check for non-nil allsrcs
+;;; 31-Jan-2005 A. Simms add :allow-other-keys t to make-brachy-dose-panel
+;;;
+
+;;; *** still to do: finish efficiency hacks for update operations
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defparameter *brachy-dose-min* 0.1)
+(defparameter *brachy-dose-max* 20000.0)
+
+;;;---------------------------------------------
+
+(defvar *brachy-dose-row-heights* (make-list 12 :initial-element 25))
+
+;;;---------------------------------------------
+
+(defvar *brachy-dose-col-widths* '(40 100 60 60))
+
+;;;---------------------------------------------
+
+(defvar *brachy-dose-cells*
+ (make-array '(12 4)
+ :initial-contents
+ `((nil
+ (:button "Compute Dose" nil nil :button-type :momentary)
+ (:button "Act.")
+ (:button "Time"))
+ (nil (:label "Point name") (:label "Dose rate")
+ (:label "Total dose"))
+ ((:up-arrow nil nil nil :fg-color sl:red)
+ (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ (nil (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*))
+ ((:down-arrow nil nil nil :fg-color sl:red)
+ (:readout "")
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)
+ (:number nil ,*brachy-dose-min* ,*brachy-dose-max*)))))
+
+;;;---------------------------------------------
+
+(defclass brachy-dose-panel ()
+
+ ((fr :accessor fr
+ :documentation "The SLIK spreadsheet panel that contains
+all the control buttons, name cells, data cells and arrow buttons.")
+
+ (seeds :accessor seeds
+ :initarg :seeds
+ :documentation "The seed collection for this brachy-dose
+panel.")
+
+ (line-sources :accessor line-sources
+ :initarg :line-sources
+ :documentation "The line-source collection for this
+brachy-dose panel.")
+
+ (pointlist :accessor pointlist
+ :initarg :pointlist
+ :documentation "The collection of points at which to
+calculate the dose.")
+
+ (compute-time :accessor compute-time
+ :initform t
+ :documentation "t if need to compute time from dose
+and activity, and nil if compute activity from dose and time.")
+
+ (point-pos :type fixnum
+ :accessor point-pos
+ :initform 0
+ :documentation "The position in the point list of the
+point in the first data row of the seed dose panel spreadsheet.")
+
+ (hold-updates :accessor hold-updates
+ :initform nil
+ :documentation "When this flag is set, the panel does
+not update with every seed app. time or strength update, so that we
+can avoid redundant updates which would be really slow.")
+
+ )
+
+ )
+
+;;;---------------------------------------------
+
+(defun make-brachy-dose-panel (&rest initargs)
+
+ "make-brachy-dose-panel &rest initargs
+
+Creates and returns a brachy-dose panel with the specified initargs."
+
+ (apply #'make-instance 'brachy-dose-panel
+ :font (symbol-value *small-font*)
+ :allow-other-keys t
+ initargs))
+
+
+;;;---------------------------------------------
+
+(defun source-dose-rates (src)
+ (if (valid-points (result src))
+ (let ((act (activity src)))
+ (mapcar #'(lambda (x) (* act x))
+ (points (result src))))))
+
+;;;---------------------------------------------
+
+(defun source-doses (src)
+ (let ((time (treat-time src)))
+ (mapcar #'(lambda (x) (* time x))
+ (source-dose-rates src))))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((sdp brachy-dose-panel)
+ &rest initargs)
+
+ "Initializes the user interface for the brachy-dose panel."
+
+ (let ((sheet (apply #'sl:make-spreadsheet
+ *brachy-dose-row-heights* *brachy-dose-col-widths*
+ *brachy-dose-cells*
+ :title "Prism Brachy Dose Panel"
+ initargs)))
+ (setf (fr sdp) sheet)
+ (sl:set-button sheet 0 3 t)
+ (brachy-dose-refresh sdp)
+ ;; display point totals in rads per hour numbered 1 to n
+ ;; accept point total desired for any point, scale hours or
+ ;; activity, display totals
+ (ev:add-notify sdp (sl:user-input sheet)
+ #'(lambda (pan sp i j info)
+ (let* ((seeds (coll:elements (seeds pan)))
+ (lines (coll:elements (line-sources pan)))
+ (allsrcs (append seeds lines))
+ (pts (coll:elements (pointlist pan)))
+ (lastrow (min (+ 1 (- (length pts)
+ (point-pos pan)))
+ 11)))
+ (cond ((and (= i 2) (= j 0)) ;; up arrow
+ (brachy-dose-scroll pan (case info
+ (1 -1)
+ (2 -10))))
+ ((and (= i 11) (= j 0)) ;; down arrow
+ (brachy-dose-scroll pan (case info
+ (1 1)
+ (2 10))))
+ ((and (= i 0) (= j 1))
+ (when (= info 1)
+ ;; compute point doses
+ (dolist (src seeds)
+ (let ((result (result src)))
+ (unless (valid-points result)
+ (setf (valid-points result)
+ (compute-seed-dose src pts nil)))))
+ (dolist (src lines)
+ (let ((result (result src)))
+ (unless (valid-points result)
+ (setf (valid-points result)
+ (compute-line-dose src pts nil)))))
+ (brachy-dose-refresh pan)))
+ ((and (= i 0) (= j 2))
+ (when (= info 1)
+ (setf (compute-time pan) nil)
+ (sl:set-button sp i 3 nil)))
+ ((and (= i 0) (= j 3))
+ (when (= info 1)
+ (setf (compute-time pan) t)
+ (sl:set-button sp i 2 nil)))
+ ;; new point dose rate - renormalize activity
+ ((and (> i 1) (<= i lastrow) (= j 2))
+ (if (every #'(lambda (x)
+ (valid-points (result x)))
+ allsrcs)
+ (let* ((pt-rates
+ (apply #'mapcar #'+
+ (mapcar #'source-dose-rates
+ allsrcs)))
+ (old-rate
+ (nth (+ i (point-pos pan) -2)
+ pt-rates))
+ (ratio (coerce (/ info old-rate)
+ 'single-float)))
+ ;; (setf (hold-updates pan) t)
+ (dolist (src allsrcs)
+ (setf (activity src)
+ (* ratio (activity src))))
+ ;; (setf (hold-updates pan) nil)
+ ;; (brachy-dose-refresh pan)
+ )
+ (progn
+ (sl:acknowledge
+ '(" No results!"
+ "Compute raw dose rates first"))
+ (sl:erase-contents sp i j)))
+ (brachy-dose-refresh pan))
+ ;; new point total dose - renormalize
+ ;; either time or activity
+ ((and (> i 1) (<= i lastrow) (= j 3))
+ (if (every #'(lambda (x)
+ (valid-points (result x)))
+ allsrcs)
+ (let* ((pt-doses
+ (apply #'mapcar #'+
+ (mapcar #'source-doses
+ allsrcs)))
+ (old-dose
+ (nth (+ i (point-pos pan) -2)
+ pt-doses))
+ (ratio (coerce (/ info old-dose)
+ 'single-float)))
+ ;; (setf (hold-updates pan) t)
+ (if (compute-time pan)
+ (dolist (src allsrcs)
+ (setf (treat-time src)
+ (* ratio (treat-time src))))
+ (dolist (src allsrcs)
+ (setf (activity src)
+ (* ratio (activity src)))))
+ ;; (setf (hold-updates pan) nil)
+ ;; (brachy-dose-refresh pan)
+ )
+ (progn
+ (sl:acknowledge
+ '(" No results!"
+ "Compute raw dose rates first"))
+ (sl:erase-contents sp i j)))
+ (brachy-dose-refresh pan))
+ ;; could come here, user entered a number
+ ;; in an empty textline
+ (t (sl:acknowledge "That cell is empty")
+ (sl:erase-contents sp i j))))))
+ ;; need to register with changes in source activities and
+ ;; times from elsewhere
+ (dolist (source (coll:elements (seeds sdp)))
+ (ev:add-notify sdp (new-activity source)
+ #'(lambda (pan src act)
+ (declare (ignore src act))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (new-treat-time source)
+ #'(lambda (pan src time)
+ (declare (ignore src time))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (new-source-type source)
+ #'(lambda (pan src time)
+ (declare (ignore time))
+ (setf (valid-points (result src))
+ (compute-seed-dose src
+ (coll:elements (pointlist pan))
+ nil))
+ (brachy-dose-refresh pan))))
+ (dolist (source (coll:elements (line-sources sdp)))
+ (ev:add-notify sdp (new-activity source)
+ #'(lambda (pan src act)
+ (declare (ignore src act))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (new-treat-time source)
+ #'(lambda (pan src time)
+ (declare (ignore src time))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (new-source-type source)
+ #'(lambda (pan src time)
+ (declare (ignore time))
+ (setf (valid-points (result src))
+ (compute-line-dose src
+ (coll:elements (pointlist pan))
+ nil))
+ (brachy-dose-refresh pan))))
+ (ev:add-notify sdp (coll:inserted (seeds sdp))
+ #'(lambda (pan coll newsrc)
+ (declare (ignore coll))
+ (ev:add-notify pan (new-activity newsrc)
+ #'(lambda (pnl src act)
+ (declare (ignore src act))
+ (brachy-dose-refresh pnl)))
+ (ev:add-notify pan (new-treat-time newsrc)
+ #'(lambda (pnl src time)
+ (declare (ignore src time))
+ (brachy-dose-refresh pnl)))
+ (ev:add-notify sdp (new-source-type newsrc)
+ #'(lambda (pnl src time)
+ (declare (ignore time))
+ (setf (valid-points (result src))
+ (compute-seed-dose
+ src
+ (coll:elements (pointlist pnl))
+ nil))
+ (brachy-dose-refresh pnl)))
+ (setf (valid-points (result newsrc))
+ (compute-seed-dose newsrc
+ (coll:elements (pointlist pan))
+ nil))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (coll:deleted (seeds sdp))
+ #'(lambda (pan coll src)
+ (declare (ignore coll src))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (coll:inserted (line-sources sdp))
+ #'(lambda (pan coll newsrc)
+ (declare (ignore coll))
+ (ev:add-notify pan (new-activity newsrc)
+ #'(lambda (pnl src act)
+ (declare (ignore src act))
+ (brachy-dose-refresh pnl)))
+ (ev:add-notify pan (new-treat-time newsrc)
+ #'(lambda (pnl src time)
+ (declare (ignore src time))
+ (brachy-dose-refresh pnl)))
+ (ev:add-notify sdp (new-source-type newsrc)
+ #'(lambda (pnl src time)
+ (declare (ignore time))
+ (setf (valid-points (result src))
+ (compute-line-dose
+ src
+ (coll:elements (pointlist pnl))
+ nil))
+ (brachy-dose-refresh pnl)))
+ (setf (valid-points (result newsrc))
+ (compute-line-dose newsrc
+ (coll:elements (pointlist pan))
+ nil))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (coll:deleted (line-sources sdp))
+ #'(lambda (pan coll src)
+ (declare (ignore coll src))
+ (brachy-dose-refresh pan)))
+ ;; register for points added and deleted, and for point name change
+ (dolist (pt (coll:elements (pointlist sdp)))
+ (ev:add-notify sdp (new-name pt)
+ #'(lambda (pan pnt newname)
+ (declare (ignore pnt newname))
+ (brachy-dose-refresh pan))))
+ (ev:add-notify sdp (coll:inserted (pointlist sdp))
+ #'(lambda (pan coll pt)
+ (declare (ignore coll))
+ (ev:add-notify pan (new-name pt)
+ #'(lambda (pnl pnt newname)
+ (declare (ignore pnt newname))
+ (brachy-dose-refresh pnl)))
+ (brachy-dose-refresh pan)))
+ (ev:add-notify sdp (coll:deleted (pointlist sdp))
+ #'(lambda (pan coll pt)
+ (declare (ignore coll pt))
+ (brachy-dose-refresh pan)))
+ ))
+
+;;;---------------------------------------------
+
+(defun brachy-dose-refresh (seedpan)
+
+ (let* ((sp (fr seedpan))
+ (points (coll:elements (pointlist seedpan)))
+ (allsrcs (append (coll:elements (seeds seedpan))
+ (coll:elements (line-sources seedpan))))
+ (pt-dose-rates (if allsrcs ;; to insure 2 args to mapcar
+ (apply #'mapcar #'+
+ (mapcar #'source-dose-rates allsrcs))))
+ (pt-doses (if allsrcs ;; to insure 2 args to mapcar
+ (apply #'mapcar #'+
+ (mapcar #'source-doses allsrcs))))
+ (pt-pos (point-pos seedpan)))
+ (dotimes (n 10)
+ (if (< (+ n pt-pos) (length points))
+ (let* ((i (+ n pt-pos))
+ (dose-rate (nth i pt-dose-rates))
+ (dose (nth i pt-doses))
+ (pt-name (format nil "~2A ~14A"
+ (id (nth i points))
+ (name (nth i points)))))
+ (sl:set-contents sp (+ n 2) 1 pt-name)
+ (when dose-rate ;; could be nil if not yet computed
+ (sl:set-contents sp (+ n 2) 2 (format nil "~6,1F" dose-rate))
+ (sl:set-contents sp (+ n 2) 3 (format nil "~6,1F" dose))))
+ (dotimes (i 3)
+ (sl:set-contents sp (+ n 2) (1+ i) ""))))))
+
+;;;---------------------------------------------
+
+(defun brachy-dose-scroll (panel amt)
+
+ (when amt ;; could be nil - see case forms above
+ (let ((tmp (+ (point-pos panel) amt))
+ (ptlist (coll:elements (pointlist panel))))
+ (when (and (>= tmp 0) (< tmp (length ptlist)))
+ (setf (point-pos panel) tmp)
+ (brachy-dose-refresh panel)))))
+
+;;;---------------------------------------------
+
+(defmethod destroy ((sdp brachy-dose-panel))
+
+ (dolist (source (coll:elements (seeds sdp)))
+ (ev:remove-notify sdp (new-activity source))
+ (ev:remove-notify sdp (new-treat-time source))
+ (ev:remove-notify sdp (new-source-type source)))
+ (dolist (source (coll:elements (line-sources sdp)))
+ (ev:remove-notify sdp (new-activity source))
+ (ev:remove-notify sdp (new-treat-time source))
+ (ev:remove-notify sdp (new-source-type source)))
+ (ev:remove-notify sdp (coll:inserted (seeds sdp)))
+ (ev:remove-notify sdp (coll:deleted (seeds sdp)))
+ (ev:remove-notify sdp (coll:inserted (line-sources sdp)))
+ (ev:remove-notify sdp (coll:deleted (line-sources sdp)))
+ (dolist (pt (coll:elements (pointlist sdp)))
+ (ev:remove-notify sdp (new-name pt)))
+ (ev:remove-notify sdp (coll:inserted (pointlist sdp)))
+ (ev:remove-notify sdp (coll:deleted (pointlist sdp)))
+ (sl:destroy (fr sdp)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/brachy-dose.cl b/prism/src/brachy-dose.cl
new file mode 100644
index 0000000..6ee9bfe
--- /dev/null
+++ b/prism/src/brachy-dose.cl
@@ -0,0 +1,209 @@
+;;;
+;;; brachy-dose
+;;;
+;;; Functions that implement the brachytherapy dose computation.
+;;;
+;;; 2-Jan-1996 I. Kalet created
+;;; 7-Mar-1997 I. Kalet finally start implementation
+;;; 24-Mar-1997 I. Kalet ongoing work...
+;;; 7-May-1997 BobGian inlined (SQR x) to (* x x) where arg is symbol;
+;;; left as call to inlined fcn SQR where arg is a form.
+;;; 30-Oct-1997 BobGian COMPUTE-xxx-DOSE fcns return T on success.
+;;; 1-Feb-2000 I. Kalet create local variables for efficiency, use
+;;; first, second, third to access source end coordinates etc., use
+;;; flet for local dose comp. expressions.
+;;; 27-Feb-2000 I. Kalet add type declarations.
+;;; 8-May-2000 I. Kalet gamma factor now split into dose rate
+;;; constant and anisotropy factor.
+;;; 19-Jun-2000 I. Kalet handle points close to source exactly as in
+;;; UWPLAN.
+;;; 20-Jun-2000 I. Kalet protect against user entering zero length
+;;; line sources.
+;;; 24-Jul-2002 I. Kalet make flat cutoff for distances less than
+;;; *brachy-min-dist* parameter. Add terminal output of progress.
+;;; 18-Sep-2002 I. Kalet return nil when no pts or gg are provided,
+;;; and be sure to return non-nil when successful.
+;;; 27-Dec-2002 I. Kalet add two more terms to polynomial tissue
+;;; correction.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defvar *brachy-min-dist* 0.2 "The minimum distance for computing a
+reasonable dose. For less than this, the value at this distance is used.")
+
+;;;--------------------------------------------------
+
+(defun compute-line-dose (src pts gg)
+
+ "compute-line-dose src pts gg
+
+Computes the doses to points or dose array (but NOT both) for line
+source src and puts them in the results object of src. Returns
+results on success, nil if no pts or gg."
+
+ (let* ((src-table (source-data (source-type src)))
+ (gamma (* (dose-rate-const src-table) (anisotropy-fn src-table)))
+ (active-length (actlen src-table))
+ (range (poly-range src-table))
+ (mu-w (mu-water src-table))
+ (a0 (a0 src-table))
+ (a1 (a1 src-table))
+ (a2 (a2 src-table))
+ (a3 (a3 src-table))
+ (a4 (a4 src-table))
+ (a5 (a5 src-table))
+ (src-end1 (end-1 src))
+ (src-end2 (end-2 src))
+ (xs1 (first src-end1))
+ (ys1 (second src-end1))
+ (zs1 (third src-end1))
+ (xs2 (first src-end2))
+ (ys2 (second src-end2))
+ (zs2 (third src-end2))
+ (xs (/ (+ xs1 xs2) 2.0))
+ (ys (/ (+ ys1 ys2) 2.0))
+ (zs (/ (+ zs1 zs2) 2.0))
+ (dxs (- xs2 xs1))
+ (dys (- ys2 ys1))
+ (dzs (- zs2 zs1))
+ (source-length (sqrt (+ (* dxs dxs) (* dys dys) (* dzs dzs)))))
+ (declare (single-float xs ys zs gamma active-length dxs dys dzs
+ source-length a0 a1 a2 a3 a4 a5 range mu-w))
+ (if (> source-length 0.0)
+ (flet ((line-dose (x y z)
+ (let* ((rx (- x xs))
+ (ry (- y ys))
+ (rz (- z zs))
+ (r2 (+ (* rx rx) (* ry ry) (* rz rz)))
+ (r (sqrt r2))
+ (reduced-r (/ r active-length))
+ )
+ (declare (single-float rx ry rz r2 r reduced-r))
+ ;; for points close to the center of a source, set dose
+ ;; rate same as at cutoff distance
+ (if (< r *brachy-min-dist*)
+ (setq r *brachy-min-dist*
+ r2 (* r r)
+ reduced-r (/ r active-length)))
+ (/ (* gamma (sievert reduced-r
+ ;; this is cos theta
+ (/ (abs (+ (* rx dxs)
+ (* ry dys)
+ (* rz dzs)))
+ (* r source-length))
+ (sievert-table src-table))
+ (tisscorr r range mu-w a0 a1 a2 a3 a4 a5))
+ r2))))
+ (if pts
+ (setf (points (result src)) ;; also returns success
+ (mapcar #'(lambda (pt) (line-dose (x pt) (y pt) (z pt)))
+ pts))
+ (if gg
+ (let* ((nx (x-dim gg))
+ (ny (y-dim gg))
+ (nz (z-dim gg))
+ (x-step (/ (x-size gg) (1- nx)))
+ (y-step (/ (y-size gg) (1- ny)))
+ (z-step (/ (z-size gg) (1- nz)))
+ ;; if gg already has a dose array present use it
+ (dose-array (or (grid (result src))
+ (make-array (list nx ny nz)
+ :element-type 'single-float
+ :initial-element 0.0))))
+ (do ((i 0 (1+ i))
+ (x (x-origin gg) (incf x x-step)))
+ ((= i nx))
+ (do ((j 0 (1+ j))
+ (y (y-origin gg) (incf y y-step)))
+ ((= j ny))
+ (do ((k 0 (1+ k))
+ (z (z-origin gg) (incf z z-step)))
+ ((= k nz))
+ (setf (aref dose-array i j k) (line-dose x y z)))))
+ t) ;; return success for grid
+ nil))) ;; neither points nor grid, so return failure
+ (progn (format t "~%*** zero length source - cannot compute dose!~%")
+ nil))))
+
+;;;--------------------------------------
+
+(defun compute-seed-dose (src pts gg)
+
+ "compute-seed-dose src pts gg
+
+Computes the doses to points or dose array (but NOT both) for seed src
+and puts them in the results object of src. Returns doses if
+successful, nil otherwise."
+
+ (let* ((src-table (source-data (source-type src)))
+ (gamma (* (dose-rate-const src-table) (anisotropy-fn src-table)))
+ (range (poly-range src-table))
+ (mu-w (mu-water src-table))
+ (a0 (a0 src-table))
+ (a1 (a1 src-table))
+ (a2 (a2 src-table))
+ (a3 (a3 src-table))
+ (a4 (a4 src-table))
+ (a5 (a5 src-table))
+ (src-loc (location src))
+ (xs (first src-loc))
+ (ys (second src-loc))
+ (zs (third src-loc)))
+ (declare (single-float gamma range mu-w a0 a1 a2 a3 a4 a5 xs ys zs))
+ (format t "~%Computing dose for source ~A...~%" (id src))
+ (flet ((seed-dose (x y z)
+ (let* ((r2 (+ (sqr (- x xs)) (sqr (- y ys)) (sqr (- z zs))))
+ (r (sqrt r2)))
+ (declare (single-float r r2))
+ ;; for distances less than cutoff distance set dose rate
+ ;; to same as at cutoff distance
+ (if (< r *brachy-min-dist*)
+ (setq r *brachy-min-dist* r2 (* r r)))
+ (/ (* gamma (tisscorr r range mu-w a0 a1 a2 a3 a4 a5))
+ r2))))
+ (if pts
+ (setf (points (result src)) ;; also returns success
+ (mapcar #'(lambda (pt)
+ (seed-dose (x pt) (y pt) (z pt)))
+ pts))
+ (if gg
+ (let* ((nx (x-dim gg))
+ (ny (y-dim gg))
+ (nz (z-dim gg))
+ (x-step (/ (x-size gg) (1- nx)))
+ (y-step (/ (y-size gg) (1- ny)))
+ (z-step (/ (z-size gg) (1- nz)))
+ (dose-array (or (grid (result src)) ; if present use it,
+ (make-array (list nx ny nz) ; or make one
+ :element-type 'single-float
+ :initial-element 0.0))))
+ (do ((i 0 (1+ i))
+ (x (x-origin gg) (incf x x-step)))
+ ((= i nx))
+ (do ((j 0 (1+ j))
+ (y (y-origin gg) (incf y y-step)))
+ ((= j ny))
+ (do ((k 0 (1+ k))
+ (z (z-origin gg) (incf z z-step)))
+ ((= k nz))
+ (setf (aref dose-array i j k) (seed-dose x y z)))))
+ t) ;; return success for grid
+ nil))))) ;; neither pts or grid, so return failure
+
+;;;--------------------------------------------------
+
+(defun tisscorr (dist range mu-w a0 a1 a2 a3 a4 a5)
+
+ (declare (single-float dist range mu-w a0 a1 a2 a3 a4 a5))
+ (if (> dist range) (exp (- (* mu-w dist))) ;; exponential absorbtion
+ (let* ((dist2 (* dist dist))
+ (dist3 (* dist dist2))) ;; Meisberger polynomial
+ (declare (single-float dist2))
+ (+ a0 (* a1 dist) (* a2 dist2) (* a3 dist3)
+ (* a4 dist2 dist2) (* a5 dist2 dist3)))))
+
+;;;--------------------------------------------------
+;;; End.
diff --git a/prism/src/brachy-graphics.cl b/prism/src/brachy-graphics.cl
new file mode 100644
index 0000000..04af3ff
--- /dev/null
+++ b/prism/src/brachy-graphics.cl
@@ -0,0 +1,201 @@
+;;;
+;;; brachy-graphics
+;;;
+;;; defines draw methods for line sources and seeds in views
+;;;
+;;; 3-Jun-1996 I. Kalet started with stub draw method.
+;;; 24-Aug-1997 I. Kalet wrote basic methods for cross sectional
+;;; views.
+;;; 13-Oct-1997 I. Kalet add stub methods for beam's eye views
+;;; 31-Mar-1998 I. Kalet combine into one method for all ortho views,
+;;; for line-sources and seeds, and use view-x,y to distinguish.
+;;; 21-Apr-1999 I. Kalet change sl:invisible to 'sl:invisible.
+;;; 23-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 26-Mar-2000 I. Kalet add support for drawing raw source data from
+;;; films into AP and Lateral view displays.
+;;; 30-Jul-2002 I. Kalet add methods for view-, view-y for oblique views
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defmethod view-x ((vw transverse-view) vec)
+
+ "returns the item in list vec that corresponds to the x coordinate
+in a transverse view."
+
+ (first vec))
+
+;;;--------------------------------------
+
+(defmethod view-y ((vw transverse-view) vec)
+
+ "returns the item in list vec that corresponds to the y coordinate
+in a transverse view."
+
+ (second vec))
+
+;;;--------------------------------------
+
+(defmethod view-x ((vw coronal-view) vec)
+
+ "returns the item in list vec that corresponds to the x coordinate
+in a coronal view."
+
+ (first vec))
+
+;;;--------------------------------------
+
+(defmethod view-y ((vw coronal-view) vec)
+
+ "returns the item in list vec that corresponds to the y coordinate
+in a coronal view."
+
+ (- (third vec)))
+
+;;;--------------------------------------
+
+(defmethod view-x ((vw sagittal-view) vec)
+
+ "returns the item in list vec that corresponds to the x coordinate
+in a sagittal view."
+
+ (third vec))
+
+;;;--------------------------------------
+
+(defmethod view-y ((vw sagittal-view) vec)
+
+ "returns the item in list vec that corresponds to the y coordinate
+in a sagittal view."
+
+ (second vec))
+
+;;;--------------------------------------
+
+(defmethod view-x ((vw oblique-view) vec)
+
+ "returns the transformed view x coordinate in an oblique view."
+
+ (let* ((x (first vec))
+ (z (third vec))
+ (azi-rad (* (azimuth vw) *pi-over-180*))
+ (sin1 (sin azi-rad))
+ (cos1 (cos azi-rad)))
+ (- (* x cos1) (* z sin1))))
+
+;;;--------------------------------------
+
+(defmethod view-y ((vw oblique-view) vec)
+
+ "returns the transformed view y coordinate in an oblique view."
+
+ (let* ((x (first vec))
+ (y (second vec))
+ (z (third vec))
+ (azi-rad (* (azimuth vw) *pi-over-180*))
+ (alt-rad (* (altitude vw) *pi-over-180*))
+ (sin1 (sin azi-rad))
+ (cos1 (cos azi-rad))
+ (sin2 (sin alt-rad))
+ (cos2 (cos alt-rad)))
+ (- (* y cos2) (* (+ (* x sin1) (* z cos1)) sin2))))
+
+;;;--------------------------------------
+
+(defmethod draw ((ls line-source) (vw view))
+
+ "draw (ls line-source) (vw view)
+
+generates graphic primitives for line sources in views. The
+differences among the views are in the view-x and view-y generic
+functions."
+
+ (unless (typep vw 'beams-eye-view)
+ (if (eql (display-color ls) 'sl:invisible)
+ (setf (foreground vw) (remove ls (foreground vw) :key #'object))
+ (let ((prim (find ls (foreground vw) :key #'object))
+ (color (sl:color-gc (display-color ls)))
+ (scale (scale vw))
+ (x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (x1 (view-x vw (end-1 ls)))
+ (y1 (view-y vw (end-1 ls)))
+ (x2 (view-x vw (end-2 ls)))
+ (y2 (view-y vw (end-2 ls))))
+ (unless prim
+ (setq prim (make-segments-prim nil color :object ls))
+ (push prim (foreground vw)))
+ (setf (color prim) color
+ (points prim) (pixel-segments (list (list x1 y1 x2 y2))
+ scale x0 y0))))))
+
+;;;--------------------------------------
+
+(defmethod draw ((sd seed) (vw view))
+
+ "draw (sd seed) (vw view)
+
+generates graphic primitives for seeds in views. For each, draws a +
+icon ten pixels long. The differences among the views are in the
+view-x and view-y generic functions."
+
+ (unless (typep vw 'beams-eye-view)
+ (if (eql (display-color sd) 'sl:invisible)
+ (setf (foreground vw) (remove sd (foreground vw) :key #'object))
+ (let ((prim (find sd (foreground vw) :key #'object))
+ (color (sl:color-gc (display-color sd)))
+ (scale (scale vw))
+ (x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (pt (list (view-x vw (location sd))
+ (view-y vw (location sd)))))
+ (unless prim
+ (setq prim (make-segments-prim nil color :object sd))
+ (push prim (foreground vw)))
+ (setf (color prim) color
+ (points prim) (draw-plus-icon pt scale x0 y0 5))))))
+
+;;;--------------------------------------
+
+(defun draw-all-raw-sources (line-data seed-data ap-vw lat-vw)
+
+ (let ((line-sources (coll:elements line-data))
+ (seeds (coll:elements seed-data)))
+ (when ap-vw
+ (setf (foreground ap-vw) nil)
+ (dolist (line line-sources) (draw-raw-source line ap-vw :ap))
+ (dolist (seed seeds) (draw-raw-source seed ap-vw :ap)))
+ (when lat-vw
+ (setf (foreground lat-vw) nil)
+ (dolist (line line-sources) (draw-raw-source line lat-vw :lat))
+ (dolist (seed seeds) (draw-raw-source seed lat-vw :lat)))))
+
+;;;--------------------------------------
+
+(defun draw-raw-source (src vw which)
+
+ ;; this function just recomputes or creates a graphic-prim for one
+ ;; raw source, src.
+
+ (let ((raw-coords (case which
+ (:ap (raw-ap-coords src))
+ (:lat (raw-lat-coords src))))
+ (prim (find src (foreground vw) :key #'object))
+ (color (sl:color-gc (display-color src)))
+ (scale (scale vw))
+ (x0 (x-origin vw))
+ (y0 (y-origin vw)))
+ (when raw-coords
+ (unless prim
+ (setq prim (make-segments-prim nil color :object src))
+ (push prim (foreground vw)))
+ (setf (color prim) color)
+ (setf (points prim)
+ (if (= (length raw-coords) 4)
+ (pixel-segments (list raw-coords) scale x0 y0)
+ (draw-plus-icon raw-coords scale x0 y0 5))))))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/brachy-mediators.cl b/prism/src/brachy-mediators.cl
new file mode 100644
index 0000000..3958017
--- /dev/null
+++ b/prism/src/brachy-mediators.cl
@@ -0,0 +1,47 @@
+;;;
+;;; brachy-mediators
+;;;
+;;; defines brachy-view-mediator and support code
+;;;
+;;; 2-Jun-1996 I. Kalet created
+;;; 31-Mar-1998 I. Kalet cosmetic changes
+;;; 6-Oct-2002 I. Kalet with event name change, combine line and seed
+;;; into single mediator class.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass brachy-view-mediator (object-view-mediator)
+
+ ()
+
+ (:documentation "This mediator connects a brachy source, line or
+ seed, with a view.")
+ )
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((bvm brachy-view-mediator)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (ev:add-notify bvm (new-location (object bvm)) #'update-view)
+ (ev:add-notify bvm (new-color (object bvm)) #'update-view))
+
+;;;--------------------------------------
+
+(defmethod destroy :after ((bvm brachy-view-mediator))
+
+ (ev:remove-notify bvm (new-location (object bvm)))
+ (ev:remove-notify bvm (new-color (object bvm))))
+
+;;;--------------------------------------
+
+(defun make-brachy-view-mediator (src view)
+
+ (make-instance 'brachy-view-mediator :object src :view view))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/brachy-panels.cl b/prism/src/brachy-panels.cl
new file mode 100644
index 0000000..9746651
--- /dev/null
+++ b/prism/src/brachy-panels.cl
@@ -0,0 +1,296 @@
+;;;
+;;; brachy-panels
+;;;
+;;; Definitions of control panels for radiation sources for
+;;; brachytherapy, i.e., line sources and seeds.
+;;;
+;;; 4-Jun-1996 I. Kalet created.
+;;; 24-Aug-1997 I. Kalet continue construction.
+;;; 19-Dec-1999 I. Kalet implement source spec. entry subpanels.
+;;; 31-Jan-2000 I. Kalet implement source table panel and other functions.
+;;; 27-Feb-2000 I. Kalet implement source coordinate entry from
+;;; digitizer, and split source-specs-panel to separate module.
+;;; 5-Mar-2000 I. Kalet split ortho film entry code to separate module.
+;;; 27-Mar-2000 I. Kalet continuing implementation...
+;;; 17-Apr-2000 I. Kalet added seed dose mini-spreadsheet
+;;; 27-Apr-2000 I. Kalet protect from selecting seed dose spreadsheet
+;;; when there are either no points or no seeds. Add keyboard input.
+;;; 11-May-2000 I. Kalet fix call to source-menu to conform to new
+;;; definitions. Also raise limits on source application times, and
+;;; parametrize.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 26-Nov-2000 I. Kalet cosmetic changes in dialog box.
+;;; 1-Apr-2002 I. Kalet big overhaul to make a nice interface. Put
+;;; seed spreadsheet directly on panel, rearrange all other controls.
+;;; 5-May-2002 I. Kalet begin reimplementation of coordinate entry
+;;; 26-Jul-2002 I. Kalet overhaul continued, add event regisrations, etc.
+;;; 12-Aug-2002 I. Kalet add delta-z for seeds in ortho mode
+;;; 6-Oct-2002 I. Kalet add line source support back in.
+;;; 29-Jan-2003 I. Kalet add registration with events to synchronize
+;;; the current and end source numbers when changing entry mode.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defclass brachy-panel (generic-panel)
+
+ ((line-sources :accessor line-sources
+ :initarg :line-sources
+ :documentation "The collection containing all the
+line sources")
+
+ (seeds :accessor seeds
+ :initarg :seeds
+ :documentation "The collection containing all the seeds.")
+
+ (points :accessor points
+ :initarg :points
+ :documentation "The collection of points from the case.")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame for this panel.")
+
+ (delete-b :accessor delete-b
+ :documentation "The Delete Panel button.")
+
+ (entry-mode-label :accessor entry-mode-label
+ :documentation "A readout labeling the entry mode
+menu")
+
+ (entry-mode :accessor entry-mode
+ :initform 'individual
+ :documentation "The entry mode specifys which type of
+sources is currently active, a symbol, either seeds or line-sources.")
+
+ (entry-mode-menu :accessor entry-mode-menu
+ :documentation "The menu used to select the
+coordinate entry mode.")
+
+ (entry-method-label :accessor entry-method-label
+ :documentation "A readout labeling the entry
+method menu")
+
+ (entry-method :accessor entry-method
+ :initform 'xyz
+ :documentation "The entry method, a symbol specifying
+the coordinate entry method currently active, one of xyz, ortho-film,
+table-shift, image.")
+
+ (entry-method-menu :accessor entry-method-menu
+ :documentation "The menu used to select the
+coordinate entry method.")
+
+ (entry-subpanel :accessor entry-subpanel
+ :initform nil
+ :documentation "The subpanel providing the controls
+and displays that depend on the current coordinate entry mode.")
+
+ (current :accessor current
+ :initform 1
+ :documentation "The cached value of the current source
+ being entered or modified so that it will be preserved
+ across changes of entry mode.")
+
+ (end-source :accessor end-source
+ :initform 1
+ :documentation "The cached value of the last source to
+ be entered or modified so that it will be preserved
+ across changes of entry mode.")
+
+ (dose-subpanel :accessor dose-subpanel
+ :initform nil
+ :documentation "The mini-spreadsheet for displaying
+dose rates and total doses to points.")
+
+ (source-update-subpanel :accessor source-update-subpanel
+ :documentation "The subpanel for modifying
+and deleting source specs.")
+
+ (line-specs-subpanel :accessor line-specs-subpanel
+ :documentation "The subpanel for entering and
+editing the numeric and catalog data about line sources.")
+
+ (seed-specs-subpanel :accessor seed-specs-subpanel
+ :documentation "The subpanel for entering and
+editing the numeric and catalog data about seeds.")
+
+ ))
+
+;;;---------------------------------------------
+
+(defun make-brachy-panel (&rest initargs)
+
+ "make-brachy-panel &rest initargs
+
+Returns a brachytherapy source panel for the two collections
+line-sources and seeds, listed in initargs."
+
+ (apply #'make-instance 'brachy-panel initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((bp brachy-panel) &rest initargs)
+
+ (let* ((bpf (symbol-value *small-font*))
+ (bth 25) ;; button and textline height for small font
+ (btw 90) ;; regular button and textline width
+ ;; (sbw 20) ;; small button width
+ (dx 10) ;; left margin
+ (top-y 10)
+ (specs-pan-hgt (apply #'+ top-y top-y *brachy-specs-row-heights*))
+ (update-pan-hgt (apply #'+ top-y top-y *brachy-update-row-heights*))
+ (pan-fr (apply #'sl:make-frame
+ (apply #'+ dx dx dx *brachy-specs-col-widths*)
+ (+ 190 update-pan-hgt specs-pan-hgt specs-pan-hgt)
+ :title "Prism Brachytherapy Panel" initargs))
+ (bp-win (sl:window pan-fr))
+ (del-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y top-y
+ :font bpf :label "Delete Panel"
+ :parent bp-win initargs))
+ (mode-r (apply #'sl:make-readout btw bth
+ :ulc-x dx
+ :ulc-y (bp-y top-y bth 1)
+ :border-width 0
+ :font bpf :label "Source type"
+ :parent bp-win initargs))
+ (mode-m (apply #'sl:make-radio-menu
+ '("Seeds" "Line sources")
+ :ulc-x dx
+ :ulc-y (bp-y top-y bth 2)
+ :font bpf
+ :parent bp-win initargs))
+ (method-r (apply #'sl:make-readout btw bth
+ :ulc-x btw
+ :ulc-y (bp-y top-y bth 1)
+ :border-width 0
+ :font bpf :label "Entry method"
+ :parent bp-win initargs))
+ (method-m (apply #'sl:make-radio-menu
+ '("XYZ" "Ortho films" "Table shift" "Images")
+ :ulc-x (+ dx btw)
+ :ulc-y (bp-y top-y bth 2)
+ :font bpf
+ :parent bp-win initargs))
+ ;; initial entry mode is seeds, so second arg is nil
+ (mods-panel (make-brachy-update-panel (seeds bp) nil bp-win
+ (+ dx btw)
+ (- (bp-y top-y bth 6) 5)))
+ (dose-spr (make-brachy-dose-panel :seeds (seeds bp)
+ :line-sources (line-sources bp)
+ :pointlist (points bp)
+ :parent bp-win
+ :ulc-x 550
+ :ulc-y top-y))
+ (seed-specs-pan (make-brachy-specs-panel
+ (seeds bp) bp-win
+ dx (- (sl:height pan-fr) specs-pan-hgt
+ specs-pan-hgt)))
+ (line-specs-pan (make-brachy-specs-panel
+ (line-sources bp) bp-win
+ dx (- (sl:height pan-fr) specs-pan-hgt))))
+ (let ((sheet (panel-frame seed-specs-pan)))
+ (sl:set-contents sheet 0 7 " X")
+ (sl:set-contents sheet 0 8 " Y")
+ (sl:set-contents sheet 0 9 " Z")
+ (sl:set-contents sheet 0 10 "Delta Z"))
+ (setf (panel-frame bp) pan-fr ;; put all the widgets in the slots
+ (delete-b bp) del-b
+ (entry-mode-label bp) mode-r
+ (entry-mode-menu bp) mode-m
+ (entry-method-label bp) method-r
+ (entry-method-menu bp) method-m
+ (source-update-subpanel bp) mods-panel
+ (dose-subpanel bp) dose-spr
+ (seed-specs-subpanel bp) seed-specs-pan
+ (line-specs-subpanel bp) line-specs-pan)
+ (ev:add-notify bp (sl:button-on del-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (destroy pan)))
+ (ev:add-notify bp (sl:selected mode-m)
+ #'(lambda (pan mnu item)
+ (declare (ignore mnu))
+ (setf (entry-mode pan)
+ (nth item '(seeds line-sources)))
+ ))
+ (ev:add-notify bp (sl:selected method-m)
+ #'(lambda (pan mnu item)
+ (declare (ignore mnu))
+ (setf (entry-method pan)
+ (nth item '(xyz ortho-film table-shift images)))))
+ (sl:select-button 0 mode-m) ;; default is individual
+ (sl:select-button 0 method-m) ;; default is xyz
+ ))
+
+;;;---------------------------------------------
+
+(defmethod (setf entry-mode) :after (newmode (pan brachy-panel))
+
+ (if (entry-subpanel pan) (destroy (entry-subpanel pan)))
+ ;; need to change the mode of the source-update-subpanel
+ (setf (src-coll (source-update-subpanel pan))
+ (if (eql newmode 'line-sources) (line-sources pan) (seeds pan)))
+ (setf (line-mode (source-update-subpanel pan)) (eql newmode 'line-sources))
+ ;; and put up a new coordinate-entry subpanel
+ (setf (entry-subpanel pan)
+ (make-coord-entry-panel newmode (entry-method pan)
+ (source-update-subpanel pan)
+ (line-sources pan) (seeds pan)
+ :parent (sl:window (panel-frame pan))
+ :current (current pan)
+ :end-source (end-source pan)))
+ (when (entry-subpanel pan)
+ (ev:add-notify pan (new-current (entry-subpanel pan))
+ #'(lambda (bpnl subp new-id)
+ (declare (ignore subp))
+ (setf (current bpnl) new-id)))
+ (ev:add-notify pan (new-end (entry-subpanel pan))
+ #'(lambda (bpnl subp new-id)
+ (declare (ignore subp))
+ (setf (end-source bpnl) new-id)))))
+
+;;;---------------------------------------------
+
+(defmethod (setf entry-method) :after (newmethod (pan brachy-panel))
+
+ (if (entry-subpanel pan) (destroy (entry-subpanel pan)))
+ (setf (entry-subpanel pan)
+ (make-coord-entry-panel (entry-mode pan) newmethod
+ (source-update-subpanel pan)
+ (line-sources pan) (seeds pan)
+ :parent (sl:window (panel-frame pan))
+ :current (current pan)
+ :end-source (end-source pan)))
+ (when (entry-subpanel pan)
+ (ev:add-notify pan (new-current (entry-subpanel pan))
+ #'(lambda (bpnl subp new-id)
+ (declare (ignore subp))
+ (setf (current bpnl) new-id)))
+ (ev:add-notify pan (new-end (entry-subpanel pan))
+ #'(lambda (bpnl subp new-id)
+ (declare (ignore subp))
+ (setf (end-source bpnl) new-id)))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((bp brachy-panel))
+
+ "releases X resources used by this panel and its children."
+
+ (sl:destroy (delete-b bp))
+ (sl:destroy (entry-mode-label bp))
+ (sl:destroy (entry-mode-menu bp))
+ (sl:destroy (entry-method-label bp))
+ (sl:destroy (entry-method-menu bp))
+ (destroy (entry-subpanel bp))
+ (destroy (source-update-subpanel bp))
+ (destroy (dose-subpanel bp))
+ (destroy (seed-specs-subpanel bp))
+ (destroy (line-specs-subpanel bp))
+ (sl:destroy (panel-frame bp)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/brachy-specs-panels.cl b/prism/src/brachy-specs-panels.cl
new file mode 100644
index 0000000..d6c3573
--- /dev/null
+++ b/prism/src/brachy-specs-panels.cl
@@ -0,0 +1,657 @@
+;;;
+;;; brachy-specs-panels
+;;;
+;;; Definitions of special control panels for source type and other
+;;; non-coordinate parameters of line sources and seeds.
+;;;
+;;; 27-Feb-2000 I. Kalet split off from brachy-panels.
+;;; 27-Apr-2000 I. Kalet add actions for source activity and
+;;; treat-time updates. Add source strength units display. Add
+;;; update when any activity or treatment time changes. Display 2
+;;; decimal places for coords.
+;;; 8-May-2000 I. Kalet split gamma into dose rate constant and
+;;; anisotropy factor, also add protocol label.
+;;; 11-May-2000 I. Kalet change limits on activity, application time,
+;;; and parametrize.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 1-Apr-2002 I. Kalet big overhaul to make a nice interface
+;;; 5-May-2002 I. Kalet allow for button-off events
+;;; 24-Jul-2002 I. Kalet fix mishandling of Z columns, also added more
+;;; required event registrations.
+;;; 29-Jul-2002 I. Kalet make initial source range in update panel 0
+;;; to 0 to prevent accidental modification or deletion.
+;;; 12-Aug-2002 I. Kalet add delta-Z column for seeds.
+;;; 6-Oct-2002 I. Kalet add line source support back in.
+;;; 11-Feb-2003 I. Kalet update units readout when source type changes.
+;;; 2-Nov-2003 I. Kalet remove #. reader macro to allow compile
+;;; without load.
+;;; 1-Dec-2003 I. Kalet use backquote in array initialization instead
+;;; of quote, to allow eval of parameters.
+;;; 5-Jan-2005 A. Simms add :allow-other-keys t to make-brachy-update-panel
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defvar *brachy-rows* 6)
+
+;;;---------------------------------------------
+
+(defvar *brachy-specs-row-heights*
+ (make-list (+ *brachy-rows* 1) :initial-element 25))
+
+;;;---------------------------------------------
+
+(defvar *brachy-specs-col-widths* '(50 60 210 60 50 30
+ 60 70 70 70 70))
+
+;;;---------------------------------------------
+
+(defvar *brachy-specs-cells*
+ (make-array (list (+ *brachy-rows* 1) 11)
+ :initial-contents
+ `(((:label "Go To:")
+ (:number nil 1 1000)
+ (:label "Source type")
+ (:label "Strength")
+ nil ;; room for labels
+ (:label "Perm")
+ (:label "App. time")
+ (:label "Act. len") ;; initially line sources
+ (:label "Phys. len") ;; initially line sources
+ (:label "Comp. len") ;; initially line sources
+ (:label "")) ;; initially line sources
+ ;; six rows of sources, with arrows in first and last
+ ((:up-arrow nil nil nil :fg-color sl:red)
+ (:button "" nil nil :border-width 0) ;; src no.
+ (:button "") ;; source type - by menu
+ (:number nil ,*brachy-activity-min*
+ ,*brachy-activity-max*) ;; source strength
+ (:readout "" nil nil :border-width 0) ;; src strength units
+ (:button "P") ;; permanent checkbox
+ (:number nil ,*brachy-app-time-min*
+ ,*brachy-app-time-max*) ;; application time
+ (:readout "" nil nil :border-width 0) ;; active len or x
+ (:readout "" nil nil :border-width 0) ;; phys. len or y
+ (:readout "" nil nil :border-width 0) ;; comp. len or z
+ (:readout "" nil nil :border-width 0)) ;; blank or delta-z
+ (nil ;; as above without arrow
+ (:button "" nil nil :border-width 0)
+ (:button "")
+ (:number nil ,*brachy-activity-min*
+ ,*brachy-activity-max*)
+ (:readout "" nil nil :border-width 0)
+ (:button "P") ;; permanent checkbox
+ (:number nil ,*brachy-app-time-min*
+ ,*brachy-app-time-max*)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0))
+ (nil
+ (:button "" nil nil :border-width 0)
+ (:button "")
+ (:number nil ,*brachy-activity-min*
+ ,*brachy-activity-max*)
+ (:readout "" nil nil :border-width 0)
+ (:button "P") ;; permanent checkbox
+ (:number nil ,*brachy-app-time-min*
+ ,*brachy-app-time-max*)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0))
+ (nil
+ (:button "" nil nil :border-width 0)
+ (:button "")
+ (:number nil ,*brachy-activity-min*
+ ,*brachy-activity-max*)
+ (:readout "" nil nil :border-width 0)
+ (:button "P") ;; permanent checkbox
+ (:number nil ,*brachy-app-time-min*
+ ,*brachy-app-time-max*)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0))
+ (nil
+ (:button "" nil nil :border-width 0)
+ (:button "")
+ (:number nil ,*brachy-activity-min*
+ ,*brachy-activity-max*)
+ (:readout "" nil nil :border-width 0)
+ (:button "P") ;; permanent checkbox
+ (:number nil ,*brachy-app-time-min*
+ ,*brachy-app-time-max*)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0))
+ ((:down-arrow nil nil nil :fg-color sl:red)
+ (:button "" nil nil :border-width 0)
+ (:button "")
+ (:number nil ,*brachy-activity-min*
+ ,*brachy-activity-max*)
+ (:readout "" nil nil :border-width 0)
+ (:button "P") ;; permanent checkbox
+ (:number nil ,*brachy-app-time-min*
+ ,*brachy-app-time-max*)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)
+ (:readout "" nil nil :border-width 0)))))
+
+;;;---------------------------------------------
+
+(defclass brachy-specs-panel ()
+
+ ((src-coll :accessor src-coll
+ :initarg :src-coll
+ :documentation "The collection of sources for this panel,
+from the plan.")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The frame for this panel")
+
+ (src-pos :type fixnum
+ :accessor src-pos
+ :initform 0
+ :documentation "The position in the source list of the
+source in the first row of the source panel spreadsheet.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "Used to prevent infinite loop in permanent button")
+
+ ))
+
+;;;---------------------------------------------
+
+(defun make-brachy-specs-panel (sources window x y)
+
+ (make-instance 'brachy-specs-panel
+ :src-coll sources
+ :parent window :ulc-x x :ulc-y y
+ :font (symbol-value *small-font*)
+ :allow-other-keys t))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((srcpan brachy-specs-panel)
+ &rest initargs)
+
+ (let ((pan-fr (apply #'sl:make-spreadsheet
+ *brachy-specs-row-heights*
+ *brachy-specs-col-widths*
+ *brachy-specs-cells*
+ initargs)))
+ (setf (panel-frame srcpan) pan-fr)
+ (brachy-specs-refresh srcpan)
+ (dolist (src (coll:elements (src-coll srcpan)))
+ (ev:add-notify srcpan (new-source-type src)
+ #'(lambda (pan source newid)
+ (let ((srctab (source-data newid)))
+ (update-brachy-spec-cell
+ pan source
+ (format nil "~A ~A C=~4,2F A=~4,2F"
+ (src-type srctab) (protocol srctab)
+ (dose-rate-const srctab)
+ (anisotropy-fn srctab))
+ "~A" 2)
+ (update-brachy-spec-cell
+ pan source (activity-units srctab) "~A" 4))))
+ (ev:add-notify srcpan (new-activity src)
+ #'(lambda (pan source newact)
+ (update-brachy-spec-cell
+ pan source newact "~6,3F" 3)))
+ (ev:add-notify srcpan (new-treat-time src)
+ #'(lambda (pan source newtime)
+ (update-brachy-spec-cell
+ pan source newtime "~6,1F" 6)))
+ (ev:add-notify srcpan (new-location src)
+ #'(lambda (pan source newloc)
+ (if (> (actlen (source-data (source-type source))) 0)
+ (update-brachy-spec-cell
+ pan source (source-length source) "~6,2F" 9)
+ (progn
+ (update-brachy-spec-cell
+ pan source (first newloc) "~6,2F" 7)
+ (update-brachy-spec-cell
+ pan source (second newloc) "~6,2F" 8)
+ (update-brachy-spec-cell
+ pan source (third newloc) "~6,2F" 9)
+ ;; column 10 blank for now
+ )))))
+ (ev:add-notify srcpan (coll:inserted (src-coll srcpan))
+ #'(lambda (pan coll src)
+ (declare (ignore coll))
+ (brachy-specs-refresh pan)
+ (ev:add-notify pan (new-source-type src)
+ #'(lambda (pnl source newid)
+ (let ((srctab (source-data newid)))
+ (update-brachy-spec-cell
+ pnl source
+ (format nil
+ "~A ~A C=~4,2F A=~4,2F"
+ (src-type srctab)
+ (protocol srctab)
+ (dose-rate-const srctab)
+ (anisotropy-fn srctab))
+ "~A" 2)
+ (update-brachy-spec-cell
+ pan source
+ (activity-units srctab)
+ "~A" 4))))
+ (ev:add-notify pan (new-activity src)
+ #'(lambda (pnl source newact)
+ (update-brachy-spec-cell
+ pnl source newact "~6,3F" 3)))
+ (ev:add-notify pan (new-treat-time src)
+ #'(lambda (pnl source newtime)
+ (update-brachy-spec-cell
+ pnl source newtime "~6,1F" 6)))
+ (ev:add-notify pan (new-location src)
+ #'(lambda (pnl source newloc)
+ (if (> (actlen
+ (source-data
+ (source-type source))) 0)
+ (update-brachy-spec-cell
+ pan source
+ (source-length source)
+ "~6,2F" 9)
+ (progn
+ (update-brachy-spec-cell
+ pnl source (first newloc)
+ "~6,2F" 7)
+ (update-brachy-spec-cell
+ pnl source (second newloc)
+ "~6,2F" 8)
+ (update-brachy-spec-cell
+ pnl source (third newloc)
+ "~6,2F" 9)
+ ;; column 10 blank for now
+ ))))
+ ))
+ (ev:add-notify srcpan (coll:deleted (src-coll srcpan))
+ #'(lambda (pan coll src)
+ (declare (ignore coll))
+ (ev:remove-notify pan (new-source-type src))
+ (ev:remove-notify pan (new-activity src))
+ (ev:remove-notify pan (new-treat-time src))
+ (ev:remove-notify pan (new-location src))
+ (brachy-specs-refresh pan)
+ ))
+ (ev:add-notify srcpan (sl:user-input pan-fr)
+ #'(lambda (pan sheet i j info)
+ (let* ((srcs (coll:elements (src-coll pan)))
+ (lastrow (min (- (length srcs) (src-pos pan))
+ *brachy-rows*)))
+ (cond ((and (= i 1) (= j 0)) ;; up arrow
+ (src-scroll pan (case info
+ (1 -1)
+ (2 -10))))
+ ((and (= i *brachy-rows*) (= j 0)) ;; down arrow
+ (src-scroll pan (case info
+ (1 1)
+ (2 10))))
+ ((and (= i 0) (= j 1)) ;; "Go To" textline
+ (aif (position info srcs :key #'id)
+ (src-scroll pan (- it (src-pos pan)))
+ (sl:acknowledge "No such source number")))
+ ((<= i lastrow)
+ (let* ((src (nth (+ i -1 (src-pos pan)) srcs))
+ (srctab (source-data
+ (source-type src))))
+ (case j
+ (1 (when (= info 1)
+ (aif (sl:popup-color-menu)
+ (progn
+ (setf (display-color src) it
+ (sl:fg-color
+ (sl:cell-object
+ sheet i j)) it)))
+ (sl:set-button sheet i j nil)))
+ (2 (when (= info 1)
+ (let ((srclist
+ (source-menu
+ (not (zerop
+ (actlen srctab))))))
+ (aif (sl:popup-menu
+ (mapcar #'second srclist))
+ (setf (source-type src)
+ (first (nth it srclist)))))
+ (sl:set-button sheet i j nil)))
+ (3 (setf (activity src)
+ (coerce info 'single-float)))
+ ;; action for P button
+ (5 (unless (busy pan)
+ (setf (busy pan) t)
+ (case info
+ (0 (setf (permanent src) nil))
+ (1 (setf (permanent src) t)))
+ (setf (busy pan) nil)))
+ (6 (if (permanent src)
+ (sl:acknowledge
+ (list
+ "Cannot change treatment time"
+ "for permanent implant source"))
+ (setf (treat-time src)
+ (coerce info 'single-float)))))))
+ (t (sl:acknowledge "That cell is empty")
+ (if (or (= j 1) (= j 2) (= j 5))
+ (if (= info 1)
+ (sl:set-button sheet i j nil))
+ (sl:erase-contents sheet i j)))))
+ (unless (busy pan)
+ (setf (busy pan) t)
+ (brachy-specs-refresh pan)
+ (setf (busy pan) nil))
+ ))))
+
+;;;---------------------------------------------
+
+(defun brachy-specs-refresh (panel)
+
+ (let ((sheet (panel-frame panel)))
+ (dotimes (row *brachy-rows*)
+ (sl:set-contents sheet (+ row 1) 1 "") ;; source number button
+ (sl:set-contents sheet (+ row 1) 2 "") ;; source type button
+ (sl:erase-contents sheet (+ row 1) 3)
+ (sl:erase-contents sheet (+ row 1) 6)
+ (sl:erase-contents sheet (+ row 1) 7)
+ (sl:erase-contents sheet (+ row 1) 8)
+ (sl:erase-contents sheet (+ row 1) 9)
+ (sl:erase-contents sheet (+ row 1) 10))
+ (let ((row 0)
+ (pos (src-pos panel)))
+ (dolist (src (nthcdr pos (coll:elements (src-coll panel))))
+ (if (<= (incf row) *brachy-rows*) ;; don't go past the bottom!
+ (let ((srctab (source-data (source-type src))))
+ (setf (sl:fg-color (sl:cell-object sheet row 1))
+ (display-color src))
+ (sl:set-contents sheet row 1
+ (format nil "~3 at A" (id src)))
+ (sl:set-contents sheet row 2
+ (format nil "~A ~A C=~4,2F A=~4,2F"
+ (src-type srctab) (protocol srctab)
+ (dose-rate-const srctab)
+ (anisotropy-fn srctab)))
+ (sl:set-contents sheet row 3
+ (format nil "~6,3F" (activity src)))
+ (sl:set-contents sheet row 4 (activity-units srctab))
+ (unless (busy panel)
+ (setf (busy panel) t)
+ (sl:set-button sheet row 5 (permanent src))
+ (setf (busy panel) nil))
+ (sl:set-contents sheet row 6
+ (format nil "~6,1F" (treat-time src)))
+ (sl:set-contents sheet row 7
+ (format nil "~6,2F"
+ (if (> (actlen srctab) 0)
+ (actlen srctab)
+ (first (location src)))))
+ (sl:set-contents sheet row 8
+ (format nil "~6,2F"
+ (if (> (actlen srctab) 0)
+ (physlen srctab)
+ (second (location src)))))
+ (sl:set-contents sheet row 9
+ (format nil "~6,2F"
+ (if (> (actlen srctab) 0)
+ (source-length src)
+ (third (location src)))))
+ ;; column 10 is currently left blank
+ ))))))
+
+;;;---------------------------------------------
+
+(defun src-scroll (panel amt)
+
+ (when amt ;; could be nil - see case above
+ (let ((tmp (+ (src-pos panel) amt))
+ (srclist (coll:elements (src-coll panel))))
+ (when (and (>= tmp 0) (< tmp (length srclist)))
+ (setf (src-pos panel) tmp)
+ (brachy-specs-refresh panel)))))
+
+;;;---------------------------------------------
+
+(defun update-brachy-spec-cell (panel source info format-str column)
+
+ "update-brachy-spec-cell panel source info format-str column
+
+updates the display in the brachy-specs-panel panel if this source is
+currently visible. If it is not within the range of the displayed
+rows, nothing is done."
+
+ (let ((panel-pos (src-pos panel))
+ (srcpos (position source (coll:elements (src-coll panel)))))
+ (when (and (>= srcpos panel-pos) (< srcpos (+ panel-pos *brachy-rows*)))
+ (sl:set-contents (panel-frame panel)
+ (+ srcpos (- panel-pos) 1) column
+ (format nil format-str info)))))
+
+;;;---------------------------------------------
+
+(defmethod destroy ((pan brachy-specs-panel))
+
+ (dolist (src (coll:elements (src-coll pan)))
+ (ev:remove-notify pan (new-source-type src))
+ (ev:remove-notify pan (new-activity src))
+ (ev:remove-notify pan (new-treat-time src))
+ (ev:remove-notify pan (new-location src)))
+ (ev:remove-notify pan (coll:inserted (src-coll pan)))
+ (ev:remove-notify pan (coll:deleted (src-coll pan)))
+ (sl:destroy (panel-frame pan)))
+
+;;;---------------------------------------------
+;;; update controls
+;;;---------------------------------------------
+
+(defvar *brachy-update-row-heights* '(25 25 25 25 25))
+
+;;;---------------------------------------------
+
+(defvar *brachy-update-col-widths* '(70 240 50 50))
+
+;;;---------------------------------------------
+
+(defvar *brachy-update-cells*
+ (make-array '(5 4)
+ :initial-contents
+ `(((:button "Change" nil nil :button-type :momentary)
+ (:button "")
+ nil
+ nil
+ )
+ ((:button "Change" nil nil :button-type :momentary)
+ (:label "Source strength:")
+ (:number nil ,*brachy-activity-min*
+ ,*brachy-activity-max*) ;; source strength
+ (:readout "" nil nil :border-width 0) ;; src strength units
+ )
+ ((:button "Change" nil nil :button-type :momentary)
+ (:label "Application time:")
+ (:number nil ,*brachy-app-time-min*
+ ,*brachy-app-time-max*) ;; application time
+ (:label "Hours")
+ )
+ ((:button "Delete" nil nil :button-type :momentary)
+ (:label "Source number range:")
+ (:readout "First:" nil nil :border-width 0)
+ (:number nil 1 1000) ;; start source
+ )
+ (nil
+ nil
+ (:readout "Last:" nil nil :border-width 0)
+ (:number nil 1 1000) ;; end source
+ )
+ )))
+
+;;;---------------------------------------------
+
+(defclass brachy-update-panel ()
+
+ ((src-coll :accessor src-coll
+ :initarg :src-coll
+ :documentation "The collection of sources for this panel,
+from the plan.")
+
+ (line-mode :accessor line-mode
+ :initarg :line-mode
+ :initform nil
+ :documentation "t if src-coll will contain line sources,
+ nil if seeds")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The frame for this panel")
+
+ (src-type :accessor src-type
+ :documentation "The currently selected source type")
+
+ (src-strength :accessor src-strength
+ :initform 1.0
+ :documentation "The currently specified source strength.")
+
+ (app-time :accessor app-time
+ :initform 1.0
+ :documentation "The currently specified application time
+ in hours.")
+
+ (first-src :accessor first-src
+ :initform 0
+ :documentation "The first source to modify or delete.")
+
+ (last-src :accessor last-src
+ :initform 0
+ :documentation "The last source to modify or delete.")
+
+ ))
+
+;;;---------------------------------------------
+
+(defun make-brachy-update-panel (sources line-mode window x y)
+
+ (make-instance 'brachy-update-panel
+ :src-coll sources :line-mode line-mode
+ :parent window :ulc-x x :ulc-y y
+ :font (symbol-value *small-font*)
+ :allow-other-keys t))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((srcpan brachy-update-panel)
+ &rest initargs)
+
+ (let* ((pan-fr (apply #'sl:make-spreadsheet
+ *brachy-update-row-heights*
+ *brachy-update-col-widths*
+ *brachy-update-cells*
+ initargs))
+ (default-src-type (first (first (source-menu (line-mode srcpan)))))
+ (default-table (source-data default-src-type)))
+ (setf (panel-frame srcpan) pan-fr)
+ (setf (src-type srcpan) default-src-type)
+ (sl:set-contents pan-fr 0 1
+ (format nil "~A ~A C=~4,2F A=~4,2F"
+ (src-type default-table)
+ (protocol default-table)
+ (dose-rate-const default-table)
+ (anisotropy-fn default-table)))
+ (sl:set-contents pan-fr 1 2 (src-strength srcpan))
+ (sl:set-contents pan-fr 1 3 (activity-units default-table))
+ (sl:set-contents pan-fr 2 2 (app-time srcpan))
+ (ev:add-notify srcpan (sl:user-input pan-fr)
+ #'(lambda (pan sheet i j info)
+ (let ((srcs (coll:elements (src-coll pan))))
+ (cond (;; update source type
+ (and (= i 0) (= j 0) (= info 1))
+ (dolist (src srcs)
+ (if (<= (first-src pan) (id src)
+ (last-src pan))
+ (setf (source-type src)
+ (src-type pan)))))
+ (;; select source type
+ (and (= i 0) (= j 1) (= info 1))
+ (let ((srclist (source-menu (line-mode
+ pan))))
+ (aif (sl:popup-menu
+ (mapcar #'second srclist))
+ (let* ((srcid (first (nth it srclist)))
+ (srctab (source-data srcid)))
+ (setf (src-type pan) srcid)
+ (sl:set-contents
+ sheet i j
+ (format nil "~A ~A C=~4,2F A=~4,2F"
+ (src-type srctab)
+ (protocol srctab)
+ (dose-rate-const srctab)
+ (anisotropy-fn srctab)))
+ ;; also update source
+ ;; strength units in i=1,j=3
+ (sl:set-contents
+ sheet 1 3 (activity-units srctab))
+ )))
+ (sl:set-button sheet i j nil))
+ (;; update source strength
+ (and (= i 1) (= j 0) (= info 1))
+ (dolist (src srcs)
+ (if (<= (first-src pan) (id src)
+ (last-src pan))
+ (setf (activity src)
+ (src-strength pan)))))
+ ((and (= i 1) (= j 2))
+ (setf (src-strength pan)
+ (coerce info 'single-float)))
+ (;; update applic. time
+ (and (= i 2) (= j 0) (= info 1))
+ (dolist (src srcs)
+ (if (<= (first-src pan) (id src)
+ (last-src pan))
+ (setf (treat-time src)
+ (app-time pan)))))
+ ((and (= i 2) (= j 2))
+ (setf (app-time pan)
+ (coerce info 'single-float)))
+ (;; delete sources
+ (and (= i 3) (= j 0) (= info 1))
+ (dolist (src srcs)
+ (if (<= (first-src pan)
+ (id src)
+ (last-src pan))
+ (coll:delete-element
+ src (src-coll pan)))))
+ ((and (= i 3) (= j 3))
+ (setf (first-src pan)
+ (coerce info 'single-float)))
+ ((and (= i 4) (= j 3))
+ (setf (last-src pan)
+ (coerce info 'single-float)))
+ ))))
+ ))
+
+;;;---------------------------------------------
+
+(defmethod (setf line-mode) :after (mode (pan brachy-update-panel))
+
+ (let* ((default-src-type (first (first (source-menu mode))))
+ (default-table (source-data default-src-type))
+ (pan-fr (panel-frame pan)))
+ (setf (src-type pan) default-src-type)
+ (sl:set-contents pan-fr 0 1
+ (format nil "~A ~A C=~4,2F A=~4,2F"
+ (src-type default-table)
+ (protocol default-table)
+ (dose-rate-const default-table)
+ (anisotropy-fn default-table)))
+ (sl:set-contents pan-fr 1 3 (activity-units default-table))))
+
+;;;---------------------------------------------
+
+(defmethod destroy ((pan brachy-update-panel))
+
+ (sl:destroy (panel-frame pan)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/brachy-tables.cl b/prism/src/brachy-tables.cl
new file mode 100644
index 0000000..be4e347
--- /dev/null
+++ b/prism/src/brachy-tables.cl
@@ -0,0 +1,727 @@
+;;;
+;;; brachy-tables
+;;;
+;;; Defines the Sievert integral tables and lookup functions that are
+;;; needed for the brachytherapy dose computation.
+;;;
+;;; 7-Mar-1997 I. Kalet created
+;;; 9-May-1997 BobGian added stub defs so will compile OK.
+;;; 19-Dec-1999 I. Kalet added selection and table editing support.
+;;; 7-Feb-2000 I. Kalet completed Sievert integral table generation.
+;;; 27-Feb-2000 I. Kalet add type declarations.
+;;; 25-Apr-2000 I. Kalet add activity units slot.
+;;; 8-May-2000 I. Kalet make gamma into separate slots for dose rate
+;;; constant and anisotropy factor. Add slot for string naming
+;;; calibration protocol.
+;;; 31-Mar-2002 I. Kalet add slot for half life, to support permanent
+;;; implants.
+;;; 1-May-2002 I. Kalet add edit support for half life slot.
+;;; 27-Dec-2002 I. Kalet add two more coefficients to polynomial
+;;; tissue correction data.
+;;; 29-Jan-2003 I. Kalet change half-life upper limit to a more
+;;; realistic value
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defvar *brachy-tables* nil
+ "The list of tables defining the available brachytherapy sources")
+
+(defvar *radii* '(0.1 0.15 0.2 0.3 0.4 0.6 0.8 1.2 1.6 2.4 3.2 4.8 6.4)
+ "The list of radii for which the Sievert integral is tabulated.")
+
+;;;--------------------------------------------------
+
+(defclass source-table ()
+
+ ((src-type :type string
+ :accessor src-type
+ :initform ""
+ :documentation "The string identifying the source type,
+i.e., 3M-6711, or whatever...")
+
+ (dose-rate-const :type single-float
+ :accessor dose-rate-const
+ :initform 8.81
+ :documentation "The dose rate factor for this
+source type.")
+
+ (anisotropy-fn :accessor anisotropy-fn
+ :initform 1.0
+ :documentation "A separate factor that accounts for
+anisotropic seed alignment.")
+
+ (protocol :type string
+ :accessor protocol
+ :initform ""
+ :documentation "Text identifying the seed calibration
+protocol")
+
+ (activity-units :type string
+ :accessor activity-units
+ :initform ""
+ :documentation "The short text string that is
+displayed or printed with activity of a source, showing the units in
+which the activity is specified. This is related to the choice of
+value for the dose rate factor.")
+
+ (half-life :type single-float
+ :accessor half-life
+ :initform 0.0
+ :documentation "The half life in hours, in order to do
+ permanent implant calculations")
+
+ (mu-wall :type single-float
+ :accessor mu-wall
+ :initform '((0.04 1.10) (0.06 1.10) (0.08 1.10) (0.1 1.10)
+ (0.2 1.10) (0.4 1.10) (0.6 1.10) (0.8 1.10)
+ (1.0 1.10) (2.0 1.10))
+ :documentation "An association list of attenuation values
+as a function of thickness, to account for beam hardening")
+
+ (diameter :type single-float
+ :accessor diameter
+ :initform 0.0)
+
+ (wall-thickness :type single-float
+ :accessor wall-thickness
+ :initform 0.0)
+
+ (endcap-thickness :type single-float
+ :accessor endcap-thickness
+ :initform 0.0)
+
+ (mu-water :type single-float
+ :accessor mu-water
+ :initform 0.0
+ :documentation "The attenuation coefficient for
+exponential attenuation of tissue beyond the maximum radius for the
+polynomial correction factor.")
+
+ (poly-range :type single-float
+ :accessor poly-range
+ :initform 0.0
+ :documentation "The distance in cm beyond which the
+polynomial tissue correction should not be used.")
+
+ (a0 :type single-float
+ :accessor a0
+ :initform 0.0
+ :documentation "The constant coefficient in the polynomial
+tissue correction.")
+
+ (a1 :type single-float
+ :accessor a1
+ :initform 0.0
+ :documentation "The linear term coefficient in the polynomial
+tissue correction.")
+
+ (a2 :type single-float
+ :accessor a2
+ :initform 0.0
+ :documentation "The coefficient of r squared in the polynomial
+tissue correction.")
+
+ (a3 :type single-float
+ :accessor a3
+ :initform 0.0
+ :documentation "The coefficient of r cubed in the polynomial
+tissue correction.")
+
+ (a4 :type single-float
+ :accessor a4
+ :initform 0.0
+ :documentation "The coefficient of r fourth power in the
+ polynomial tissue correction.")
+
+ (a5 :type single-float
+ :accessor a5
+ :initform 0.0
+ :documentation "The coefficient of r fifth power in the
+ polynomial tissue correction.")
+
+ (actlen :type single-float
+ :accessor actlen
+ :initform 0.0
+ :documentation "The active length of the source, applicable
+only to line sources.")
+
+ (physlen :type single-float
+ :accessor physlen
+ :initform 0.0
+ :documentation "The physical length of the source, as it
+would be seen on a radiograph - applicable only to line sources.")
+
+ (sievert-table :accessor sievert-table
+ :initform nil
+ :documentation "The Prism modified Sievert integral
+table for calculation of dose from line sources.")
+
+ )
+
+ (:documentation "A source-table represents the characteristics of a
+single source type, i.e., isotope, capsule type and size, but not
+activity.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defun source-data (source-id)
+
+ (find source-id *brachy-tables*
+ :key #'src-type :test #'string-equal))
+
+;;;--------------------------------------------------
+
+(defun trapezoid (ll ul nsteps fn)
+
+ "trapezoid ll ul nsteps fn
+
+returns the definite integral of fn, a real valued function of one
+real value, from ll to ul, using the trapezoidal rule, and dividing
+the interval into nsteps divisions."
+
+ (if (< nsteps 5) (setq nsteps 5))
+ (let ((delta (/ (- ul ll) nsteps))
+ (sum (* 0.5 (+ (funcall fn ll) (funcall fn ul))))
+ (x ll))
+ ;; (declare (single-float ll ul delta sum x))
+ (dotimes (i (- nsteps 1) (* delta sum))
+ (incf x delta)
+ (incf sum (funcall fn x)))))
+
+;;;--------------------------------------------------
+
+(defun effective-thickness (filt diam)
+
+ (let* ((big-r (/ diam 2.0))
+ (rs (- big-r filt))
+ (rs2 (* rs rs))
+ (big-r2 (* big-r big-r))
+ (pi1 (coerce pi 'single-float)))
+ (if (<= rs 0.0) filt
+ (- (* (/ 2.0 (* pi1 rs2))
+ (trapezoid (- rs) rs 1000
+ #'(lambda (r)
+ (let ((r2 (* r r)))
+ (sqrt (* (- rs2 r2) (- big-r2 r2)))))))
+ (/ (* 2.4 rs) pi1)))))
+
+;;;--------------------------------------------------
+
+(defun findslot (given table)
+
+ "findslot given table
+
+returns two values, the index of the lower bounding element of table
+for the value of given, and the fraction of the way given is between
+the lower bounding element and the next element. If given is less
+than the lowest value in table, the index is 0 and the fraction is 0.0
+and if the value is larger than the largest value in the table, the
+index is one less than the index of the last element, and the fraction
+is 1.0. The table is assumed to be in order of increasing values."
+
+ (declare (single-float given))
+ (cond ((< given (first table)) (values 0 0.0))
+ ((> given (first (last table)))
+ (values (- (length table) 2) 1.0))
+ (t (let ((leftend 0)
+ (rightend (1- (length table))))
+ (declare (fixnum leftend rightend))
+ (loop
+ (if (> rightend (1+ leftend))
+ (let ((newend (round (/ (+ leftend rightend) 2))))
+ (if (>= (nth newend table) given)
+ (setq rightend newend)
+ (setq leftend newend)))
+ (return (values leftend
+ (/ (- given (nth leftend table))
+ (- (nth (1+ leftend) table)
+ (nth leftend table)))))))))))
+
+;;;--------------------------------------------------
+
+(defun calc-sievert-table (table-entry)
+
+ "calc-sievert-table table-entry
+
+calculates a table of modified Sievert integrals and stores them in
+the table record, for later lookup for line sources. This is the
+table generation function."
+
+ (let* ((stab (or (sievert-table table-entry)
+ (setf (sievert-table table-entry)
+ (make-array (list (length *radii*) 11)
+ :element-type 'single-float
+ :initial-element 0.0))))
+ (wall-thicknesses (mapcar #'first (mu-wall table-entry)))
+ (atten-list (mapcar #'second (mu-wall table-entry)))
+ (d (effective-thickness (wall-thickness table-entry)
+ (diameter table-entry)))
+ (mu-salt (* 0.1 (nth 3 atten-list) ;; approx of mu of salt
+ (actlen table-entry)))
+ (endcap (endcap-thickness table-entry))
+ (end-mu (multiple-value-bind (index fr)
+ (findslot endcap wall-thicknesses)
+ (+ (* (- 1.0 fr) (nth index atten-list))
+ (* fr (nth (1+ index) atten-list)))))
+ (end-coeff (exp (- (* end-mu endcap))))
+ (actlen (actlen table-entry)))
+ (flet ((sievert-integrand (theta)
+ (let* ((slant (/ d (cos theta)))
+ (mu (multiple-value-bind (index fr)
+ (findslot slant wall-thicknesses)
+ (+ (* (- 1.0 fr) (nth index atten-list))
+ (* fr (nth (1+ index) atten-list))))))
+ (exp (- (* mu slant))))))
+ (dotimes (i (length *radii*))
+ (let ((r (nth i *radii*)))
+ (dotimes (j 10)
+ (let* ((costh (* 0.1 (- 10 j))) ;; theta is 90 - phi
+ (sinth (if (zerop j) 0.0 ;; when j is 0, sin theta is 0
+ (sqrt (- 1.0 (* costh costh)))))
+ (x (* r sinth))
+ (y (* r costh)))
+ (setf (aref stab i j)
+ (* (/ r costh)
+ (trapezoid (atan (/ (- x 0.5) y))
+ (atan (/ (+ x 0.5) y))
+ 200
+ #'sievert-integrand)))))
+ (setf (aref stab i 10)
+ (if (<= r 0.5) 0.0
+ (* end-coeff r r
+ (trapezoid -0.5 0.5 200
+ #'(lambda (x)
+ (/ (exp (- (* mu-salt (- 0.5 x) actlen)))
+ (* (- r x) (- r x)))
+ ))))))))))
+
+;;;--------------------------------------------------
+
+(defun source-menu (line)
+
+ "source-menu line
+
+returns an association list of pairs, each consisting of a source type
+string and a full description string, one pair for each entry from the
+current list of source tables, the value of *brachy-tables*. If line
+is t, line sources are listed, otherwise seed."
+
+ (mapcar #'(lambda (tab)
+ (list (src-type tab)
+ (format nil "~A ~A C=~4,2F A=~4,2F ~A"
+ (src-type tab) (protocol tab)
+ (dose-rate-const tab) (anisotropy-fn tab)
+ (activity-units tab))))
+ (funcall (if line #'remove-if #'remove-if-not)
+ #'zerop *brachy-tables* :key #'actlen)))
+
+;;;--------------------------------------------------
+
+(defun mu-wall-edit (mu-wall-alist)
+
+ "a little panel for entering or modifying wall attenuation coeffs."
+
+ (sl:push-event-level)
+ (let* ((btw 170)
+ (bth 30)
+ (wall-frame (sl:make-frame (+ btw 10)
+ (+ (* 11 (+ bth 5)) 5)
+ :title "Wall Attenuations"))
+ (win (sl:window wall-frame))
+ (tmp-list (copy-tree mu-wall-alist))
+ (accept-btn (sl:make-exit-button 80 bth :parent win
+ :ulc-x 5 :ulc-y (bp-y 5 bth 10)
+ :bg-color 'sl:green
+ :label "Accept"))
+ textline-list
+ (update nil))
+ (ev:add-notify wall-frame (sl:button-on accept-btn)
+ #'(lambda (fr btn)
+ (declare (ignore fr btn))
+ (setf update t)))
+ (push accept-btn textline-list)
+ (push (sl:make-exit-button 80 bth :parent win
+ :ulc-x 90 :ulc-y (bp-y 5 bth 10)
+ :label "Cancel")
+ textline-list)
+ (dotimes (i 10)
+ (let ((tln (sl:make-textline btw bth :parent win
+ :ulc-x 5 :ulc-y (bp-y 5 bth i)
+ :numeric t
+ :lower-limit 0.0 :upper-limit 100.0
+ :label
+ (format nil "~5A cm: "
+ (first (nth i tmp-list))))))
+ (ev:add-notify i (sl:new-info tln)
+ #'(lambda (n tl info)
+ (declare (ignore tl))
+ (setf (second (nth n tmp-list))
+ (coerce (read-from-string info) 'single-float))))
+ (setf (sl:info tln) (second (nth i tmp-list)))
+ (push tln textline-list)))
+ (sl:process-events)
+ (dolist (tln textline-list) (sl:destroy tln))
+ (sl:destroy wall-frame)
+ (sl:pop-event-level)
+ ;; if change requested return new list, otherwise return original
+ (if update tmp-list mu-wall-alist)))
+
+;;;--------------------------------------------------
+
+(defun edit-source-table (table)
+
+ "edit-source-table table
+
+provides a popup panel to enter or modify all the attributes of the
+source defined by table."
+
+ (sl:push-event-level)
+ (let* ((bth 30)
+ (btw 170)
+ (dx 5)
+ (dx2 (+ btw (* 2 dx)))
+ (dx3 (+ dx2 btw dx))
+ (top-y 5)
+ (frm (sl:make-frame (+ dx (* 3 (+ dx btw)))
+ (+ top-y (* 7 (+ top-y bth)))
+ :title "Prism source table editor"))
+ (win (sl:window frm))
+ (update-btn (sl:make-exit-button 80 bth :parent win
+ :ulc-x dx :ulc-y top-y
+ :fg-color 'sl:black
+ :bg-color 'sl:green
+ :label "Update"))
+ (cancel-btn (sl:make-exit-button 80 bth :parent win
+ :ulc-x (+ dx 90) :ulc-y top-y
+ :label "Cancel"))
+ (name-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx :ulc-y (bp-y top-y bth 1)
+ :label "Type: "))
+ (drate-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx :ulc-y (bp-y top-y bth 2)
+ :label "DR const: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 100.0))
+ (actunits-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx :ulc-y (bp-y top-y bth 3)
+ :label "Act units: "))
+ (actlen-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx :ulc-y (bp-y top-y bth 4)
+ :label "Active len: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 100.0))
+ (physlen-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx :ulc-y (bp-y top-y bth 5)
+ :label "Phys. len: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 100.0))
+ (halflife-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx :ulc-y (bp-y top-y bth 6)
+ :label "Half-life: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 2000.0))
+ (poly-range-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx2
+ :ulc-y top-y
+ :label "P-Range: "
+ :numeric t
+ :lower-limit 0.0
+ :upper-limit 100.0))
+ (a0-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 1)
+ :label "A0: "
+ :numeric t
+ :lower-limit -100.0 :upper-limit 100.0))
+ (a1-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 2)
+ :label "A1: "
+ :numeric t
+ :lower-limit -100.0 :upper-limit 100.0))
+ (a2-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 3)
+ :label "A2: "
+ :numeric t
+ :lower-limit -100.0 :upper-limit 100.0))
+ (a3-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 4)
+ :label "A3: "
+ :numeric t
+ :lower-limit -100.0 :upper-limit 100.0))
+ (a4-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 5)
+ :label "A4: "
+ :numeric t
+ :lower-limit -100.0 :upper-limit 100.0))
+ (a5-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx2 :ulc-y (bp-y top-y bth 6)
+ :label "A5: "
+ :numeric t
+ :lower-limit -100.0 :upper-limit 100.0))
+ (proto-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx3 :ulc-y top-y
+ :label "Proto: "))
+ (aniso-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 1)
+ :label "Aniso: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 1.0))
+ (mu-water-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 2)
+ :label "Mu-water: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 100.0))
+ (mu-wall-btn (sl:make-button btw bth :parent win
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 3)
+ :label "Mu-wall table"))
+ (diam-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 4)
+ :label "Diam: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 1.0))
+ (wallthick-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 5)
+ :label "Wall thick: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 1.0))
+ (endcap-tln (sl:make-textline btw bth :parent win
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 6)
+ :label "End thick: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 1.0))
+ ;; local temporary variables
+ (src-type (src-type table))
+ (drate (dose-rate-const table))
+ (aniso (anisotropy-fn table))
+ (proto (protocol table))
+ (actunits (activity-units table))
+ (actlen (actlen table))
+ (physlen (physlen table))
+ (halflife (half-life table))
+ (mu-wall (mu-wall table))
+ (mu-water (mu-water table))
+ (poly-range (poly-range table))
+ (a0 (a0 table))
+ (a1 (a1 table))
+ (a2 (a2 table))
+ (a3 (a3 table))
+ (a4 (a4 table))
+ (a5 (a5 table))
+ (diameter (diameter table))
+ (wall-thickness (wall-thickness table))
+ (endcap-thickness (endcap-thickness table))
+ (update nil))
+ (setf (sl:info name-tln) (src-type table)
+ (sl:info drate-tln) (dose-rate-const table)
+ (sl:info aniso-tln) (anisotropy-fn table)
+ (sl:info proto-tln) (protocol table)
+ (sl:info actunits-tln) (activity-units table)
+ (sl:info actlen-tln) (actlen table)
+ (sl:info physlen-tln) (physlen table)
+ (sl:info halflife-tln) (half-life table)
+ (sl:info mu-water-tln) (mu-water table)
+ (sl:info poly-range-tln) (poly-range table)
+ (sl:info a0-tln) (a0 table)
+ (sl:info a1-tln) (a1 table)
+ (sl:info a2-tln) (a2 table)
+ (sl:info a3-tln) (a3 table)
+ (sl:info a4-tln) (a4 table)
+ (sl:info a5-tln) (a5 table)
+ (sl:info diam-tln) (diameter table)
+ (sl:info wallthick-tln) (wall-thickness table)
+ (sl:info endcap-tln) (endcap-thickness table))
+ (ev:add-notify table (sl:new-info name-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf src-type info)))
+ (ev:add-notify table (sl:new-info drate-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf drate
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info aniso-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf aniso
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info proto-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf proto info)))
+ (ev:add-notify table (sl:new-info actunits-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf actunits info)))
+ (ev:add-notify table (sl:button-on mu-wall-btn)
+ #'(lambda (tab btn)
+ (declare (ignore tab))
+ (setf mu-wall (mu-wall-edit mu-wall))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify table (sl:new-info actlen-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf actlen
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info physlen-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf physlen
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info halflife-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf halflife
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info mu-water-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf mu-water
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info poly-range-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf poly-range
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info a0-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf a0
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info a1-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf a1
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info a2-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf a2
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info a3-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf a3
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info a4-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf a4
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info a5-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf a5
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info diam-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf diameter
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info wallthick-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf wall-thickness
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:new-info endcap-tln)
+ #'(lambda (tab tl info)
+ (declare (ignore tab tl))
+ (setf endcap-thickness
+ (coerce (read-from-string info) 'single-float))))
+ (ev:add-notify table (sl:button-on update-btn)
+ #'(lambda (tab btn)
+ (declare (ignore btn))
+ ;; set all the values...
+ (setf (src-type tab) src-type
+ (dose-rate-const tab) drate
+ (anisotropy-fn tab) aniso
+ (protocol tab) proto
+ (activity-units tab) actunits
+ (actlen tab) actlen
+ (physlen tab) physlen
+ (half-life tab) halflife
+ (mu-water tab) mu-water
+ (mu-wall tab) mu-wall
+ (poly-range tab) poly-range
+ (a0 tab) a0 (a1 tab) a1
+ (a2 tab) a2 (a3 tab) a3
+ (a4 tab) a4 (a5 tab) a5
+ (diameter tab) diameter
+ (wall-thickness tab) wall-thickness
+ (endcap-thickness tab) endcap-thickness
+ update t)
+ (if (not (zerop (actlen tab)))
+ (calc-sievert-table tab))))
+ (sl:process-events)
+ (sl:destroy update-btn)
+ (sl:destroy cancel-btn)
+ (sl:destroy name-tln)
+ (sl:destroy drate-tln)
+ (sl:destroy actunits-tln)
+ (sl:destroy mu-wall-btn)
+ (sl:destroy actlen-tln)
+ (sl:destroy physlen-tln)
+ (sl:destroy mu-water-tln)
+ (sl:destroy poly-range-tln)
+ (sl:destroy a0-tln)
+ (sl:destroy a1-tln)
+ (sl:destroy a2-tln)
+ (sl:destroy a3-tln)
+ (sl:destroy a4-tln)
+ (sl:destroy a5-tln)
+ (sl:destroy diam-tln)
+ (sl:destroy wallthick-tln)
+ (sl:destroy endcap-tln)
+ (sl:destroy frm)
+ (sl:pop-event-level)
+ update))
+
+;;;--------------------------------------------------
+
+(defun brachy-table-manager ()
+
+ (let* ((items (append (source-menu nil) (source-menu t)))
+ (selection (sl:popup-menu (cons "New table"
+ (mapcar #'second items)))))
+ (if selection
+ (let* ((table (if (= selection 0)
+ (make-instance 'source-table)
+ (source-data (first (nth (1- selection) items)))))
+ (update (edit-source-table table)))
+ (if (and (= selection 0) update)
+ (push table *brachy-tables*))
+ (if (and update
+ (sl:confirm "Update the brachy source catalog file?"))
+ (put-all-objects *brachy-tables*
+ (merge-pathnames "source-catalog"
+ *brachy-database*)))))))
+
+;;;--------------------------------------------------
+
+(defun sievert (radius costh table)
+
+ "sievert radius costh table
+
+returns the interpolated value of the Prism modified Sievert integral
+from the specified source table. This is the lookup function, used in
+the actual dose calculation."
+
+ ;; (declare (type (simple-array single-float (13 11)) table))
+ (let* ((st10 (if (>= costh 1.0) 10.0
+ (- 10.0 (* 10.0 (sqrt (- 1.0 (* costh costh)))))))
+ (j (min (truncate st10) 9)) ;; j has to be < 10, array is dim 11
+ (fr2 (- st10 j)))
+ (declare (fixnum j) (single-float fr2))
+ (multiple-value-bind (i fr1)
+ (findslot radius *radii*)
+ (declare (fixnum i) (single-float fr1))
+ (+ (* (- 1.0 fr2) (- 1.0 fr1) (aref table i j))
+ (* fr1 (- 1.0 fr2) (aref table (+ i 1) j))
+ (* fr2 (- 1.0 fr1) (aref table i (+ j 1)))
+ (* fr1 fr2 (aref table (+ i 1) (+ j 1)))))))
+
+;;;--------------------------------------------------
+;;; End.
diff --git a/prism/src/brachy.cl b/prism/src/brachy.cl
new file mode 100644
index 0000000..f189ce4
--- /dev/null
+++ b/prism/src/brachy.cl
@@ -0,0 +1,394 @@
+;;;
+;;; brachy
+;;;
+;;; Definitions of radiation sources for brachytherapy, i.e., line
+;;; sources and seeds.
+;;;
+;;; 2-Sep-1992 I. Kalet created
+;;; 23-Jun-1994 I. Kalet change float to single-float
+;;; 30-Jan-1995 I. Kalet make classes subclasses of generic prism
+;;; classes, add more implementation details.
+;;; 9-Jun-1996 I. Kalet lots more implementation details, split
+;;; panels off into brachy-panels.
+;;; 7-Feb-2000 I. Kalet add announce of various slot update events,
+;;; make default treat-time 1.0, not 0.0.
+;;; 21-Feb-2000 I. Kalet take out rest pars in copy methods
+;;; 27-Mar-2000 I. Kalet add raw coords slots.
+;;; 6-Apr-2000 I. Kalet keep ap, lat mags and flags with each source,
+;;; even though redundant.
+;;; 10-May-2000 I. Kalet add application time and activity upper and
+;;; lower limits parameters.
+;;; 30-Jul-2000 I. Kalet replace distance-3d with inline code to make
+;;; this module more self-contained.
+;;; 31-Mar-2002 I. Kalet add support for permanent implants.
+;;; 1-May-2002 I. Kalet add id attribute so sources can keep their
+;;; numbers when some are deleted.
+;;; 5-May-2002 I. Kalet add announcement of new treat-time when
+;;; permanent flag is changed.
+;;; 1-Aug-2002 I. Kalet include new data in announce for new coords,
+;;; also announce update-plan when time or activity change, also copy
+;;; id and display-color in copy methods. Also change name of lateral
+;;; film flag to lat-flag instead of ll-flag.
+;;; 6-Oct-2002 I. Kalet change name of line-source event to
+;;; new-location to match seed event name, move to parent class.
+;;; 29-Jan-2003 I. Kalet change *brachy-activity-max*
+;;; 3-Nov-2003 I. Kalet move some parameters here from
+;;; brachy-dose-panels so they can be used with #. reader macro
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defparameter *brachy-activity-min* 0.0)
+(defparameter *brachy-activity-max* 50000.0)
+(defparameter *brachy-app-time-min* 0.0)
+(defparameter *brachy-app-time-max* 3000.0)
+
+;;;--------------------------------------------------
+
+(defclass brachy-source (generic-prism-object)
+
+ ((id :type fixnum
+ :accessor id
+ :initarg :id
+ :documentation "Sources are numbered sequentially when first
+created but keep their numbers even when some are deleted.")
+
+ (source-type :initarg :source-type
+ :accessor source-type
+ :documentation "The type of radiation source, as well
+as the designation of the model or size.")
+
+ (new-source-type :type ev:event
+ :accessor new-source-type
+ :initform (ev:make-event)
+ :documentation "Announced when the source type is
+updated.")
+
+ (activity :type single-float
+ :initarg :activity
+ :accessor activity
+ :documentation "The source strength in e.g., millicuries,
+or some other activity unit.")
+
+ (new-activity :type ev:event
+ :accessor new-activity
+ :initform (ev:make-event)
+ :documentation "Announced when the activity is
+changed.")
+
+ (permanent :initarg :permanent
+ :accessor permanent
+ :documentation "t if permanent implant source.")
+
+ (treat-time :type single-float
+ :initarg :treat-time
+ :accessor treat-time
+ :documentation "Number of hours the source is left
+in.")
+
+ (new-treat-time :type ev:event
+ :accessor new-treat-time
+ :initform (ev:make-event)
+ :documentation "Announced when the insertion time
+is changed.")
+
+ (display-color :initarg :display-color
+ :accessor display-color)
+
+ (new-color :type ev:event
+ :accessor new-color
+ :initform (ev:make-event)
+ :documentation "Announced when the color is changed.")
+
+ (update-plan :type ev:event
+ :accessor update-plan
+ :initform (ev:make-event)
+ :documentation "Announced when anything happens that
+should update a containing plan's time stamp.")
+
+ (new-location :type ev:event
+ :accessor new-location
+ :initform (ev:make-event)
+ :documentation "Announced when the location for a
+seed or an endpoint for a line source changes.")
+
+ (ap-flag :accessor ap-flag
+ :initarg :ap-flag
+ :documentation "True if using AP film rather than PA")
+
+ (ap-mag :type single-float
+ :accessor ap-mag
+ :initarg :ap-mag
+ :documentation "The AP film magnification, a number greater
+than 1.0 usually")
+
+ (lat-flag :accessor lat-flag
+ :initarg :lat-flag
+ :documentation "True if using right lateral film rather
+than left lateral film")
+
+ (lat-mag :type single-float
+ :accessor lat-mag
+ :initarg :lat-mag
+ :documentation "The lateral film magnification, a number
+greater than 1.0 usually")
+
+ (rotation :type single-float
+ :accessor rotation
+ :initarg :rotation
+ :documentation "The amount the orthogonal films are
+rotated from exactly AP/Lateral.")
+
+ (raw-ap-coords :type list
+ :accessor raw-ap-coords
+ :initarg :raw-ap-coords
+ :documentation "The raw data from orthogonal film
+entry of source coordinates.")
+
+ (raw-lat-coords :type list
+ :accessor raw-lat-coords
+ :initarg :raw-lat-coords
+ :documentation "The raw data from orthogonal film
+entry of source coordinates.")
+
+ (result :type dose-result
+ :initarg :result
+ :accessor result
+ :initform (make-dose-result)
+ :documentation "The result of computing dose from this
+source.")
+
+ )
+
+ (:default-initargs :name "" :id 0 :activity 10.0 :permanent nil
+ :treat-time 1.0
+ :ap-flag t :ap-mag 1.0 :lat-flag t :lat-mag 1.0
+ :rotation 0.0
+ :raw-ap-coords nil :raw-lat-coords nil
+ :display-color 'sl:red)
+
+ (:documentation "Brachy sources all share certain characteristics,
+collected here in a base class.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod slot-type ((object brachy-source) slotname)
+
+ (case slotname
+ (result :object)
+ (otherwise :simple)))
+
+(defmethod not-saved ((object brachy-source))
+
+ (append (call-next-method)
+ '(new-source-type new-activity new-treat-time new-color
+ update-plan new-location result)))
+
+;;;---------------------------------------------
+
+(defmethod invalidate-results ((src brachy-source) &rest ignored)
+
+ "invalidate-results (src brachy-source) &rest ignored
+
+An action function that invalidates a source's dose results and
+announces update-plan event. Called in response to various changes to
+source attributes."
+
+ (declare (ignore ignored))
+ (setf (valid-grid (result src)) nil)
+ (setf (valid-points (result src)) nil)
+ (ev:announce src (update-plan src)))
+
+;;;---------------------------------------------
+
+(defmethod (setf source-type) :after (new-type (src brachy-source))
+
+ (invalidate-results src)
+ (ev:announce src (new-source-type src) new-type))
+
+;;;---------------------------------------------
+
+(defmethod (setf activity) :after (new-act (src brachy-source))
+
+ (ev:announce src (update-plan src))
+ (ev:announce src (new-activity src) new-act))
+
+;;;---------------------------------------------
+
+(defmethod treat-time :around ((src brachy-source))
+
+ (if (permanent src)
+ (/ (half-life (source-data (source-type src))) 0.693)
+ (call-next-method)))
+
+;;;---------------------------------------------
+
+(defmethod (setf treat-time) :around (new-time (src brachy-source))
+
+ (declare (ignore new-time))
+ (if (permanent src)
+ (treat-time src) ;; don't do anything but return correct value
+ (call-next-method))) ;; go ahead and set the new value
+
+;;;---------------------------------------------
+
+(defmethod (setf treat-time) :after (new-time (src brachy-source))
+
+ (ev:announce src (update-plan src))
+ (ev:announce src (new-treat-time src) new-time))
+
+;;;---------------------------------------------
+
+(defmethod (setf permanent) :after (newval (src brachy-source))
+
+ (declare (ignore newval))
+ (ev:announce src (update-plan src))
+ (ev:announce src (new-treat-time src) (treat-time src)))
+
+;;;--------------------------------------
+
+(defmethod (setf display-color) :after (col (src brachy-source))
+
+ (ev:announce src (new-color src) col))
+
+;;;---------------------------------------------
+
+(defclass line-source (brachy-source)
+
+ ((end-1 :initarg :end-1
+ :accessor end-1
+ :documentation "The x,y,z coordinates of one end of the
+source.")
+
+ (end-2 :initarg :end-2
+ :accessor end-2
+ :documentation "The x,y,z coordinates of the other end of
+the source.")
+
+ )
+
+ (:default-initargs :name "Line source"
+ :end-1 '(0.0 0.0 1.0)
+ :end-2 '(0.0 0.0 -1.0))
+
+ (:documentation "Line sources are sealed reusable tubes or needles
+of radioactive material, radium, cesium or other...")
+
+ )
+
+;;;---------------------------------------------
+
+(defun make-line-source (src-name &rest initargs)
+
+ "make-line-source src-name
+
+returns a line source with specified or default name and initargs."
+
+ (apply #'make-instance 'line-source
+ :name (if (equal src-name "")
+ (format nil "~A" (gensym "LINESRC-"))
+ src-name)
+ initargs))
+
+;;;---------------------------------------------
+
+(defmethod (setf end-1) :after (new-end (src line-source))
+
+ (invalidate-results src)
+ (ev:announce src (new-location src) new-end))
+
+;;;---------------------------------------------
+
+(defmethod (setf end-2) :after (new-end (src line-source))
+
+ (invalidate-results src)
+ (ev:announce src (new-location src) new-end))
+
+;;;---------------------------------------------
+
+(defmethod copy ((obj line-source))
+
+ (make-line-source ""
+ :id (id obj)
+ :source-type (source-type obj)
+ :activity (activity obj)
+ :treat-time (treat-time obj)
+ :display-color (display-color obj)
+ :result (copy (result obj))
+ :end-1 (end-1 obj)
+ :end-2 (end-2 obj)))
+
+;;;---------------------------------------------
+
+(defun source-length (src)
+
+ (let* ((end1 (end-1 src))
+ (end2 (end-2 src))
+ (dx (- (first end2) (first end1)))
+ (dy (- (second end2) (second end1)))
+ (dz (- (third end2) (third end1))))
+ (declare (single-float dx dy dz))
+ (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
+
+;;;---------------------------------------------
+;;;
+;;; Seeds
+;;;
+;;;---------------------------------------------
+
+(defclass seed (brachy-source)
+
+ ((location :initarg :location
+ :accessor location
+ :documentation "The x,y,z coordinates of the source.")
+
+ )
+
+ (:default-initargs :name "Seed"
+ :location '(0.0 0.0 0.0))
+
+ (:documentation "Seeds are iridium, gold or iodine placed surgically
+in the tumor area.")
+
+ )
+
+;;;---------------------------------------------
+
+(defun make-seed (src-name &rest initargs)
+
+ "make-seed src-name
+
+returns a seed with specified or default name and initargs."
+
+ (apply #'make-instance 'seed
+ :name (if (equal src-name "")
+ (format nil "~A" (gensym "SEED-"))
+ src-name)
+ initargs))
+
+;;;---------------------------------------------
+
+(defmethod (setf location) :after (new-loc (src seed))
+
+ (invalidate-results src)
+ (ev:announce src (new-location src) new-loc))
+
+;;;---------------------------------------------
+
+(defmethod copy ((obj seed))
+
+ (make-seed ""
+ :id (id obj)
+ :source-type (source-type obj)
+ :activity (activity obj)
+ :treat-time (treat-time obj)
+ :display-color (display-color obj)
+ :result (copy (result obj))
+ :location (location obj)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/charts.cl b/prism/src/charts.cl
new file mode 100644
index 0000000..fd1c562
--- /dev/null
+++ b/prism/src/charts.cl
@@ -0,0 +1,1634 @@
+;;;
+;;; charts
+;;;
+;;; The functions for generating a chart are defined here.
+;;;
+;;; 11-Feb-1994 J. Unger started.
+;;; 06-Mar-1994 J. Unger put printer popup menu in make-chart-dialog-box.
+;;; 18-May-1994 I. Kalet move globals to prism-globals and
+;;; consolidate. Also, comments are now lists of strings.
+;;; 25-May-1994 J. Unger add Combined Doses page, Dose per Treatment
+;;; By Field page, and Total Dose by Field page to chart.
+;;; 6-Jun-1994 J. Jacky begin mods to scale to machine coord system
+;;; 22-Jun-1994 J. Jacky complete chart scaling for wedge rotation, arcs
+;;; 22-Jun-1994 J. Jacky improve style to minimize funcall and #'
+;;; 23-Jun-1994 J. Jacky handle collimator, blocks; add bounding-box fcn
+;;; move scale-angle out to therapy-machines, correct MU on setup
+;;; page: rounded MU/frac, not total correct Tray Fac: only apply when
+;;; blocks present, correct SSD, Iso Depth when isocenter outside patient
+;;; 24-Jun-1994 J. Jacky Fiddle with column alignment to improve readability
+;;; correct rounding: no decimal point in angles etc., correct
+;;; reversal of TOTAL DOSE.../DOSE PER... entries.
+;;; 15-Jul-1994 J. Unger points' z coords now print to two decimal
+;;; places and add patient id to each chart page.
+;;; 21-Jul-1994 J. Unger move bounding-box to polygons pkg.
+;;; 11-Aug-1994 J. Unger mods to run-subprocess command to print chart.
+;;; 26-Aug-1994 J. Unger fix bug in run-subprocess call.
+;;; 30-Aug-1994 J. Unger remove code to sort points - list should always be
+;;; in correct order now.
+;;; 31-Aug-194 J. Unger add make-neutron-chart function.
+;;; 16-Sep-1994 J. Unger round mu's to nearest mu on neutron chart. Also
+;;; modify neutron chart code to produce a chart for every field sent,
+;;; highlight the changed settings, rework interactive-make-chart calls
+;;; to make each type of chart.
+;;; 22-Sep-1994 J. Jacky Add write-leaf-settings and fill in
+;;; make-leaf-chart and make-neutron-chart.
+;;; 23-Sep-1994 J. Jacky make-neutron-chart uses brief-chart-header not main
+;;; 4-Oct-1994 J. Jacky in make-neutron-chart, round mu before compare
+;;; 26-Jan-1995 I. Kalet pass plan as parameter to make-leaf-chart and
+;;; interactive-make-leaf chart, etc. and get plan as third element of
+;;; beam-pairs. Use machine of original instead of funny find-if code
+;;; to get leaf-pair-map in make-neutron-chart.
+;;; 27-Apr-1995 I. Kalet combine ext. beam dosimetry and setup pages.
+;;; 14-Jun-1995 I. Kalet adjust page length for ext. beam pages.
+;;; 3-Sep-1995 I. Kalet convert possibly integer arguments to
+;;; poly:NEARLY-EQUAL function to SINGLE-FLOAT.
+;;; 26-Sep-1995 I. Kalet add range check for number of copies in
+;;; make-chart-dialog-box and add "File only" option to printer list.
+;;; 11-Oct-1996 I. Kalet use = instead of poly:NEARLY-EQUAL in cases
+;;; where arguments are guaranteed to be integers.
+;;; 29-Jan-1997 I. Kalet names of tpr and output-factor fields in dose
+;;; result have changed - use new names.
+;;; 1-May-1997 I. Kalet add menu for specifying only part of a chart
+;;; to be printed.
+;;; 6-Jun-1997 I. Kalet machine returns the object, not the name
+;;; 3-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx .
+;;; 16-Sep-1997 I. Kalet eliminate remaining explicit calls to
+;;; get-therapy-machine.
+;;; 11-Nov-1997 I. Kalet fix egregious lisp gaff in print list menu
+;;; code - remove returns a result, does not modify its argument.
+;;; Also print Extend for TPR at ISO when it is negative, blank for
+;;; various items in beam setup when axis misses, and don't print dose
+;;; info sections when central axis of any beam misses.
+;;; 30-Apr-1998 I. Kalet move irreg chart stuff here from irreg-panels
+;;; and begin migration of all chart code to Postscript.
+;;; 12-May-1998 I. Kalet change name of list of printers to *printers*
+;;; 19-May-1998 I. Kalet move prism-logo to postscript module.
+;;; 11-Jun-1998 I. Kalet make sure the Prism name is printed with the
+;;; version string on plain charts, add explicit go to next page on
+;;; main chart when not printing combined doses section.
+;;; 15-Dec-1998 I. Kalet add list of organs and densities that were
+;;; used in the dose computation, on first page of regular chart.
+;;; 24-Dec-1998 I. Kalet remove wait t from run-subprocess, now default
+;;; 25-Feb-1999 I. Kalet fix error in MU/degree for arcs - forgot to
+;;; divide by the number of treatments. Also put the printer list on
+;;; the dialog box instead of yet another popup menu.
+;;; 14-Sep-1999 I. Kalet in call to compute-mlc always use collimator
+;;; angle, there is no difference between CNTS and Elekta here.
+;;; 5-Mar-2000 I. Kalet begin adding brachytherapy support.
+;;; 29-Mar-2000 I. Kalet ongoing work on brachy, and PostScript conversion.
+;;; 25-Apr-2000 I. Kalet add activity units for seeds.
+;;; 8-May-2000 I. Kalet add more printout for seeds, finish line
+;;; source specs printout.
+;;; 19-Jul-2000 I. Kalet cosmetic fine tuning of printing beam names.
+;;; Also fix page count computation.
+;;; 8-Aug-2000 I. Kalet add multi-page capability for dose per beam
+;;; as well as total dose.
+;;; 26-Nov-2000 I. Kalet cosmetics for buttons in dialog box.
+;;; 11-Mar-2001 I. Kalet print point Z coords to 3 decimal places.
+;;; 26-Nov-2001 J. Jacky beam-specs: separate photon/neutron, electron pages
+;;; recompute page numbers etc. to match
+;;; 3-Dec-2001 J. Jacky beam-specs: details, electron vs. photon-neutron page
+;;; 7-Dec-2001 J. Jacky beam-specs: e tweaks,SSD and ROF are only dose-results
+;;; 6-Jan-2002 I. Kalet print beam names in three rows of 10 chars
+;;; 28-Jan-2002 I. Kalet/J. Jacky add dicom chart type to menu in
+;;; chart panel, merge in the rest of the dicom chart functions.
+;;; 12-Sep-2003 BobGian regularize function name: ADD-BEAM -> ADD-BEAM-FCN to
+;;; assist readability of Dose-Monitoring-Point code [comments only, here].
+;;; 03-Oct-2003 BobGian change defstruct name and slot names in SEG-REC-... to
+;;; SEGMENT-DESCRIPTOR-... to make DMP code more readable.
+;;; Ditto with a few local variables.
+;;; STATIC, DYNAMIC, SEGMENT (Prism pkg) -> Keyword pkg.
+;;; Format indentation to get text within 80-column width.
+;;; 04-Dec-2003 BobGian: SEGMENT-DESCRIPTOR-... -> SEGDATA-... .
+;;; 23-Feb-2003 BobGian: update naming conventions which distinguish between
+;;; Prism vs Dicom beams and Prism vs Dicom DMPs. This includes:
+;;; SEGDATA-... -> PR-BEAM-...
+;;; 08-Mar-2003 BobGian: Edited DEFSTRUCTs for PR-BEAM in "imrt-segments".
+;;; Replaced PR-BEAM-TOTSEGS and PR-BEAM-SEGNUM slots by equivalent code.
+;;; 17-May-2004 BobGian complete process of extending all instances of Original
+;;; and Current Prism beam instances to include Copied beam instance too,
+;;; to provide copy for comparison with Current beam without mutating
+;;; Original beam instance.
+;;; 21-Jun-2004 I. Kalet take out IRREG support - IRREG discontinued
+;;; 26-Sep-2004 BobGian rename slot PR-BEAM-CUM-MU -> PR-BEAM-CUM-MU-INC.
+;;; 05-Oct-2004 BobGian fixed couple of lines to fit within 80 cols.
+;;; 17-Feb-2005 A. Simms replaced an allegro getenv call with a misc.cl wrapper
+;;; getenv call.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------------
+
+(defparameter *pts-full-page* 48
+ "Number of combined point dose lines that will fit on a full page")
+
+;;;----------------------------------------------------
+
+(defun chart-header (chart cur-pat pln total-pgs)
+
+ "chart-header chart cur-pat pln total-pgs
+
+writes the big header at the top of the first chart page, the same for
+all charts."
+
+ (ps:initialize chart 0.5 0.5 7.5 10.0)
+ (ps:prism-logo chart 0.6 10.4 *prism-version-string*)
+ (ps:set-font chart "Helvetica" 14)
+ (ps:set-position chart 0.1 1.5)
+ (ps:indent chart 0.1)
+ (ps:put-text chart (first *hardcopy-header*))
+ (ps:put-text chart (second *hardcopy-header*))
+ (ps:set-font chart "Courier" 12)
+ (ps:set-position chart 4.25 0.2)
+ (ps:indent chart 4.25)
+ (ps:put-text chart " APPROVED BY:")
+ (ps:put-text chart "")
+ (ps:put-text chart "ATTENDING: ________ DATE: ______")
+ (ps:put-text chart "")
+ (ps:put-text chart "RESIDENT: ________ DATE: ______")
+ (ps:put-text chart "")
+ (ps:put-text chart "PHYSICIST: ________ DATE: ______")
+ (ps:put-text chart "")
+ (ps:put-text chart "THERAPIST: ________ DATE: ______")
+ (ps:put-text chart "")
+ (ps:put-text chart "BILLED: ________________________")
+ (ps:indent chart 0.1)
+ (brief-header chart cur-pat pln 1 total-pgs 2.0)
+ (dolist (cmt (comments cur-pat))
+ (ps:put-text chart cmt))
+ (ps:put-text chart "")
+ (when pln
+ (ps:put-text chart (format nil "DS: ~A" (plan-by pln)))
+ (ps:put-text chart "")
+ (dolist (cmt (comments pln))
+ (ps:put-text chart cmt))
+ (ps:put-text chart "")
+ (ps:put-text chart "Organs used in dose computation:")
+ (ps:put-text chart "--------------------------------")
+ (ps:put-text chart "")
+ (dolist (org (coll:elements (anatomy cur-pat)))
+ (when (density org)
+ (ps:put-text chart (format nil "~15A : ~4,2F"
+ (name org) (density org)))))
+ (ps:put-text chart "")))
+
+;;;----------------------------------------------------
+
+(defun brief-header (chart cur-pat pln pgnum total-pgs
+ &optional (top-margin 0.0))
+
+ "brief-header chart cur-pat pln pgnum total-pgs &optional (top-margin 0.0)
+
+writes the brief header that appears at the top (or down an amount of
+top-margin) on every chart page."
+
+ (ps:draw-rectangle chart 0.5 0.5 7.5 10.0)
+ (ps:set-position chart 6.0 (+ top-margin 0.2))
+ (ps:put-text chart (format nil "PAGE: ~A of ~A" pgnum total-pgs))
+ (ps:set-position chart 0.1 (+ top-margin 0.5))
+ (ps:indent chart 0.1)
+ (ps:put-text chart (format nil "PATIENT: ~A" (name cur-pat)))
+ (ps:put-text chart (format nil "PAT ID: ~A" (patient-id cur-pat)))
+ (when pln
+ (ps:put-text chart (format nil "PLAN: ~A" (name pln))))
+ (ps:set-position chart 4.25 (+ top-margin 0.5))
+ (ps:indent chart 4.25)
+ (ps:put-text chart (format nil "CASE DATE: ~A" (date-entered cur-pat)))
+ (ps:put-text chart (format nil "HOSP ID: ~A" (hospital-id cur-pat)))
+ (when pln
+ (ps:put-text chart (format nil "PLAN DATE: ~A" (time-stamp pln))))
+ (ps:indent chart 0.1)
+ (ps:put-text chart ""))
+
+;;;----------------------------------------------------
+
+(defun print-points (chart pts doses start end)
+
+ "prints point data and doses from point numbers start through end
+inclusive from pts with column labels"
+
+ (when (< start end)
+ (ps:put-text chart
+ " Site Total Dose (cGy) X Y Z")
+ (ps:put-text chart "")
+ (do* ((i start (1+ i))
+ (pt (nth i pts) (nth i pts))
+ (dose (nth i doses) (nth i doses))
+ (name (subseq (name pt) 0 (min 16 (length (name pt))))
+ (subseq (name pt) 0 (min 16 (length (name pt))))))
+ ((= i end) nil)
+ (ps:put-text chart
+ (format nil "~2 at a. ~16a ~5 at a ~8,1F ~8,1F ~8,3F"
+ (id pt) name (round dose)
+ (x pt) (y pt) (z pt))))))
+
+;;;----------------------------------------------------
+
+(defun combined-doses (chart cur-pat pln lines page-no total-pgs)
+
+ "combined-doses chart cur-pat pln lines page-no total-pgs
+
+prints the combined total doses from all sources, external beam or
+brachytherapy in the specified plan PLN for patient CUR-PAT."
+
+ (ps:put-text
+ chart
+ "----------------------- COMBINED POINT DOSES ----------------------")
+ (ps:put-text chart "")
+ (if (valid-points (sum-dose pln))
+ (let* ((pts (coll:elements (points cur-pat)))
+ (doses (points (sum-dose pln)))
+ (end (length pts)))
+ (if (<= end (- lines 2))
+ (progn
+ (print-points chart pts doses 0 end)
+ (ps:finish-page chart (< page-no total-pgs))
+ (incf page-no))
+ (let ((npts1 (max 0 (- lines 2))))
+ (print-points chart pts doses 0 npts1)
+ (ps:finish-page chart (< page-no total-pgs))
+ (incf page-no)
+ (do* ((pt-list (nthcdr npts1 pts)
+ (nthcdr *pts-full-page* pt-list))
+ (dose-list (nthcdr npts1 doses)
+ (nthcdr *pts-full-page* dose-list)))
+ ((null pt-list) nil)
+ (brief-header chart cur-pat pln page-no total-pgs)
+ (print-points chart pt-list dose-list
+ 0 (min *pts-full-page* (length pt-list)))
+ (ps:finish-page chart (< page-no total-pgs))
+ (incf page-no)))))
+ (progn
+ (ps:put-text chart "Combined doses not available")
+ (ps:finish-page chart (< page-no total-pgs))
+ (incf page-no)))
+ page-no)
+
+;;;----------------------------------------------------
+
+(defun beam-specs (chart cur-pat pln page-no total-pgs modality)
+
+ (let ((bms
+ ;; I'm sure there's a more elegant way to choose remove-if/-if-not
+ ;; and also to shorten remove- call by using :key.
+ (if (eq modality 'electron)
+ ;; call argument modality because particle is a slot in machine
+ (remove-if-not (lambda (b) (eq (particle (machine b)) 'electron))
+ (coll:elements (beams pln)))
+ (remove-if (lambda (b) (eq (particle (machine b)) 'electron))
+ (coll:elements (beams pln))))))
+ (do ((bm-list bms (nthcdr 4 bm-list)))
+ ((null bm-list) page-no)
+ (brief-header chart cur-pat pln page-no total-pgs)
+ (ps:put-text
+ chart
+ (format
+ nil
+ "------------------- ~A BEAM SETUP AND DOSIMETRY -----------------"
+ (if (eq modality 'electron) "ELECTRON" "EXTERNAL")))
+ (ps:set-position chart 0.1 1.5)
+
+ ;; the name is up to 30 chars in 10 character pieces
+ (ps:put-text chart "Name :")
+ (ps:put-text chart "")
+ (ps:put-text chart "")
+ (ps:put-text chart "Machine :")
+ (ps:put-text chart "")
+ (ps:put-text chart "Particle :")
+ (ps:put-text chart "Energy :")
+ (ps:put-text chart "MU/Frac :")
+ (ps:put-text chart "Fractions :")
+ (ps:put-text chart "SSD :")
+ (ps:put-text chart "")
+ (ps:put-text chart (if (eq modality 'electron) "" "Wedge Sel :"))
+ (ps:put-text chart (if (eq modality 'electron) "" "Wedge Rot :"))
+ (ps:put-text chart "")
+ (ps:put-text chart (if (eq modality 'electron)
+ "Applicator:" "Collimator:"))
+ (ps:put-text chart (if (eq modality 'electron)
+ "" "(cm) :")) ;electron accessory?
+ (ps:put-text chart (if (eq modality 'electron)
+ "" " :")) ;electron fitment?
+ (ps:put-text chart " :")
+ (ps:put-text chart "")
+ (ps:put-text chart "Gantry :")
+ (ps:put-text chart "Arc Size :")
+ (ps:put-text chart "Coll Ang :")
+ (ps:put-text chart "Tabl Ang :")
+ (ps:put-text chart "")
+ (ps:put-text chart (if (eq modality 'electron) "" "Blocks :"))
+ (ps:put-text chart "")
+ (ps:put-text chart "Tabl Hgt :")
+ (ps:put-text chart "Tabl Lat :")
+ (ps:put-text chart "Tabl Lng :")
+ (ps:put-text chart "")
+ ;; If any of the 4 are arcs, print this stuff
+ (when (find-if-not #'(lambda (b) (zerop (arc-size b)))
+ bm-list)
+ (ps:put-text chart "Start Ang :")
+ (ps:put-text chart "Stop Ang :")
+ (ps:put-text chart "Arc Size :")
+ (ps:put-text chart "MU/deg :")
+ (ps:put-text chart ""))
+ (ps:put-text chart "Iso Depth :")
+ (ps:put-text chart "")
+ (ps:put-text chart (if (eq modality 'electron) "" "Coll X :"))
+ (ps:put-text chart (if (eq modality 'electron) "" "Coll Y :"))
+ (ps:put-text chart (if (eq modality 'electron) "" "Equiv Sqr :"))
+ (ps:put-text chart "")
+ (ps:put-text chart "ROF :")
+ (ps:put-text chart (if (eq modality 'electron) "" "TPR @ Iso :"))
+ (ps:put-text chart (if (eq modality 'electron) "" "Tray Fac :"))
+ (ps:put-text chart "Atten Fac :")
+
+ ;; now do each of the beams on this page
+ (dotimes (i (min 4 (length bm-list)))
+ (ps:set-position chart (+ 1.3 (* i 1.6)) 1.5)
+ (ps:indent chart (+ 1.3 (* i 1.6)))
+ (let* ((bm (nth i bm-list))
+ (mach (machine bm))
+ (wdg (wedge bm))
+ (name-str (listify (name bm) 10)))
+ (dolist (str name-str)
+ (ps:put-text chart (format nil "~10A" str)))
+ (dotimes (i (- 3 (length name-str)))
+ (ps:put-text chart ""))
+ (ps:put-text chart (format nil "~14A" (machine-name bm)))
+ (ps:put-text chart "")
+ (ps:put-text chart (format nil "~14A" (particle mach)))
+ (ps:put-text chart (apply #'format nil "~6 at A ~3A"
+ (if (eq (collimator-type mach)
+ 'electron-coll)
+ (list (energy (collimator bm))
+ "MeV")
+ (list (energy mach) "MV"))))
+ (ps:put-text chart (format nil "~6 at A MU/F"
+ (round (/ (monitor-units bm)
+ (n-treatments bm)))))
+ (ps:put-text chart (format nil "~6 at A" (n-treatments bm)))
+ (ps:put-text chart (let ((d (ssd (result bm))))
+ (if (minusp d) "MISS"
+ (format nil "~6,1F cm" d))))
+ (ps:put-text chart "")
+ (ps:put-text chart (if (eq modality 'electron)
+ ""
+ (format nil "~16A"
+ (wedge-label (id wdg) mach))))
+ (if (or (zerop (id wdg)) (not (wedge-rot-print-flag mach)))
+ (ps:put-text chart "")
+ (let ((ang (scale-angle (rotation wdg)
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach))))
+ (ps:put-text chart (format nil "~6 at A ~A"
+ (round (first ang)) (second ang)))))
+ (ps:put-text chart "")
+
+ ;; collimator setup here
+ (let ((coll (collimator bm))
+ (coll-info (collimator-info mach)))
+ ;; Put collimator y on first line because Varian calls it upper
+ (ps:put-text
+ chart
+ (apply #'format nil "~6,1F ~A"
+ (typecase coll
+ ((or symmetric-jaw-coll combination-coll)
+ (list (y coll) (y-name coll-info)))
+ (variable-jaw-coll
+ (list (y-inf coll) (y-inf-name coll-info)))
+ (multileaf-coll
+ (let* ((box (poly:bounding-box
+ (vertices coll)))
+ (ymin (second (first box)))
+ (ymax (second (second box))))
+ (list (- ymax ymin) "height")))
+ (electron-coll
+ (list (cone-size coll) "cm")))))
+ ;; Put collimator x on second line because Varian calls it lower
+ (ps:put-text
+ chart
+ (if (eq modality 'electron)
+ "" ; possibly print accessory number here?
+ (apply #'format nil "~6,1F ~A"
+ (typecase coll
+ (symmetric-jaw-coll
+ (list (x coll) (x-name coll-info)))
+ (combination-coll
+ (if (poly:nearly-equal (x-inf coll)
+ (x-sup coll))
+ (list (+ (x-inf coll) (x-sup coll))
+ (x-sym-name coll-info))
+ (list (x-inf coll)
+ (x-inf-name coll-info))))
+ (variable-jaw-coll
+ (list (y-sup coll) (y-sup-name coll-info)))
+ (multileaf-coll
+ (let* ((box (poly:bounding-box
+ (vertices coll)))
+ (ymin (second (first box)))
+ (ymax (second (second box))))
+ (list (/ (+ ymax ymin) 2) "h offset")))
+ (electron-coll
+ (list (cone-size coll) ""))))))
+ ;; third line, we're done with simple collimators
+ (ps:put-text
+ chart
+ (if (eq modality 'electron)
+ "" ; possibly print fitment number here?
+ (apply #'format nil "~6,1F ~A"
+ (typecase coll
+ ((or symmetric-jaw-coll electron-coll)
+ (list "" ""))
+ (combination-coll
+ (if (poly:nearly-equal (x-inf coll)
+ (x-sup coll))
+ (list "" "")
+ (list (x-sup coll)
+ (x-sup-name coll-info))))
+ (variable-jaw-coll
+ (list (x-inf coll) (x-inf-name coll-info)))
+ (multileaf-coll
+ (let* ((box (poly:bounding-box
+ (vertices coll)))
+ (xmin (first (first box)))
+ (xmax (first (second box))))
+ (list (- xmax xmin) "width")))))))
+ ;; fourth line: variable jaw and mlc only
+ (ps:put-text
+ chart
+ (apply #'format nil "~6,1F ~A"
+ (typecase coll
+ ((or symmetric-jaw-coll combination-coll
+ electron-coll)
+ (list "" ""))
+ (variable-jaw-coll
+ (list (x-sup coll) (x-sup-name coll-info)))
+ (multileaf-coll
+ (let* ((box (poly:bounding-box
+ (vertices coll)))
+ (xmin (first (first box)))
+ (xmax (first (second box))))
+ (list (/ (+ xmax xmin) 2)
+ "w offset")))))))
+ (ps:put-text chart "")
+ (let ((ang (scale-angle (gantry-angle bm)
+ (gantry-scale mach)
+ (gantry-offset mach))))
+ (ps:put-text chart (format nil "~6 at A ~A"
+ (round (first ang)) (second ang))))
+ ;; arc size always positive, no scaling
+ (ps:put-text chart
+ (if (zerop (arc-size bm)) " fixed"
+ (format nil "~6 at A deg" (round (arc-size bm)))))
+ (let ((ang (scale-angle (collimator-angle bm)
+ (collimator-scale mach)
+ (collimator-offset mach)
+ (collimator-negative-flag mach)
+ (collimator-lower-limit mach)
+ (collimator-upper-limit mach))))
+ (ps:put-text chart (format nil "~6 at A ~A"
+ (round (first ang)) (second ang))))
+ (let ((ang (scale-angle (couch-angle bm)
+ (turntable-scale mach)
+ (turntable-offset mach)
+ (turntable-negative-flag mach)
+ (turntable-lower-limit mach)
+ (turntable-upper-limit mach))))
+ (ps:put-text chart (format nil "~6 at A ~A"
+ (round (first ang)) (second ang))))
+ (ps:put-text chart "")
+ (ps:put-text chart (cond ((eq modality 'electron)
+ "")
+ ((typep (collimator bm) 'multileaf-coll)
+ " leaf")
+ ((null (coll:elements (blocks bm)))
+ " none")
+ (t "blocks")))
+ (ps:put-text chart "")
+ (ps:put-text chart (format nil "~6,1F cm" (couch-height bm)))
+ (ps:put-text chart (format nil "~6,1F cm" (couch-lateral bm)))
+ (ps:put-text chart (format nil "~6,1F cm" (couch-longitudinal bm)))
+ (ps:put-text chart "")
+
+ (when (find-if-not #'(lambda (b) (zerop (arc-size b)))
+ bm-list)
+ ;; Start angle is Prism gantry-angle, scaled
+ ;; Stop angle is Prism (gantry-angle + arc-size), scaled
+ ;; Therefore stop angle may be less than Start angle in
+ ;; machine system
+ (let ((ang (scale-angle (gantry-angle bm)
+ (gantry-scale mach)
+ (gantry-offset mach))))
+ (ps:put-text chart (format nil "~6 at A ~A"
+ (round (first ang)) (second ang))))
+ (let ((ang (scale-angle (+ (gantry-angle bm)
+ (arc-size bm))
+ (gantry-scale mach)
+ (gantry-offset mach))))
+ (ps:put-text chart (format nil "~6 at A ~A"
+ (round (first ang)) (second ang))))
+ (ps:put-text chart (format nil "~6 at A deg" (round (arc-size bm))))
+ (ps:put-text chart (if (zerop (arc-size bm)) ""
+ (format nil "~6,2F MU"
+ (/ (monitor-units bm)
+ (* (arc-size bm)
+ (n-treatments bm))))))
+ (ps:put-text chart ""))
+
+ (let* ((dd (ssd (result bm)))
+ (depth (- (cal-distance mach) dd)))
+ (ps:put-text chart (cond ((minusp dd) "")
+ ((minusp depth) "EXTEND")
+ (t (format nil "~6,1F cm" depth)))))
+ (ps:put-text chart "")
+
+ ;; collimator x, y
+ (let* ((coll (collimator bm))
+ (x (typecase coll
+ (symmetric-jaw-coll (x coll))
+ ((or variable-jaw-coll combination-coll)
+ (+ (x-inf coll) (x-sup coll)))
+ (multileaf-coll
+ (let ((box (poly:bounding-box (vertices coll))))
+ (- (first (second box)) (first (first box)))))
+ (electron-coll (cone-size coll)))) ; we don't use this
+ (y (typecase coll
+ ((or symmetric-jaw-coll combination-coll) (y coll))
+ (variable-jaw-coll (+ (y-inf coll) (y-sup coll)))
+ (multileaf-coll
+ (let ((box (poly:bounding-box (vertices coll))))
+ (- (second (second box)) (second (first box)))))
+ (electron-coll (cone-size coll))))) ; we don't use this
+ (ps:put-text chart (if (eq modality 'electron)`
+ ""
+ (format nil "~6,1F cm" x)))
+ (ps:put-text chart (if (eq modality 'electron)
+ ""
+ (format nil "~6,1F cm" y)))
+
+ ;; equiv sqr, ROF, TPR at iso
+ (if (not (valid-points (result bm)))
+ ;; now handle electron beams in each case below
+ (progn (ps:put-text chart "")
+ (ps:put-text chart "")
+ (ps:put-text chart "")
+ (ps:put-text chart "")
+ (ps:put-text chart ""))
+ (progn
+ (ps:put-text chart (if (or (minusp (ssd (result bm)))
+ (eq modality 'electron))
+ ""
+ (format nil "~6,1F cm"
+ (equiv-square (result bm)))))
+ (ps:put-text chart "")
+ (ps:put-text chart
+ (format nil "~6,3F" (output-comp (result bm))))
+ (let ((tpriso (tpr-at-iso (result bm))))
+ (ps:put-text
+ chart (cond ((eq modality 'electron) "")
+ ((minusp (ssd (result bm))) "")
+ ((minusp tpriso) "EXTEND")
+ (t (format nil "~6,3F" tpriso)))))
+ (ps:put-text
+ chart (if (null (coll:elements (blocks bm))) ""
+ (format nil "~6,3F" (tray-factor mach))))))
+ (ps:put-text chart (format nil "~6,3F" (atten-factor bm))))))
+ (ps:finish-page chart (< page-no total-pgs))
+ (incf page-no))
+ page-no))
+
+;;;----------------------------------------------------
+
+(defun dose-per-beam (chart cur-pat pln page-no total-pgs fractional)
+
+ (do* ((pt-list (coll:elements (points cur-pat))
+ (nthcdr *pts-full-page* pt-list))
+ (sum-doses (if (valid-points (sum-dose pln))
+ (points (sum-dose pln)))
+ (nthcdr *pts-full-page* sum-doses))
+ (start-pt 0 (+ start-pt *pts-full-page*))
+ (npts (min *pts-full-page* (length pt-list))
+ (min *pts-full-page* (length pt-list))))
+ ((null pt-list) nil)
+ (do ((bm-list (coll:elements (beams pln)) (nthcdr 4 bm-list)))
+ ((null bm-list))
+ (brief-header chart cur-pat pln page-no total-pgs)
+ (ps:put-text
+ chart
+ (format nil "~A~A~A"
+ "-------------------"
+ (if fractional " DOSE PER TREATMENT BY FIELD (cGy) "
+ "---- TOTAL DOSE BY FIELD (cGy) ----")
+ "-------------------"))
+ ;; write column 1, the point names
+ (ps:set-position chart 0.1 1.5)
+ (ps:put-text chart "Site:")
+ (ps:put-text chart "")
+ (ps:put-text chart "")
+ (do* ((i 0 (1+ i))
+ (pt (nth i pt-list) (nth i pt-list)))
+ ((= i npts) nil)
+ (ps:put-text chart (format nil "~2 at A. ~16A" (id pt)
+ (if (< (length (name pt)) 16) (name pt)
+ (subseq (name pt) 0 16)))))
+ ;; if fractional skip the next column
+ (unless fractional
+ (ps:set-position chart 2.0 1.5)
+ (ps:indent chart 2.0)
+ (ps:put-text chart "Total")
+ (ps:put-text chart "")
+ (ps:put-text chart "")
+ (if (valid-points (sum-dose pln))
+ (do* ((i 0 (1+ i))
+ (dose (nth i sum-doses) (nth i sum-doses)))
+ ((= i npts) nil)
+ (ps:put-text chart (format nil "~8,1F" (round dose))))))
+ ;; do each beam up to 4 at a time
+ (dotimes (i (min 4 (length bm-list)))
+ (ps:set-position chart (+ 2.9 (* i 1.18)) 1.5)
+ (ps:indent chart (+ 2.9 (* i 1.18)))
+ (let* ((bm (nth i bm-list))
+ (name-str (listify (name bm) 10)))
+ (dolist (str name-str)
+ (ps:put-text chart (format nil "~10A" str)))
+ (dotimes (i (- 3 (length name-str)))
+ (ps:put-text chart ""))
+ (if (valid-points (result bm))
+ (do* ((i start-pt (1+ i))
+ (dose (nth i (points (result bm)))
+ (nth i (points (result bm)))))
+ ((= i (+ start-pt npts)) nil)
+ (ps:put-text
+ chart (format nil "~8,1F"
+ (if fractional
+ (/ (* dose (monitor-units bm))
+ (n-treatments bm))
+ (* dose (monitor-units bm)))))))))
+ (ps:finish-page chart (< page-no total-pgs))
+ (incf page-no)))
+ page-no)
+
+;;;----------------------------------------------------
+
+(defun line-specs (chart line-sources)
+
+ (ps:put-text chart "")
+ (ps:put-text
+ chart
+ "--------------------------- LINEAR SOURCES ---------------------------")
+ (ps:put-text chart "")
+ (ps:put-text
+ chart
+ " Source type Appl. Activ Filt. Meas. Total Active Gamma")
+ (ps:put-text
+ chart
+ " time -ity (mm) len(cm) len(cm) len(cm)")
+ (ps:put-text chart "")
+ (do* ((srclist line-sources (rest srclist))
+ (i 1 (1+ i)))
+ ((null srclist))
+ (let* ((src (first srclist))
+ (srcdata (find (source-type src) *brachy-tables*
+ :key #'src-type :test #'string-equal)))
+ (ps:put-text chart
+ (format nil
+ "~2 at A. ~16A~6,1F~6,1F~6,1F~8,2F~8,2F~8,2F~8,2F"
+ i (source-type src) (treat-time src)
+ (activity src) (* 10.0 (wall-thickness srcdata))
+ 0.0 ;; replace with computed length
+ (physlen srcdata) (actlen srcdata)
+ (* (dose-rate-const srcdata)
+ (anisotropy-fn srcdata)))))))
+
+;;;----------------------------------------------------
+
+(defun seed-specs (chart seeds)
+
+ (ps:put-text chart "")
+ (ps:put-text chart
+ "------------------------ SEEDS ------------------------")
+ (ps:put-text chart "")
+ (ps:put-text
+ chart
+ " Appl. Activity Dose Rate Aniso.")
+ (ps:put-text
+ chart
+ " time constant factor")
+ (ps:put-text chart "")
+ (do* ((srclist seeds (rest srclist))
+ (i 1 (1+ i))
+ (start-count 1)
+ (prev-type (source-type (first srclist)) (source-type src))
+ (prev-treattime (treat-time (first srclist)) (treat-time src))
+ (prev-act (activity (first srclist)) (activity src))
+ (prev-table (source-data (source-type (first srclist)))
+ (source-data (source-type src)))
+ (prev-drate (dose-rate-const prev-table) (dose-rate-const prev-table))
+ (prev-units (activity-units prev-table) (activity-units prev-table))
+ (prev-proto (protocol prev-table) (protocol prev-table))
+ (prev-aniso (anisotropy-fn prev-table) (anisotropy-fn prev-table))
+ (src (first srclist) (first srclist)))
+ ((null srclist)
+ (ps:put-text
+ chart
+ (format nil
+ "~3A thru ~3A ~16A~6,1F~6,1F ~5A ~5,2F ~5,2F"
+ start-count (1- i)
+ (concatenate 'string prev-type " " prev-proto)
+ prev-treattime prev-act
+ prev-units prev-drate prev-aniso)))
+ (when (or (not (string-equal prev-type (source-type src)))
+ (/= prev-treattime (treat-time src))
+ (/= prev-act (activity src)))
+ (ps:put-text
+ chart
+ (format nil
+ "~3A thru ~3A ~16A~6,1F~6,1F ~5A ~5,2F ~5,2F"
+ start-count (1- i)
+ (concatenate 'string prev-type " " prev-proto)
+ prev-treattime prev-act
+ prev-units prev-drate prev-aniso))
+ (setq start-count i))))
+
+;;;----------------------------------------------------
+
+(defun dose-per-source (chart cur-pat pln page-no total-pgs)
+
+ (do ((srclist (coll:elements (line-sources pln)) (nthcdr 4 srclist)))
+ ((null srclist))
+ (brief-header chart cur-pat pln page-no total-pgs)
+ (ps:put-text
+ chart
+ "--------------------- TOTAL DOSE BY SOURCE ---------------------")
+ (ps:set-position chart 0.1 1.5)
+ (ps:put-text chart "Site:")
+ (ps:put-text chart "")
+ (dolist (pt (coll:elements (points cur-pat)))
+ (ps:put-text chart (format nil "~2 at A. ~16A" (id pt)
+ (if (< (length (name pt)) 16) (name pt)
+ (subseq (name pt) 0 15)))))
+ (dotimes (i (min 4 (length srclist)))
+ (ps:set-position chart (+ 3.0 (* i 1.18)) 1.5)
+ (ps:indent chart (+ 3.0 (* i 1.2)))
+ (let ((src (nth i srclist)))
+ (ps:put-text chart (format nil "Source ~2A" i))
+ (ps:put-text chart "")
+ (if (valid-points (result src))
+ (dolist (dose (points (result src)))
+ (ps:put-text chart (format nil "~8,1F"
+ (* dose (activity src)
+ (treat-time src))))))))
+ (ps:finish-page chart (< page-no total-pgs))
+ (incf page-no))
+ page-no)
+
+;;;----------------------------------------------------
+
+(defun main-chart (parts cur-pat pln)
+
+ "main-chart parts cur-pat pln
+
+Generates a chart for the specified plan, and writes it to a file.
+The doses to points are also computed before the chart is printed,
+since they are written on the chart. The parts numbered in the list
+parts are included, 0 for the combined doses, 1 for the beam
+settings, 2 for the doses per fraction, 3 for the total doses, 4 for
+brachy source specs."
+
+ (unless (valid-points (sum-dose pln))
+ (when (coll:elements (points cur-pat))
+ (compute-dose-points pln cur-pat)))
+ ;; figure out how many pages the chart is
+ (let* ((n-comment-lines (+ (length (comments cur-pat))
+ 1 ;; blank always printed
+ (if pln (+ (length (comments pln))
+ (length (remove-if
+ #'(lambda (x)
+ (null (density x)))
+ (coll:elements
+ (anatomy cur-pat))))
+ 7) ;; blanks and labels
+ 0)))
+ (n-pts-page1 (- 36 n-comment-lines))
+ (n-pts (length (coll:elements (points cur-pat))))
+ ;; n-bm-pages is total of all beams, used for npt-pages
+ (n-bm-pages (if pln
+ (ceiling (length (coll:elements (beams pln))) 4)
+ 0))
+ ;; n-e-pages is electron beams only, one set of pages
+ (n-e-pages (if pln
+ (ceiling (length
+ (remove-if-not
+ (lambda (b) (eq (particle (machine b))
+ 'electron))
+ (coll:elements (beams pln))))
+ 4)
+ 0))
+ ;; n-pn-pages is photon/neutron beams only, another set of pages
+ (n-pn-pages (- n-bm-pages n-e-pages))
+ (npt-pages (* n-bm-pages (ceiling n-pts *pts-full-page*)))
+ (total-pages (+ 1 (if (and (member :combined parts)
+ (> n-pts n-pts-page1))
+ (ceiling (- n-pts n-pts-page1)
+ *pts-full-page*)
+ 0)
+ (if (member :beam-specs parts)
+ (+ n-e-pages n-pn-pages) 0)
+ (if (member :beam-frac-dose parts) npt-pages 0)
+ (if (member :beam-total-dose parts) npt-pages 0)
+ (if (or (member :line-specs parts)
+ (member :seed-specs parts)) 1 0)
+ (if (member :source-dose parts) 1 0)
+ ))
+ (page-no 1))
+ (with-open-file (chart *chart-file*
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (chart-header chart cur-pat pln total-pages)
+ (if (member :combined parts)
+ (setq page-no (combined-doses chart cur-pat pln n-pts-page1
+ page-no total-pages))
+ (progn
+ (ps:finish-page chart (< page-no total-pages))
+ (incf page-no)))
+ (when (member :beam-specs parts)
+ (setq page-no (beam-specs chart cur-pat pln page-no total-pages
+ 'photon-neutron))
+ (setq page-no (beam-specs chart cur-pat pln page-no total-pages
+ 'electron)))
+ (when (member :beam-frac-dose parts)
+ (setq page-no (dose-per-beam
+ chart cur-pat pln page-no total-pages t)))
+ (when (member :beam-total-dose parts)
+ (setq page-no (dose-per-beam
+ chart cur-pat pln page-no total-pages nil)))
+ (when (or (member :line-specs parts)
+ (member :seed-specs parts))
+ (brief-header chart cur-pat pln page-no total-pages)
+ (if (member :line-specs parts)
+ (line-specs chart (coll:elements (line-sources pln))))
+ (if (member :seed-specs parts)
+ (seed-specs chart (coll:elements (seeds pln))))
+ (ps:finish-page chart (< page-no total-pages))
+ (incf page-no))
+ (when (member :source-dose parts)
+ (dose-per-source chart cur-pat pln page-no total-pages)))))
+
+;;;----------------------------------------------------
+
+(defun chart-panel (chart-type cur-pat pln &rest pars)
+
+ "chart-panel chart-type cur-pat pln &rest pars
+
+Generates a chart of type chart-type from information specified by the
+user through a dialog box, unless the user presses the cancel button
+in the dialog box. The chart file is written and if the user did not
+specify File only, it is spooled to the user selected printer, to
+produce the user specified number of copies."
+
+ (sl:push-event-level)
+ (let* ((num-copies 1)
+ (printer (first *postscript-printers*))
+ (printer-menu (sl:make-radio-menu *postscript-printers* :mapped nil))
+ (delta-y (+ 10 (max (sl:height printer-menu) 100)
+ 10))
+ (cbox (sl:make-frame (+ 10 (sl:width printer-menu)
+ 10 150 10)
+ (+ delta-y 30 10 30 10)
+ :title "Chart Parameters"))
+ (win (sl:window cbox))
+ (cpy-tln (sl:make-textline 150 30 :parent win
+ :label "Copies: "
+ :info (write-to-string num-copies)
+ :numeric t
+ :lower-limit 1
+ :upper-limit 9
+ :ulc-x (+ 10 (sl:width printer-menu)
+ 10)
+ :ulc-y delta-y))
+ (accept-x (round (/ (- (sl:width cbox) 170) 2)))
+ (accept-btn (sl:make-exit-button 80 30 :label "Accept"
+ :parent win
+ :ulc-x accept-x
+ :ulc-y (+ delta-y 40)
+ :bg-color 'sl:green))
+ (cancel-btn (sl:make-exit-button 80 30 :label "Cancel"
+ :parent win
+ :ulc-x (+ accept-x 90)
+ :ulc-y (+ delta-y 40)))
+ parts-codes part-menu print-list) ;; only for main chart
+ (clx:reparent-window (sl:window printer-menu) win 10 10)
+ (clx:map-window (sl:window printer-menu))
+ (clx:map-subwindows (sl:window printer-menu))
+ (sl:select-button 0 printer-menu)
+ (when (eql chart-type 'main)
+ (let ((pts (coll:elements (points cur-pat)))
+ (bms (coll:elements (beams pln)))
+ (lines (coll:elements (line-sources pln)))
+ (seeds (coll:elements (seeds pln)))
+ part-strings)
+ (when seeds
+ (push :seed-specs parts-codes)
+ (push "Seed specs" part-strings))
+ (when lines
+ (push :source-dose parts-codes)
+ (push "Dose per source" part-strings)
+ (push :line-specs parts-codes)
+ (push "Line sources" part-strings))
+ (when (and bms pts)
+ (push :beam-total-dose parts-codes)
+ (push "Total doses" part-strings)
+ (push :beam-frac-dose parts-codes)
+ (push "Doses per treat." part-strings))
+ (when bms
+ (push :beam-specs parts-codes)
+ (push "Beam settings" part-strings))
+ (when (and pts (or bms lines seeds))
+ (push :combined parts-codes)
+ (push "Combined doses" part-strings))
+ (setq part-menu (sl:make-menu part-strings :parent win
+ :ulc-x (+ 10 (sl:width printer-menu)
+ 10)
+ :ulc-y 10)))
+ (ev:add-notify cbox (sl:selected part-menu)
+ #'(lambda (bx mn num)
+ (declare (ignore bx mn))
+ (pushnew (nth num parts-codes) print-list)))
+ (ev:add-notify cbox (sl:deselected part-menu)
+ #'(lambda (bx mn num)
+ (declare (ignore bx mn))
+ (setf print-list
+ (remove (nth num parts-codes) print-list))))
+ (dotimes (i (length parts-codes))
+ (sl:select-button i part-menu)))
+ (ev:add-notify cbox (sl:new-info cpy-tln)
+ #'(lambda (cbox tl info)
+ (declare (ignore cbox tl))
+ (setq num-copies
+ (round (read-from-string info)))))
+ (ev:add-notify cbox (sl:selected printer-menu)
+ #'(lambda (cbox m item)
+ (declare (ignore cbox m))
+ (setq printer (nth item *postscript-printers*))))
+ (ev:add-notify cbox (sl:button-on accept-btn)
+ #'(lambda (cbox bt)
+ (declare (ignore cbox bt))
+ (case chart-type
+ (main (main-chart print-list cur-pat pln))
+ (neutron (apply #'make-neutron-chart cur-pat pars))
+ ;; new dicom based on neutron but different
+ (dicom (apply #'make-dicom-chart cur-pat pars))
+ (leaf (apply #'make-leaf-chart cur-pat pln pars)))
+ (unless (string-equal "File only" printer)
+ (dotimes (i num-copies)
+ (run-subprocess (format nil "~a~a ~a"
+ *spooler-command*
+ printer *chart-file*))))))
+ (sl:process-events)
+ (when (eql chart-type 'main)
+ (sl:destroy part-menu))
+ (sl:destroy printer-menu)
+ (sl:destroy cpy-tln)
+ (sl:destroy accept-btn)
+ (sl:destroy cancel-btn)
+ (sl:destroy cbox)
+ (sl:pop-event-level)))
+
+;;;----------------------------------------------------
+
+(defun write-leaf-settings (chart leaf-settings coll-info top)
+
+ (let* ((leaf-data (mapcar #'(lambda (leaf-loc leaf-pair)
+ (list (first leaf-loc)
+ (* (inf-leaf-scale coll-info)
+ (first leaf-pair))
+ (second leaf-pair)
+ (second leaf-loc)))
+ (leaf-pair-map coll-info) leaf-settings))
+ (nleaves (length leaf-data))
+ (halfway (1- (truncate nleaves 2)))) ; 1- because dotimes is 0-based
+ (declare (type fixnum nleaves))
+ (ps:set-position chart 1.0 top)
+ (ps:indent chart 1.0)
+ (ps:put-text chart (format nil "~A" (col-headings coll-info)))
+ (dotimes (ileaf nleaves)
+ (let ((lf (nth ileaf leaf-data)))
+ (ps:put-text chart
+ (format nil
+ "~2D ~5,1F ~5,1F ~2D"
+ (first lf) (second lf) (third lf) (fourth lf)))
+ (if (= ileaf halfway) ;; mark isocenter
+ (ps:put-text chart (format nil "~23 at A" "+")))))))
+
+;;;----------------------------------------------------
+
+(defun make-leaf-chart (cur-pat pln beam)
+
+ "make-leaf-chart cur-pat pln beam
+
+Makes a leaf chart for MLC beam."
+
+ (with-open-file (chart *chart-file*
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (ps:initialize chart 0.5 0.5 7.5 10.0)
+ (ps:set-font chart "Courier" 12)
+ (ps:indent chart 0.1)
+ (brief-header chart cur-pat pln 1 1)
+ (ps:put-text
+ chart
+ "-------------------- LEAF COLLIMATOR SETTINGS --------------------")
+ (ps:put-text chart "")
+ (ps:put-text chart (format nil "For: ~A" (name beam)))
+ (write-leaf-settings chart
+ (compute-mlc (collimator-angle beam)
+ (get-mlc-vertices beam)
+ (edge-list
+ (collimator-info (machine beam))))
+ (collimator-info (machine beam))
+ 2.0)
+ (ps:finish-page chart)))
+
+;;;----------------------------------------------------
+
+(defun make-neutron-chart (cur-pat beam-pairs date)
+
+ "make-neutron-chart cur-pat beam-pairs date
+
+Writes a neutron chart for the specified patient, for each
+original-beam/current-beam pair, and date."
+
+ (with-open-file (chart *chart-file*
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (ps:initialize chart 0.5 0.5 7.5 10.0)
+ (ps:set-font chart "Courier" 12)
+ (ps:indent chart 0.1)
+ (dolist (bms beam-pairs)
+ (let* ((orig-bm (first bms))
+ (curr-bm (second bms))
+ (pln (third bms))
+ (o-val nil)
+ (c-val nil)
+ (mach (machine orig-bm)))
+ (brief-header chart cur-pat pln 1 1)
+ (ps:put-text
+ chart
+ "-------------------- NEUTRON BEAM TRANSFER --------------------")
+ (ps:put-text chart (format nil "BEAM: ~a" (name curr-bm)))
+ (ps:put-text chart (format nil "XFER DATE: ~a" date))
+ (ps:put-text chart "")
+ (ps:put-text chart
+ " Setting Planned Transfered Changed?")
+ (ps:put-text chart "")
+ ;; print gantry starting angle
+ (setq o-val (scale-angle (gantry-angle orig-bm)
+ (gantry-scale mach)
+ (gantry-offset mach)))
+ (setq c-val (scale-angle (gantry-angle curr-bm)
+ (gantry-scale mach)
+ (gantry-offset mach)))
+ (ps:put-text
+ chart
+ (format nil "~15a: ~6,1F ~5a ~6,1F ~5a ~5a"
+ "Gantry Start"
+ (first o-val) (second o-val)
+ (first c-val) (second c-val)
+ (if (poly:nearly-equal (gantry-angle orig-bm)
+ (gantry-angle curr-bm))
+ " "
+ "*****")))
+ ;; print gantry stopping angle
+ (setq o-val (scale-angle
+ (+ (arc-size orig-bm) (gantry-angle orig-bm))
+ (gantry-scale mach) (gantry-offset mach)))
+ (setq c-val (scale-angle
+ (+ (arc-size curr-bm) (gantry-angle curr-bm))
+ (gantry-scale mach) (gantry-offset mach)))
+ (ps:put-text
+ chart (format nil "~15a: ~6,1F ~5a ~6,1F ~5a ~5a"
+ "Gantry Stop"
+ (first o-val) (second o-val)
+ (first c-val) (second c-val)
+ (if (poly:nearly-equal
+ (+ (arc-size orig-bm) (gantry-angle orig-bm))
+ (+ (arc-size curr-bm) (gantry-angle curr-bm)))
+ " "
+ "*****")))
+ ;; print collimator angle
+ (setq o-val (scale-angle (collimator-angle orig-bm)
+ (collimator-scale mach)
+ (collimator-offset mach)
+ (collimator-negative-flag mach)
+ (collimator-lower-limit mach)
+ (collimator-upper-limit mach)))
+ (setq c-val (scale-angle (collimator-angle curr-bm)
+ (collimator-scale mach)
+ (collimator-offset mach)
+ (collimator-negative-flag mach)
+ (collimator-lower-limit mach)
+ (collimator-upper-limit mach)))
+ (ps:put-text
+ chart
+ (format nil "~15a: ~6,1F ~5a ~6,1F ~5a ~5a"
+ "Collim Angle"
+ (first o-val) (second o-val)
+ (first c-val) (second c-val)
+ (if (poly:nearly-equal (collimator-angle orig-bm)
+ (collimator-angle curr-bm))
+ " "
+ "*****")))
+ ;; print turntable angle
+ (setq o-val (scale-angle (couch-angle orig-bm)
+ (turntable-scale mach)
+ (turntable-offset mach)
+ (turntable-negative-flag mach)
+ (turntable-lower-limit mach)
+ (turntable-upper-limit mach)))
+ (setq c-val (scale-angle (couch-angle curr-bm)
+ (turntable-scale mach)
+ (turntable-offset mach)
+ (turntable-negative-flag mach)
+ (turntable-lower-limit mach)
+ (turntable-upper-limit mach)))
+ (ps:put-text
+ chart
+ (format nil "~15a: ~6,1F ~5a ~6,1F ~5a ~5a"
+ "Couch Angle"
+ (first o-val) (second o-val)
+ (first c-val) (second c-val)
+ (if (poly:nearly-equal (couch-angle orig-bm)
+ (couch-angle curr-bm))
+ " "
+ "*****")))
+ ;; print num fractions
+ (ps:put-text
+ chart
+ (format nil "~15a: ~5 at a ~5 at a ~5a"
+ "Fractions"
+ (n-treatments orig-bm) (n-treatments curr-bm)
+ (if (= (n-treatments orig-bm) (n-treatments curr-bm))
+ " "
+ "*****")))
+ ;; print MU/fraction
+ (let ((mu-orig-per-frac (round (/ (the single-float
+ (monitor-units orig-bm))
+ (the fixnum
+ (n-treatments orig-bm)))))
+ (mu-curr-per-frac (round (/ (the single-float
+ (monitor-units curr-bm))
+ (the fixnum
+ (n-treatments curr-bm))))))
+ (ps:put-text
+ chart
+ (format nil "~15a: ~5 at a ~5a ~5 at a ~7a ~5a"
+ "Mu/Fraction"
+ mu-orig-per-frac "Mu/F"
+ mu-curr-per-frac "Mu/F"
+ (if (= mu-orig-per-frac mu-curr-per-frac)
+ " "
+ "*****"))))
+ ;; print out the wedge selection and rotation discrepancies
+ (let* ((wdg-orig (wedge orig-bm))
+ (wdg-curr (wedge curr-bm))
+ (id-orig (id wdg-orig))
+ (id-curr (id wdg-curr))
+ (rot-orig (rotation wdg-orig))
+ (rot-curr (rotation wdg-curr)))
+ (ps:put-text
+ chart
+ (format nil "~15a: ~13a ~12a ~5a"
+ "Wedge Sel"
+ (wedge-label id-orig (machine orig-bm))
+ (wedge-label id-curr (machine curr-bm))
+ (if (= id-orig id-curr) " "
+ "*****")))
+ (setq o-val (if (zerop id-orig) '("NONE" "")
+ (scale-angle rot-orig
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach))))
+ (setq c-val (if (zerop id-curr) '("NONE" "")
+ (scale-angle rot-curr
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach))))
+ (ps:put-text
+ chart
+ (format nil "~15a: ~6,1F ~5a ~6,1F ~5a ~5a"
+ "Wedge Rot"
+ (first o-val) (second o-val)
+ (first c-val) (second c-val)
+ (if (or (= 0 id-orig id-curr)
+ ;; eql can compare nil to 90.0, eg.
+ (eql rot-orig rot-curr))
+ " "
+ "*****"))))
+ ;; print out the leaf discrepancies - sort by increasing leaf number
+ ;; to make more readable on chart.
+ (ps:put-text chart "")
+ (do* ((leaf-names (leaf-pair-map (collimator-info mach)))
+ (orig-vals (leaf-settings (collimator orig-bm)))
+ (curr-vals (leaf-settings (collimator curr-bm)))
+ (triples (mapcar #'list
+ (reduce #'append leaf-names)
+ (reduce #'append orig-vals)
+ (reduce #'append curr-vals)))
+ (sorted (sort (copy-tree triples) #'< :key #'first)
+ (rest sorted))
+ (triple (first sorted) (first sorted)))
+ ((null sorted))
+ (unless (poly:nearly-equal (second triple) (third triple))
+ (ps:put-text chart
+ (format nil "Leaf ~10a: ~6,1F ~5a ~6,1F ~5a ~5a"
+ (first triple) (second triple) "cm "
+ (third triple) "cm " "*****"))))
+ ;; write out all the leaf settings
+ (write-leaf-settings chart
+ (leaf-settings (collimator curr-bm))
+ (collimator-info (machine curr-bm))
+ 4.0)
+ (ps:finish-page chart t)))))
+
+;;;----------------------------------------------------
+;;; DICOM chart functions written by Jon Jacky
+;;;----------------------------------------------------
+;;; Like brief-header in charts.cl but compressed and rearranged
+;;; to better fit page and match info on Eletka RTD screens
+;;; also add date parameter, also note beam number is page number
+;;; add col2-horiz parameter.
+
+(defun dicom-header (chart cur-pat pln date label pgnum total-pgs col2-horiz
+ dicom-pat-id &optional (top-margin 0.0))
+
+ "dicom-header chart cur-pat pln pgnum total-pgs &optional (top-margin 0.0)
+
+writes the brief header that appears at the top (or down an amount of
+top-margin) on every chart page."
+
+ (declare (type single-float top-margin))
+ (ps:draw-rectangle chart 0.5 0.5 7.5 10.0)
+ (ps:set-position chart 0.1 (+ top-margin 0.2))
+ (let ((user (getenv "USER")))
+ (ps:put-text chart (format nil "~A on ~A by ~A" label date user)))
+ (ps:set-position chart 6.0 (+ top-margin 0.2))
+ (ps:put-text chart (format nil "PAGE: ~A of ~A" pgnum total-pgs))
+ (ps:set-position chart 0.1 (+ top-margin 0.5))
+ (ps:indent chart 0.1)
+ (ps:put-text chart (format nil "PAT. ID: ~A" dicom-pat-id))
+ (ps:put-text chart (format nil "PATIENT: ~A" (name cur-pat)))
+ (when pln
+ (ps:put-text chart (format nil "PLAN: ~A" (name pln))))
+ (ps:set-position chart col2-horiz (+ top-margin 0.5)) ; start a new column
+ (ps:indent chart col2-horiz) ; set left margin for subsequent lines in column
+ (ps:put-text chart (format nil "HOSPITAL NUMBER : ~A"
+ (hospital-id cur-pat)))
+ (ps:put-text chart (format nil "PRISM PATIENT, CASE: ~A, ~A"
+ (patient-id cur-pat) (case-id cur-pat)))
+ (when pln
+ (ps:put-text chart (format nil "PLAN DATE: ~A" (time-stamp pln))))
+ (ps:set-position chart 0.1 (+ top-margin 1.0625))
+ (ps:indent chart 0.1)
+ (ps:put-text
+ chart
+ "-----------------------------------------------------------------------")
+
+ (ps:put-text chart "")) ; put "cursor" back at indent
+
+;;;----------------------------------------------------
+
+(defun write-dicom-leaf-settings (chart copy-coll curr-coll coll-info horiz)
+ ;; Only write "*" next to leaves where differences change field shape
+ ;; not at leaves moved to make flagpole or open under jaw edge
+ (let* ((end-tol 0.3) ; if edge is 3mm different,dosimetrist prob'ly intended
+ (print-tol 0.01) ; print * on chart if they differ at all
+ (copy-leaves (leaf-settings copy-coll))
+ (curr-leaves (leaf-settings curr-coll))
+ (shapes (shape-diff copy-coll curr-coll end-tol))
+ (nleaves (length shapes)) ; should be 40 for SL
+ (halfway (1- (truncate nleaves 2)))) ; 1- because dotimes is 0-based
+ (declare (type single-float end-tol print-tol)
+ (type fixnum nleaves))
+ (ps:indent chart horiz) ; so subsequent lines line up
+ (ps:put-text chart (format nil ; hard code captions to align with data
+ "Y2 Transf Planned Planned Transf Y1"))
+ (dotimes (ileaf nleaves)
+ (let ((lf (nth ileaf shapes))
+ (copy-pair (nth ileaf copy-leaves))
+ (curr-pair (nth ileaf curr-leaves)))
+ (ps:put-text
+ chart
+ (format nil
+ "~2D ~A ~6,2F ~6,2F ~6,2F ~6,2F ~A"
+ (first (nth ileaf (leaf-pair-map coll-info)))
+ (cond ((or (and (lpair-open-o lf)
+ (not (lpair-open lf)))
+ (and (not (lpair-open-o lf))
+ (lpair-open lf))
+ (and (lpair-open-o lf)
+ (lpair-open lf)
+ (> (abs (- (lpair-xl-o lf)
+ (lpair-xl lf)))
+ print-tol)))
+ "*") ; shape changed at leaf
+ ((lpair-open lf) ".") ; open and not changed
+ (t " ")) ; closed and not changed
+ (* (the single-float (inf-leaf-scale coll-info))
+ (the single-float (first curr-pair)))
+ (* (the single-float (inf-leaf-scale coll-info))
+ (the single-float (first copy-pair)))
+ (second copy-pair)
+ (second curr-pair)
+ (cond ((or (and (lpair-open-o lf)
+ (not (lpair-open lf)))
+ (and (not (lpair-open-o lf))
+ (lpair-open lf))
+ (and (lpair-open-o lf)
+ (lpair-open lf)
+ (> (abs (- (lpair-xr-o lf)
+ (lpair-xr lf)))
+ print-tol)))
+ "*")
+ ((lpair-open lf) ".")
+ (t " "))))
+ (if (= ileaf halfway) ;; mark isocenter
+ (ps:put-text chart (format nil " +")))))))
+
+;;;----------------------------------------------------
+;;; Based on make-neutron-chart, but quite a bit different now.
+
+(defun make-dicom-chart (cur-pat p-bm-info date label dicom-pat-id)
+
+ "make-dicom-chart cur-pat p-bm-info date label
+
+Writes a chart for CUR-PAT with all the Prism beams and segments in
+P-BM-INFO [a list of segments in the Dicom beams]."
+
+ ;; P-BM-INFO is a list, in forward order, each entry being:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <Prism-Beam-Object> )
+ ;; with one entry for each segment. Note that the list contains all Prism
+ ;; beams - that is, all segments for all Dicom beams. They are grouped
+ ;; into Dicom beams in order - all segments for one Dicom beam followed by
+ ;; all segments for the next, and so forth.
+ ;;
+ ;; OrigBmInst is uncopied original Prism beam.
+ ;; CopyBmInst and CurrBmInst are both copied beams so that changes
+ ;; to their collimators will not side-effect real Prism beams.
+
+ (with-open-file (chart *chart-file*
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (ps:initialize chart 0.5 0.5 7.5 10.0)
+ (ps:set-font chart "Courier" 12)
+ (ps:indent chart 0.1)
+ (do ((p-bms p-bm-info (cdr p-bms))
+ (total-pages (length p-bm-info))
+ (col2-horiz 3.75) (beam-vert 1.25) (warn-vert 9.0)
+ (segnum 0) (totsegs 0) (n-warn 5) (pgnum 0)
+ (curr-pbi) ;Current [copied/mutated] Prism beam instance.
+ (copy-coll) ;Collimator of Copied Beam
+ (curr-coll) ;Collimator of Current Beam
+ (pln) ;Current Plan
+ (p-bm-obj) ;Prism-Beam structure instance
+ (seg-type :static) ; :Static, :Dynamic, or :Static
+ (p-bmdata) (c-val) (mach))
+ ((null p-bms))
+ (declare (type list p-bms p-bmdata c-val)
+ (type (member :static :dynamic :segment) seg-type)
+ (type single-float col2-horiz beam-vert warn-vert)
+ (type fixnum total-pages n-warn pgnum segnum totsegs))
+ (setq p-bmdata (car p-bms)
+ curr-pbi (third p-bmdata) ;Current [copied/mutated] Prism beam.
+ pln (fourth p-bmdata) ;Current Plan
+ p-bm-obj (fifth p-bmdata) ;Prism-Beam [segment] instance
+ copy-coll (collimator (second p-bmdata)) ;Collimator of Copied Beam
+ curr-coll (collimator curr-pbi) ;Collimator of Current Beam
+ seg-type (pr-beam-segtype p-bm-obj) ;Prism beam type
+ mach (machine (first p-bmdata))) ;Orig [uncopied] beam's machine
+ (setq pgnum (the fixnum (1+ pgnum)))
+ (dicom-header chart cur-pat pln date label pgnum
+ total-pages col2-horiz dicom-pat-id)
+ (ps:set-position chart 0.1 beam-vert)
+ (ps:put-text chart (format nil "LINAC: ~A" (car (ident mach))))
+ (ps:put-text chart (format nil "BEAM NAME: ~D. ~A"
+ (pr-beam-dbeam-num p-bm-obj)
+ (name curr-pbi)))
+ (ps:put-text
+ chart
+ (cond ((eq seg-type :static) "")
+ ((eq seg-type :dynamic)
+ (setq segnum 1)
+ (do ((pp (cdr p-bms) (cdr pp))
+ (cnt 1 (the fixnum (1+ cnt))))
+ ((null pp)
+ (setq totsegs cnt))
+ (unless (eq (pr-beam-segtype (fifth (car pp))) :segment)
+ (setq totsegs cnt)
+ (return)))
+ (format nil "SEGMENT: 1 of ~D" totsegs))
+ ((eq seg-type :segment)
+ (format nil "SEGMENT: ~D of ~D, from Prism beam ~A"
+ (setq segnum (the fixnum (1+ segnum)))
+ totsegs
+ (name curr-pbi)))))
+
+ ;; Items in same order as Geometry tab on Elekta RTD beam panel.
+ (ps:put-text chart "")
+ (ps:put-text chart "GEOMETRY:")
+ (ps:put-text chart "")
+ (setq c-val (scale-angle (gantry-angle curr-pbi)
+ (gantry-scale mach)
+ (gantry-offset mach)))
+ (ps:put-text chart (format nil "Gantry Angle: ~6,1F ~5A"
+ (first c-val) (second c-val)))
+ (setq c-val (scale-angle (collimator-angle curr-pbi)
+ (collimator-scale mach)
+ (collimator-offset mach)
+ (collimator-negative-flag mach)
+ (collimator-lower-limit mach)
+ (collimator-upper-limit mach)))
+ (ps:put-text chart (format nil "Diaphragm rotation: ~6,1F ~5A"
+ (first c-val) (second c-val)))
+ (ps:put-text chart "")
+
+ ;; Elekta X1,X2 Y1,Y2 are Prism/DICOM y2,-y1 x2,-x1 respectively.
+ (ps:put-text chart (format nil "Diaphragm X1: ~7,2F cm"
+ (y2 curr-coll)))
+ (ps:put-text chart (format nil "Diaphragm X2: ~7,2F cm"
+ (- (y1 curr-coll))))
+ (ps:put-text chart (format nil "Diaphragm Y1: ~7,2F cm"
+ (x2 curr-coll)))
+ (ps:put-text chart (format nil "Diaphragm Y2: ~7,2F cm"
+ (- (x1 curr-coll))))
+ (ps:put-text chart "")
+
+ (setq c-val (scale-angle (couch-angle curr-pbi)
+ (turntable-scale mach)
+ (turntable-offset mach)
+ (turntable-negative-flag mach)
+ (turntable-lower-limit mach)
+ (turntable-upper-limit mach)))
+ (ps:put-text chart (format nil "Isocenter rotation: ~6,1F ~5A"
+ (first c-val) (second c-val)))
+
+ ;; Sort of like the Radiation tab on the Elekta RTD beam panel.
+ (ps:put-text chart "")
+ (ps:put-text chart "")
+ (ps:put-text chart "RADIATION:")
+ (ps:put-text chart "")
+ (ps:put-text chart (format nil "Radiation type: ~A" (particle mach)))
+ (ps:put-text chart (format nil "Energy: ~A MV"
+ (energy mach)))
+ (ps:put-text chart "")
+
+ (when (eq seg-type :static)
+ (let ((mu-val (monitor-units curr-pbi))
+ (n-frac (n-treatments curr-pbi)))
+ (declare (type single-float mu-val)
+ (type fixnum n-frac))
+ (ps:put-text
+ chart (format nil "Total MU planned: ~6,1F MU" mu-val))
+ (ps:put-text chart (format nil "Fractions: ~2D" n-frac))
+ ;; Printed Fractions * printed Daily MU may not equal Total MU.
+ (ps:put-text chart (format nil "Daily MU: ~3D MU/F"
+ (round (/ mu-val n-frac))))
+ (ps:put-text chart "")))
+
+ (when (eq seg-type :dynamic)
+ (let ((tot-mu (pr-beam-tot-mu p-bm-obj))
+ (n-frac (n-treatments curr-pbi)))
+ (declare (type single-float tot-mu)
+ (type fixnum n-frac))
+ (ps:put-text
+ chart (format nil "Total MU, all segs: ~6,1F MU" tot-mu))
+ (ps:put-text chart (format nil "Fractions: ~2D" n-frac))
+ (ps:put-text chart (format nil "Daily MU, all segs: ~3D MU/F"
+ (round (/ tot-mu n-frac))))
+ (ps:put-text chart "")))
+
+ (when (or (eq seg-type :dynamic)
+ (eq seg-type :segment))
+ (let ((tot-mu (pr-beam-tot-mu p-bm-obj))
+ (seg-mu (pr-beam-seg-mu p-bm-obj))
+ (seg-cum (pr-beam-cum-mu-inc p-bm-obj))
+ (n-frac (n-treatments curr-pbi)))
+ (declare (type single-float tot-mu seg-mu seg-cum)
+ (type fixnum n-frac))
+ (ps:put-text chart
+ (format nil "Total MU, this seg: ~6,1F (~5,1F%)"
+ seg-mu
+ (* 100.0 (/ seg-mu tot-mu))))
+ (ps:put-text chart
+ (format nil "Daily MU, this seg: ~3D MU/F"
+ (round (/ seg-mu n-frac))))
+ (ps:put-text chart
+ (format nil "Cumu. MU, this seg: ~6,1F (~5,1F%)"
+ seg-cum
+ (* 100.0 (/ seg-cum tot-mu))))
+ (ps:put-text chart
+ (format nil "DayCu MU, this seg: ~3D MU/F"
+ (round (/ seg-cum n-frac))))
+ (ps:put-text chart "")))
+
+ ;; Special cases for internal, external wedges, external blocks
+ (let* ((wedge-id (id (wedge curr-pbi)))
+ (wedge-name (wedge-label wedge-id mach))
+ (wedge-fixed (string-equal wedge-name "Fixed Wedge"))
+ (wedge-ext (and (not (zerop wedge-id)) (not wedge-fixed)))
+ (blocks-ext (if (coll:elements (blocks curr-pbi)) t nil))
+ ;; shadow tray holds any external wedge or external blocks
+ (shadow-tray
+ (cond (wedge-ext
+ (accessory-code
+ (find wedge-id (wedges mach) :key #'ID)))
+ (blocks-ext (tray-accessory-code mach))
+ (t "NONE"))))
+ ;; Internal wedge is either in or out, nothing else to specify.
+ (ps:put-text chart
+ (format nil "Internal wedge pos: ~A"
+ (if (string-equal wedge-name "Fixed Wedge")
+ "IN" "OUT")))
+
+ ;; May have ext wedge or ext blocks but not both - only one tray!
+ (cond (wedge-ext
+ (ps:put-text
+ chart (format nil "External wedge: ~A" wedge-name))
+ (setq c-val (scale-angle (rotation (wedge curr-pbi))
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach)))
+ (ps:put-text
+ chart
+ (format nil "Ext. wedge rot: ~6,1F ~5A"
+ (first c-val) (second c-val))))
+ (blocks-ext
+ (ps:put-text chart "")
+ (ps:put-text chart "External blocks"))
+ (t (ps:put-text chart "") ; no ext wedges or blocks - make space
+ (ps:put-text chart "")))
+ (ps:put-text chart "")
+
+ (ps:put-text chart (format nil "Shadow Tray: ~A" shadow-tray)))
+
+ ;; Applicator, fitment are for electron beams only.
+ (ps:put-text chart "Applicator: NONE")
+ (ps:put-text chart "Fitment Number: NONE")
+
+ ;; Make bottom of DIAPHRAGMS section line up with bottom of leaves.
+ (dotimes (i (case seg-type
+ (:static 6)
+ (:segment 5)
+ (:dynamic 1)))
+ (ps:put-text chart ""))
+
+ (ps:put-text chart "DIAPHRAGMS:")
+ (ps:put-text chart "")
+ (ps:put-text chart " Planned Transferred")
+ (let ((print-tol 0.01)) ; Print * on chart if they differ at all.
+ (put-collim-line chart "X1" (y2 copy-coll) (y2 curr-coll) print-tol)
+ (put-collim-line chart "X2"
+ (- (y1 copy-coll)) (- (y1 curr-coll)) print-tol)
+ (put-collim-line chart "Y1" (x2 copy-coll) (x2 curr-coll) print-tol)
+ (put-collim-line chart "Y2"
+ (- (x1 copy-coll)) (- (x1 curr-coll)) print-tol))
+
+ ;; Start a second column.
+ (ps:set-position chart col2-horiz beam-vert)
+ (ps:indent chart col2-horiz) ;Set left margin for subsequent lines.
+ (ps:put-text chart (format nil "PRISM MACHINE: ~A" (name mach)))
+
+ ;; Write out all the leaf settings.
+ (ps:put-text chart "") ; Align with GEOMETRY.
+ (ps:put-text chart "")
+ (ps:put-text chart "") ; one more to match SEGMENTS line
+ (write-dicom-leaf-settings chart copy-coll curr-coll
+ *sl-collim-info* col2-horiz)
+
+ ;; Write warnings at bottom of page.
+ (let ((wl (collim-warnings copy-coll curr-coll)))
+ (if wl (let ((wll (if (<= (length wl) n-warn)
+ wl
+ (append
+ (subseq wl 0 (- n-warn 1))
+ '("(There were more warnings ...)")))))
+ (ps:set-position chart 0.1 warn-vert)
+ (ps:indent chart 0.1)
+ (dolist (w wll) (ps:put-text chart w)))))
+
+ (ps:finish-page chart t))))
+
+;;;----------------------------------------------------
+
+(defun put-collim-line (chart label copy-coll-data curr-coll-data tol)
+ (declare (type single-float copy-coll-data curr-coll-data tol))
+ (ps:put-text chart
+ (format nil "~A: ~6,2F ~6,2F ~A"
+ label copy-coll-data curr-coll-data
+ (if (< (abs (- copy-coll-data curr-coll-data)) tol)
+ " "
+ "*"))))
+
+;;;----------------------------------------------------
+;;; End.
diff --git a/prism/src/clipper.cl b/prism/src/clipper.cl
new file mode 100644
index 0000000..4832164
--- /dev/null
+++ b/prism/src/clipper.cl
@@ -0,0 +1,900 @@
+;;;
+;;; clipper
+;;;
+;;; 22-Jan-1998 BobGian move all polygon clipping code here from file
+;;; "pathlength.cl". Add declarations for more speed (inlining). Use FLET
+;;; to declare local functions avoiding necessity of passing large arg lists.
+;;; 09-Mar-1998 BobGian minor update with new version of dose-calc code.
+;;; 22-May-1998 BobGian:
+;;; - Convert throughout to pass flonum args via Arg-Vec
+;;; (as in COMPUTE-BEAM-DOSE and PATHLENGTH).
+;;; - convert CNODE from DEFSTRUCT to array with named slots.
+;;; - INTERPOLATE-CROSSING: function -> macro (inlined).
+;;; - GRAZER?, PUSHNODE, SINGLE-CROSSPOINT, DUAL-CROSSPOINTS: convert
+;;; internal (FLET) definitions to ordinary function using Arg-Vec
+;;; to pass args are return values(s).
+;;; 20-Jul-1998 BobGian optimize a few more array declarations and accessors.
+;;; 03-Feb-2000 BobGian cosmetic fixes (case regularization).
+;;; 08-Feb-2000 BobGian more cosmetic cleanup.
+;;; 02-Mar-2000 BobGian add declarations to CLIPBLK-CONTOURS.
+;;; 02-Nov-2000 BobGian function name and argument order changes to make
+;;; consistent with new version of dose-calc used in electron code.
+;;; 30-May-2001 BobGian:
+;;; Wrap generic arithmetic with THE-declared types.
+;;; Move symbols used only as tags from Prism to Keyword package.
+;;; MOD -> LOGAND in order to enable inlining.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+;;; Polygon-Clipping code. Based loosely on Sutherland-Hodgman algorithm
+;;; [see COMPUTER GRAPHICS, 2nd Ed in C, Foley, van Dam, Feiner, and Hughes,
+;;; pp. 124-127 and 924-937]. There are also comments in file "beam-dose"
+;;; relating to polygon clipping and its iterface with the rest of the dose
+;;; calculation.
+
+(defmacro interpolate-crossing (ic-1 ic-2 bc-1 bound bc-2)
+ ;;
+ ;; Parameters:
+ ;; IC-1 - Interpolated Coordinate, Vertex 1
+ ;; IC-2 - Interpolated Coordinate, Vertex 2
+ ;; BC-1 - Bound Coordinate [one defining boundary], Vertex 1
+ ;; BOUND - Boundary [value of Bound Coordinate]
+ ;; BC-2 - Bound Coordinate [one defining boundary], Vertex 2
+ ;;
+ ;; All args should be compile-time symbols to avoid multiple evaluation.
+ ;; All should be declared SINGLE-FLOAT in calling context.
+ ;;
+ ;; IC can be X or Y coordinate and BC is Y or X coordinate respectively.
+ ;; BOUND is value of BC coordinate at crossing boundary.
+ ;; Either of Vertex 1 or 2 can be "lower" or "upper" vertex, as long as
+ ;; they are consistent between the two.
+ ;;
+ ;; Value returned is the interpolated value of the IC coordinate.
+ ;; Note that BC coordinates need not strictly straddle BOUND - at most
+ ;; one of them can EQUAL BOUND. BOTH CANNOT, or division-by-zero results.
+ ;;
+ `(cond
+ ;;
+ #+ignore
+ ((= (the single-float ,bc-1) (the single-float ,bc-2))
+ ;; Safety - should never occur, but better than crashing machine.
+ (error "INTERPOLATE-CROSSING [1] Zero-length crossing."))
+ ;;
+ ;; Next two cases are to return EXACTLY correct value so testing
+ ;; for vertex equality via border node coordinate equality will
+ ;; work using internal flonum-equality test. Fringe benefit: also
+ ;; speeds up interpolation of rare border node case.
+ ((= (the single-float ,bc-1) (the single-float ,bound))
+ (the single-float ,ic-1))
+ ((= (the single-float ,bc-2) (the single-float ,bound))
+ (the single-float ,ic-2))
+ ;;
+ ;; Usual case of interpolation for portal boundary strict crossing.
+ ;; Due to oddities of flonum arithmetic, we arrange the following
+ ;; calculation in either of two mathematically-equivalent ways
+ ;; [when using REAL numbers] to get the better FLONUM approximation.
+ ;; The idea is to interpolate FROM the point CLOSEST to the boundary.
+ ;; In cases where one point is extremely close to the boundary and
+ ;; the other is "far" away, this results in smaller roundoff error.
+ ;;
+ ((< (the single-float
+ (abs (- (the single-float ,bound) (the single-float ,bc-1))))
+ (the single-float
+ (abs (- (the single-float ,bound) (the single-float ,bc-2)))))
+ (+ (/ (* (- (the single-float ,ic-2) (the single-float ,ic-1))
+ (- (the single-float ,bound) (the single-float ,bc-1)))
+ (- (the single-float ,bc-2) (the single-float ,bc-1)))
+ (the single-float ,ic-1)))
+ ;;
+ (t (+ (/ (* (- (the single-float ,ic-1) (the single-float ,ic-2))
+ (- (the single-float ,bound) (the single-float ,bc-2)))
+ (- (the single-float ,bc-1) (the single-float ,bc-2)))
+ (the single-float ,ic-2)))))
+
+;;;-------------------------------------------------------------
+
+(defun clip-blocks (vlist arg-vec &aux (chain nil) (enterlist '()))
+ ;;
+ ;; CHAIN is Defstruct-chain of CNODEs representing subcontour being built.
+ ;; ENTERLIST is list of ENTER nodes not yet absorbed into subcontours.
+ ;;
+ ;; Takes a list VLIST of vertices [2-lists, X/Y coords in collimator system,
+ ;; at isocenter, traversed in either direction] and portal coordinates
+ ;; [XCI-, XCI+, YCI-, and YCI+ as single-floats]. Returns LIST of clipped
+ ;; subcontours, that is, NIL for none or list of one or more - each as a
+ ;; vertex list traversed in CCW direction.
+ ;;
+ (declare (type list vlist)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec))
+ ;;
+ ;; Setup ... Make sure VLIST is traversed in CLOCKWISE direction.
+ (unless (poly:clockwise-traversal-p vlist)
+ (setq vlist (reverse vlist)))
+ ;;
+ (let ((xci- (aref arg-vec #.Argv-Xci-))
+ (xci+ (aref arg-vec #.Argv-Xci+))
+ (yci- (aref arg-vec #.Argv-Yci-))
+ (yci+ (aref arg-vec #.Argv-Yci+)))
+ ;;
+ (declare (type single-float xci- xci+ yci- yci+))
+ ;;
+ ;; A CNODE represents a contour VERTEX almost isomorphically, except for
+ ;; two aspects. Firstly, a vertex which lies exactly on the portal border,
+ ;; with both line segments extending into the portal interior, might be
+ ;; represented by two nodes. It will if the vertex is the single point
+ ;; of intersection of two subcontours - one node represents the vertex
+ ;; in each of the two subcontours [one as a LEAVE node, other as an ENTER].
+ ;; If the border point is on a single contour, a single node represents it,
+ ;; considered and INSIDE node, and this case is the sole exception that
+ ;; vertices on the border are considered OUTSIDE the portal.
+ ;;
+ ;; Secondly, vertices outside the portal are not represented at all.
+ ;; We represent their order in the vertex sequence via the fact that we
+ ;; allocate all nodes in the same order as we encounter vertices in a
+ ;; clockwise contour traversal.
+ ;;
+ ;; CHAIN points to an arbitrary entry point in the circular chain of
+ ;; nodes representing input contour. PUSHNODE updates CHAIN to the last
+ ;; node allocated.
+ ;;
+ ;; First vertex traversal, to find all points where segments cross
+ ;; portal edges. Note that ON THE BORDER counts as OUTSIDE. Thus
+ ;; a segment counts as crossing in the ENTER direction when it enters
+ ;; the interior from the strict outside or from a border point. Likewise,
+ ;; a segment counts as crossing in the LEAVE direction when it leaves
+ ;; the interior to the strict outside or to a border point. All segments
+ ;; lying strictly along a border count as OUTSIDE. Single exception is
+ ;; described in next comment - case of "interior" vertex grazing border.
+ ;;
+ ;; FWD- means vertex at target end of segment, in direction of traversal.
+ ;; BCK- means vertex at other end, at source end of traversal
+ ;;
+ (let* ((bck-vert (car (last vlist)))
+ (bnx (first bck-vert))
+ (bny (second bck-vert)))
+ ;;
+ (declare (type single-float bnx bny))
+ ;;
+ (do ((fwd-verts vlist (cdr fwd-verts)) ;List of verts - CDRed
+ (fwd-vert) ;Actual Vertex
+ (fx 0.0) (fy 0.0) ;Rotating coords of FWD point
+ (bx bnx fx) ;Rotating X coord of BCK point
+ (by bny fy) ;Rotating Y coord of BCK point
+ (f-inside?) ;FWD point Strictly-Inside?
+ ;;
+ (b-inside?
+ (or (and (< xci- bnx xci+) ;BCK point Strictly-Inside
+ (< yci- bny yci+))
+ ;;
+ ;; Or BCK-VERT is a GRAZER [see fcn GRAZES?]. Must
+ ;; examine BCK-VERT [last vertex in VLIST] and the
+ ;; vertices which come just before it [next-to-last
+ ;; in VLIST] and just after it [first in VLIST].
+ ;;
+ (let ((fn (car vlist)) ;Vertex AFTER BCK-VERT
+ (bbn (car (last (butlast vlist))))) ;One BEFORE
+ (setf (aref arg-vec #.Argv-Bx) (first bbn))
+ (setf (aref arg-vec #.Argv-By) (second bbn))
+ (setf (aref arg-vec #.Argv-Cx) bnx)
+ (setf (aref arg-vec #.Argv-Cy) bny)
+ (setf (aref arg-vec #.Argv-Nx) (first fn))
+ (setf (aref arg-vec #.Argv-Ny) (second fn))
+ (grazer? arg-vec)))
+ f-inside?))
+ ;;
+ ((null fwd-verts))
+ ;;
+ (declare (type (member nil t) f-inside? b-inside?)
+ (type single-float bx by fx fy))
+ ;;
+ (setq fwd-vert (car fwd-verts)
+ fx (first fwd-vert)
+ fy (second fwd-vert)
+ f-inside? (and (< xci- fx xci+)
+ (< yci- fy yci+)))
+ ;;
+ (cond
+ ((or f-inside?
+ ;;
+ ;; Either FWD vertex really is INSIDE, or it is a GRAZER. See
+ ;; function GRAZER? for explanation. If a grazer, we treat it
+ ;; as an INSIDE node. Otherwise we treat it as OUTSIDE,
+ ;; inducing a border crossing, resulting in allocation of two
+ ;; nodes [a LEAVE and an ENTER] with identical coordinates, both
+ ;; representing the same vertex, which is a single point of
+ ;; tangency between two otherwise non-intersecting subcontours.
+ ;;
+ (let ((next (or (second fwd-verts) ;Vertex AFTER current one
+ (car vlist))))
+ ;; FX, FY is current vertex; BX, BY is one just BEFORE it
+ (setf (aref arg-vec #.Argv-Bx) bx)
+ (setf (aref arg-vec #.Argv-By) by)
+ (setf (aref arg-vec #.Argv-Cx) fx)
+ (setf (aref arg-vec #.Argv-Cy) fy)
+ (setf (aref arg-vec #.Argv-Nx) (first next))
+ (setf (aref arg-vec #.Argv-Ny) (second next))
+ (grazer? arg-vec)))
+ ;;
+ ;; Either F-INSIDE? was already true, or we detect special case and
+ ;; treat it so. Must set F-INSIDE? so current node will be treated
+ ;; correctly on next iteration.
+ (setq f-inside? t)
+ ;;
+ (cond (b-inside?
+ ;; FWD inside, BCK inside: push new FWD node.
+ (setf (aref arg-vec #.Argv-Vx) fx)
+ (setf (aref arg-vec #.Argv-Vy) fy)
+ (setq chain (pushnode arg-vec :Inside chain)))
+ ;;
+ ;; FWD inside, BCK outside: push crossing point and FWD node.
+ (t (setf (aref arg-vec #.Argv-Ix) fx)
+ (setf (aref arg-vec #.Argv-Iy) fy)
+ (setf (aref arg-vec #.Argv-Ox) bx)
+ (setf (aref arg-vec #.Argv-Oy) by)
+ (single-cross arg-vec)
+ ;; XCOORD and YCOORD are in slots 0,1 in ARG-VEC,
+ ;; placed there as return values by SINGLE-CROSS.
+ (setq chain (pushnode arg-vec :Enter chain))
+ (push chain enterlist)
+ (setf (aref arg-vec #.Argv-Vx) fx)
+ (setf (aref arg-vec #.Argv-Vy) fy)
+ (setq chain (pushnode arg-vec :Inside chain)))))
+ ;;
+ (b-inside?
+ ;; FWD outside, BCK inside: push LEAVE node at outgoing crossing.
+ (setf (aref arg-vec #.Argv-Ix) bx)
+ (setf (aref arg-vec #.Argv-Iy) by)
+ (setf (aref arg-vec #.Argv-Ox) fx)
+ (setf (aref arg-vec #.Argv-Oy) fy)
+ (single-cross arg-vec)
+ ;; XCOORD and YCOORD are already in slots 0,1 in ARG-VEC,
+ ;; placed there as return values by SINGLE-CROSS.
+ (setq chain (pushnode arg-vec :Leave chain)))
+ ;;
+ ;; Both FWD point and BCK point are OUTSIDE [strict or border].
+ ;; Intersections are possible but not necessary - see if they
+ ;; occur. Note that if both ends are OUTSIDE and no portal
+ ;; intersections occur, we don't PUSHNODE anything.
+ (t (setf (aref arg-vec #.Argv-Ix) bx)
+ (setf (aref arg-vec #.Argv-Iy) by)
+ (setf (aref arg-vec #.Argv-Ox) fx)
+ (setf (aref arg-vec #.Argv-Oy) fy)
+ (let ((crossed? (dual-cross arg-vec)))
+ (let ((xe (aref arg-vec #.Argv-Xe))
+ (ye (aref arg-vec #.Argv-Ye))
+ (xl (aref arg-vec #.Argv-Xl))
+ (yl (aref arg-vec #.Argv-Yl)))
+ (declare (type (member nil t) crossed?)
+ (type single-float xe ye xl yl))
+ (when (and crossed?
+ (not (or (and (= xe xl)
+ (or (= xe xci-)
+ (= xe xci+)))
+ (and (= ye yl)
+ (or (= ye yci-)
+ (= ye yci+))))))
+ ;;
+ ;; There must be ZERO or TWO crossings. If two crossings,
+ ;; either or both might be border points, but each must be
+ ;; either ENTERing or LEAVEing with respect to interior.
+ ;; The NOT filters out line segments which skim along a
+ ;; border or nick a corner without entering the interior.
+ ;;
+ ;; XE and YE are already in slots 0,1 in ARG-VEC,
+ ;; placed there as return values by DUAL-CROSS.
+ (setq chain (pushnode arg-vec :Enter chain))
+ (push chain enterlist)
+ (setf (aref arg-vec #.Argv-Vx) xl)
+ (setf (aref arg-vec #.Argv-Vy) yl)
+ (setq chain (pushnode arg-vec :Leave chain)))))))))
+ ;;
+ (cond
+ ((null chain)
+ ;;
+ ;; No nodes pushed means all vertices on contour are OUTSIDE portal.
+ ;; Either it totally encloses portal, so any point inside portal must
+ ;; be enclosed; or it totally excludes portal, so any point inside
+ ;; portal must be NOT enclosed. Use portal center as the testpoint.
+ ;;
+ (setf (aref arg-vec #.Argv-Enc-X) (* 0.5 (+ xci- xci+)))
+ (setf (aref arg-vec #.Argv-Enc-Y) (* 0.5 (+ yci- yci+)))
+ (and (encloses? vlist arg-vec)
+ ;;
+ ;; Contour encloses Portal: Return [list of] portal itself - CCW.
+ ;; Otherwise - no enclosed contour - return NIL.
+ ;;
+ (list (list (list xci- yci-)
+ (list xci+ yci-)
+ (list xci+ yci+)
+ (list xci- yci+)))))
+ ;;
+ ((null enterlist)
+ ;;
+ ;; No border crossings - contour must be totally INSIDE portal.
+ ;; Return list of COUNTER-CLOCKWISE input vertex list.
+ (list (reverse vlist)))
+ ;;
+ ;; Contour is neither totally outside nor totally inside portal - it
+ ;; must cross border at least TWICE. Start a sweep with each ENTER
+ ;; node in turn and trace around subcontour it initiates, pushing result
+ ;; onto OUTLIST.
+ ;;
+ ;; Any LEAVE node encountered initiates a search for the nearest [in CW
+ ;; direction around portal] ENTER node - which could be the starting
+ ;; point [in which case we are done with this subcontour] or might be
+ ;; another ENTER node not yet encountered.
+ ;;
+ ;; When no ENTER nodes remain on ENTERLIST we are finished with the
+ ;; entire traversal, and we can return from function with OUTLIST.
+ ;;
+ (t (do ((starter (car enterlist) (car enterlist))
+ (accumulator '() '())
+ (outlist '()))
+ (( ))
+ ;;
+ ;; Only enter this loop if ENTERLIST is non-empty;
+ ;; thus STARTER must be a valid node [not NIL].
+ (do ((curr starter (svref (the (simple-array t (#.Cnode-Size)) curr)
+ #.Cnode-Next))
+ (flag? nil t))
+ ((and flag? (eq curr starter))
+ ;; Ie, we swept around without finding any LEAVE nodes.
+ (error "CLIP-BLOCKS [1] Sweep in infinite loop."))
+ ;;
+ (declare (type (member nil t) flag?))
+ ;;
+ (push (list (svref (the (simple-array t (#.Cnode-Size)) curr)
+ #.Cnode-Xci)
+ (svref (the (simple-array t (#.Cnode-Size)) curr)
+ #.Cnode-Yci))
+ accumulator)
+ ;;
+ ;; Since we start with an ENTER, we can encounter ONLY nodes of
+ ;; type INSIDE before coming to a LEAVE [which we MUST come to
+ ;; eventually]. At this point we search for the corresponding
+ ;; ENTER point - closing the current subcontour or continuing
+ ;; on it if the ENTER node is other than our starting point.
+ ;;
+ (when (eq (svref (the (simple-array t (#.Cnode-Size)) curr)
+ #.Cnode-Type)
+ :Leave)
+ ;;
+ ;; Find ENTER node nearest-clockwise to LEAVE node.
+ (let ((leavecode
+ (svref (the (simple-array t (#.Cnode-Size)) curr)
+ #.Cnode-Code))
+ (leave-X
+ (svref (the (simple-array t (#.Cnode-Size)) curr)
+ #.Cnode-Xci))
+ (leave-Y
+ (svref (the (simple-array t (#.Cnode-Size)) curr)
+ #.Cnode-Yci))
+ (enternode nil)
+ (entercode 0)
+ (enterdiff 100) ;"Infinite" so first test will succeed
+ (enter-X 0.0)
+ (enter-Y 0.0)
+ (testcode 0)
+ (testdiff 0)
+ (test-X 0.0)
+ (test-Y 0.0))
+ ;;
+ (declare (type single-float leave-X leave-Y
+ enter-X enter-Y test-X test-Y)
+ (type fixnum leavecode entercode testcode
+ enterdiff testdiff))
+ ;;
+ ;; Test against all the nodes on ENTERLIST.
+ (dolist (testnode enterlist)
+ (setq testcode (svref (the (simple-array t (#.Cnode-Size))
+ testnode)
+ #.Cnode-Code)
+ ;; (LOGAND x 7) = (MOD x 8), but it inlines.
+ testdiff (logand (the fixnum
+ (- testcode leavecode)) 7)
+ test-X (svref (the (simple-array t (#.Cnode-Size))
+ testnode)
+ #.Cnode-Xci)
+ test-Y (svref (the (simple-array t (#.Cnode-Size))
+ testnode)
+ #.Cnode-Yci))
+ ;;
+ ;; If we go all the way around CW from LEAVE before getting
+ ;; to the test ENTER, the value of TESTDIFF must be 8 rather
+ ;; than 0 to indicate this fact. This can happen only for
+ ;; non-corner vertices, since at same corner two vertices
+ ;; must be identical, and we rule out this possibility in
+ ;; searching from a LEAVE node to the nearest-clockwise
+ ;; non-identically located ENTER node.
+ (when (and (= testcode leavecode)
+ (case testcode
+ (0) ;Corner - do nothing
+ (1 (< test-Y leave-Y))
+ (2) ;Corner - do nothing
+ (3 (< test-X leave-X))
+ (4) ;Corner - do nothing
+ (5 (> test-Y leave-Y))
+ (6) ;Corner - do nothing
+ (7 (> test-X leave-X))))
+ (setq testdiff 8))
+ ;;
+ ;; Closing ENTER node must represent a vertex distinct from
+ ;; that represented by LEAVE node - thus at least one
+ ;; coordinate value must differ.
+ ;;
+ ;; It is OK for two nodes to have equal-valued coordinates,
+ ;; but this represents a single vertex which belongs to two
+ ;; different subcontours [single-point intersection case].
+ ;; The NODES representing the shared vertex will be
+ ;; allocated to different subcontours by this algorithm.
+ ;; That's why we don't allow equality match here.
+ ;;
+ (when (and (or (/= leave-X test-X)
+ (/= leave-Y test-Y))
+ ;;
+ ;; TESTNODE and ENTERNODE can represent vertices
+ ;; each on a different edge, one on an edge and
+ ;; other in a corner, each in a different corner,
+ ;; both on same edge but with different degrees
+ ;; of rotation [in one we pass no corners going
+ ;; CW from LEAVE to ENTER, in other we pass all
+ ;; 4 corners]. In all such cases, TESTDIFF and
+ ;; ENTERDIFF must differ, and the comparison
+ ;; below selects the smaller.
+ ;;
+ ;; OR ... both vertices can be on the SAME edge
+ ;; with the same degree of rotation [zero or four
+ ;; corners], and thus TESTDIFF = ENTERDIFF and
+ ;; TESTCODE = ENTERCODE. In this case we must
+ ;; compare coordinate values to determine the
+ ;; minimal point - using different comparisons
+ ;; for each edge! TESTCODE and ENTERCODE must
+ ;; be ODD in this case, since both vertices are
+ ;; on an EDGE, not at a corner. [They can't both
+ ;; be at the same corner because then they would
+ ;; would have to be identical, and we can't have
+ ;; multiple identical ENTERing vertices.
+ ;;
+ (or (< testdiff enterdiff)
+ ;; Easy case - different edges/corners.
+ ;;
+ (and (= testdiff enterdiff)
+ ;; Different points on same edge and
+ ;; same degree of CW rotation.
+ ;;
+ (cond
+ ;;
+ ;;Left edge - Y increasing CW.
+ ((= testcode 1)
+ (< test-Y enter-Y))
+ ;;
+ ;;Top edge - X increasing CW.
+ ((= testcode 3)
+ (< test-X enter-X))
+ ;;
+ ;;Right edge - Y decreasing CW.
+ ((= testcode 5)
+ (> test-Y enter-Y))
+ ;;
+ ;;Bottom edge - X decreasing CW.
+ ((= testcode 7) ;Bottom: decreasing X
+ (> test-X enter-X))
+ ;;
+ (t (error "CLIP-BLOCKS [2]"))))))
+ ;;
+ ;; We have found a "better" ENTER node - closer in CW
+ ;; direction to the starting LEAVE node. Save it and its
+ ;; associated values.
+ (setq enternode testnode
+ entercode testcode
+ enterdiff testdiff
+ enter-X test-X
+ enter-Y test-Y)))
+ ;;
+ (unless enternode
+ ;;
+ ;; Highly unlikely but possible case happened - due to
+ ;; roundoff the only ENTER node pushed happens to have the
+ ;; same coordinates as the LEAVE node from which this search
+ ;; started. Since only one ENTER node was pushed, there
+ ;; could have been only one LEAVE node too. Thus contour
+ ;; must just barely clip the border in single point [within
+ ;; roundoff]. Either the contour must surround portal or
+ ;; portal and contour must be disjoint. Determine which and
+ ;; return immediately.
+ ;;
+ (setf (aref arg-vec #.Argv-Enc-X) (* 0.5 (+ xci- xci+)))
+ (setf (aref arg-vec #.Argv-Enc-Y) (* 0.5 (+ yci- yci+)))
+ (return-from clip-blocks
+ ;;
+ ;; Does contour VLIST enclose portal's midpoint?
+ (and (encloses? vlist arg-vec)
+ ;;
+ ;; If NO, portal/contour are disjoint: return NIL.
+ ;; If YES, contour contains portal: return list
+ ;; of vertices as a CCW portal traversal.
+ ;;
+ (list (list (list xci- yci-)
+ (list xci+ yci-)
+ (list xci+ yci+)
+ (list xci- yci+))))))
+ ;;
+ ;; Found ENTER node. See if we have rounded any corners.
+ (when (or (< entercode leavecode) ;On different edges, or ...
+ (= enterdiff 8)) ;same edge, wrap all way around.
+ ;;
+ ;; Wrapped around (XCI- YCI-) corner [and possibly others].
+ ;; Incrementing ENTERCODE by the modulus of 8 allows use of
+ ;; linear rather than modular comparisons in decision tree.
+ (setq entercode (the fixnum (+ entercode 8))))
+
+ ;; Exhaustive decision tree enumerates all the possibilities.
+ ;; A vertex which IS a portal corner [node has an EVEN CODE]
+ ;; supplies that corner itself. We only "push corners" here
+ ;; if the subcontour "rounds" a corner, that is, if contour
+ ;; originates BEFORE [not AT] and terminates AFTER [not AT]
+ ;; the corresponding corner.
+ ;;
+ (cond ((= entercode leavecode))
+ ;; ENTER and LEAVE vertices on same edge - do nothing.
+ ;;
+ ((< leavecode 2)
+ (when (> entercode 2)
+ (push (list xci- yci+) accumulator))
+ (when (> entercode 4)
+ (push (list xci+ yci+) accumulator))
+ (when (> entercode 6)
+ (push (list xci+ yci-) accumulator))
+ (when (> entercode 8)
+ (push (list xci- yci-) accumulator)))
+ ;;
+ ((< leavecode 4)
+ (when (> entercode 4)
+ (push (list xci+ yci+) accumulator))
+ (when (> entercode 6)
+ (push (list xci+ yci-) accumulator))
+ (when (> entercode 8)
+ (push (list xci- yci-) accumulator))
+ (when (> entercode 10)
+ (push (list xci- yci+) accumulator)))
+ ;;
+ ((< leavecode 6)
+ (when (> entercode 6)
+ (push (list xci+ yci-) accumulator))
+ (when (> entercode 8)
+ (push (list xci- yci-) accumulator))
+ (when (> entercode 10)
+ (push (list xci- yci+) accumulator))
+ (when (> entercode 12)
+ (push (list xci+ yci+) accumulator)))
+ ;;
+ ;; LEAVECODE must be < 8 since that is the modulus.
+ (t (when (> entercode 8)
+ (push (list xci- yci-) accumulator))
+ (when (> entercode 10)
+ (push (list xci- yci+) accumulator))
+ (when (> entercode 12)
+ (push (list xci+ yci+) accumulator))
+ (when (> entercode 14)
+ (push (list xci+ yci-) accumulator))))
+ ;;
+ ;; Now that any needed corners are pushed, we can take care
+ ;; of the ENTER node. Note that we wait to delete it from
+ ;; ENTERLIST until NOW, rather than when first encountered
+ ;; in original sweep, because even if already processed into
+ ;; a subcontour we still need to find it [on ENTERLIST] when
+ ;; we encounter the LEAVE node on that subcontour which
+ ;; closes the contour with this ENTER node.
+ ;;
+ (cond
+ ((eq enternode starter)
+ ;;
+ ;; Found starting point - end of current subcontour.
+ (unless (cddr accumulator)
+ ;; Subcontours must have at least 3 nodes - at least
+ ;; one ENTER, same number of LEAVEs, zero or more
+ ;; INSIDE nodes, and zero to 4 corner nodes.
+ (error "CLIP-BLOCKS [3] Degenerate contour."))
+ ;;
+ (push accumulator outlist)
+ (setq enterlist (cdr enterlist))
+ (cond ((null enterlist)
+ (return-from clip-blocks outlist))
+ (t (return))))
+ ;;
+ ;; Found an ENTER node NOT at end of subcontour.
+ ;; Push it and continue traversal from that point.
+ (t (push (list (svref (the (simple-array t (#.Cnode-Size))
+ enternode)
+ #.Cnode-Xci)
+ (svref (the (simple-array t (#.Cnode-Size))
+ enternode)
+ #.Cnode-Yci))
+ accumulator)
+ (setq enterlist (delete enternode enterlist :test #'eq))
+ (setq curr enternode)))))))))))
+
+;;;-------------------------------------------------------------
+
+(defun grazer? (arg-vec)
+ ;;
+ ;; A GRAZER is a vertex ON the border but treated as INSIDE because the
+ ;; polygon interior is between the two segments which intersect at this
+ ;; vertex AND both segments traverse the interior of portal.
+ ;;
+ (declare (type (simple-array single-float (#.Argv-Size)) arg-vec))
+ ;;
+ (let ((bx (aref arg-vec #.Argv-Bx))
+ (by (aref arg-vec #.Argv-By))
+ (cx (aref arg-vec #.Argv-Cx))
+ (cy (aref arg-vec #.Argv-Cy))
+ (nx (aref arg-vec #.Argv-Nx))
+ (ny (aref arg-vec #.Argv-Ny))
+ (xci- (aref arg-vec #.Argv-Xci-))
+ (xci+ (aref arg-vec #.Argv-Xci+))
+ (yci- (aref arg-vec #.Argv-Yci-))
+ (yci+ (aref arg-vec #.Argv-Yci+)))
+ ;;
+ ;; BX, BY is vertex just BEFORE current one,
+ ;; CX, CY is CURRENT vertex,
+ ;; NX, NY is NEXT vertex, just AFTER current one.
+ ;;
+ (declare (type single-float bx by cx cy nx ny xci- xci+ yci- yci+))
+ ;;
+ (and (<= xci- cx xci+) ;Current vertex is on portal boundary,
+ (<= yci- cy yci+) ;so both CX and CY must be in range.
+ (or (= cx xci-) ;Current vertex must lie on at least
+ (= cx xci+) ;one of the four boundary edges.
+ (= cy yci-)
+ (= cy yci+))
+ ;;
+ ;; At least ONE of the following conditions must be true, due to
+ ;; OR above, and if ANY is true the failure of its subsidiary
+ ;; conditions will cause its AND to succeed, forcing the outermost
+ ;; OR to succeed, forcing the NOT and hence the entire fcn to FAIL.
+ (not (or (and (= cx xci-) ;If Current is on left edge,
+ (or (<= bx xci-) ;other two must be to right.
+ (<= nx xci-)))
+ (and (= cx xci+) ;If Current is on right edge,
+ (or (>= bx xci+) ;other two must be to left.
+ (>= nx xci+)))
+ (and (= cy yci-) ;If Current is on top edge,
+ (or (<= by yci-) ;other two must be below.
+ (<= ny yci-)))
+ (and (= cy yci+) ;If Current is on bottom edge,
+ (or (>= by yci+) ;other two must be above.
+ (>= ny yci+)))))
+ ;;
+ ;; Now we know both line segments traverse the portal interior. Now
+ ;; check that they do so in the correct direction - clockwise along
+ ;; the portal edge. Get the cross-product of two vectors, first the
+ ;; segment approaching the border vertex and second the segment
+ ;; leaving the border vertex. If this cross-product is negative,
+ ;; implying clockwise rotation [of < 180 degrees] along direction of
+ ;; contour traversal [clockwise], the polygon interior is toward the
+ ;; center of the portal from the current vertex.
+ ;;
+ (< (* (- cx bx)
+ (- ny cy))
+ (* (- nx cx)
+ (- cy by))))))
+
+;;;-------------------------------------------------------------
+
+(defun pushnode (arg-vec node-type chain)
+ ;;
+ ;; Creates a singly-linked circular chain of all nodes on original
+ ;; contour which are inside or border on portal. CHAIN is
+ ;; ptr to last node allocated [or NIL if none yet]. Returns ptr
+ ;; to node allocated in this call.
+ ;;
+ (declare (type (simple-array single-float (#.Argv-Size)) arg-vec))
+ ;;
+ (let ((xcoord (aref arg-vec #.Argv-Vx))
+ (ycoord (aref arg-vec #.Argv-Vy))
+ (xci- (aref arg-vec #.Argv-Xci-))
+ (xci+ (aref arg-vec #.Argv-Xci+))
+ (yci- (aref arg-vec #.Argv-Yci-))
+ (yci+ (aref arg-vec #.Argv-Yci+))
+ (node (make-array #.Cnode-Size :element-type t)))
+ ;;
+ (declare (type (simple-array t (#.Cnode-Size)) node)
+ (type single-float xcoord ycoord xci- xci+ yci- yci+))
+ ;;
+ (unless (and (<= xci- xcoord xci+)
+ (<= yci- ycoord yci+))
+ (error "PUSHNODE [1] Vertex outside portal."))
+ ;;
+ (setf (svref node #.Cnode-Xci) xcoord)
+ (setf (svref node #.Cnode-Yci) ycoord)
+ (setf (svref node #.Cnode-Type) node-type)
+ ;;
+ ;; Cache border code for convenience of border-closing search algorithm.
+ (setf (svref node #.Cnode-Code)
+ (cond ((eq node-type :Inside)
+ nil)
+ ((= xcoord xci-)
+ (cond ((= ycoord yci-) 0)
+ ((= ycoord yci+) 2)
+ (t 1)))
+ ((= xcoord xci+)
+ (cond ((= ycoord yci+) 4)
+ ((= ycoord yci-) 6)
+ (t 5)))
+ ((= ycoord yci+) 3)
+ ((= ycoord yci-) 7)
+ (t (error "PUSHNODE [2] Border vertex inside portal."))))
+ ;;
+ ;; Singly-directional and circular linkage.
+ (cond ((null chain)
+ ;; First node points to itself.
+ (setf (svref node #.Cnode-Next) node))
+ ;;
+ ;; Otherwise splice in all later nodes with NEXT pointing
+ ;; to node to which last allocated used to point
+ ;; [in forward direction].
+ (t (setf (svref node #.Cnode-Next)
+ (svref (the (simple-array t (#.Cnode-Size)) chain)
+ #.Cnode-Next))
+ (setf (svref (the (simple-array t (#.Cnode-Size)) chain)
+ #.Cnode-Next)
+ node)))
+ ;;
+ ;; Must return NODE just allocated.
+ node))
+
+;;;-------------------------------------------------------------
+
+(defun single-cross (arg-vec &aux (crosspt 0.0))
+ ;;
+ (declare (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type single-float crosspt))
+ ;;
+ (let ((ix (aref arg-vec #.Argv-Ix))
+ (iy (aref arg-vec #.Argv-Iy))
+ (ox (aref arg-vec #.Argv-Ox))
+ (oy (aref arg-vec #.Argv-Oy))
+ (xci- (aref arg-vec #.Argv-Xci-))
+ (xci+ (aref arg-vec #.Argv-Xci+))
+ (yci- (aref arg-vec #.Argv-Yci-))
+ (yci+ (aref arg-vec #.Argv-Yci+)))
+ ;;
+ ;; IX, IY - coordinates of point known to be strictly INSIDE portal.
+ ;; OX, OY - coordinates of point known to be OUTSIDE portal or
+ ;; ON BORDER.
+ ;;
+ ;; Nota Bene: Inside case is strict; Outside case includes equality.
+ ;; Either endpoint can be the initial/terminal endpoint.
+ ;;
+ (declare (type single-float ix iy ox oy xci- xci+ yci- yci+))
+ ;;
+ (tagbody
+ (when (and (<= ox xci-) ;Crossing at XCI-
+ (< xci- ix))
+ (setq crosspt (interpolate-crossing iy oy ix xci- ox))
+ (when (<= yci- crosspt yci+)
+ (setf (aref arg-vec #.Argv-X) xci-)
+ (setf (aref arg-vec #.Argv-Y) crosspt)
+ (go DONE)))
+ ;;
+ (when (and (< ix xci+) ;Crossing at XCI+
+ (<= xci+ ox))
+ (setq crosspt (interpolate-crossing iy oy ix xci+ ox))
+ (when (<= yci- crosspt yci+)
+ (setf (aref arg-vec #.Argv-X) xci+)
+ (setf (aref arg-vec #.Argv-Y) crosspt)
+ (go DONE)))
+ ;;
+ (when (and (<= oy yci-) ;Crossing at YCI-
+ (< yci- iy))
+ (setq crosspt (interpolate-crossing ix ox iy yci- oy))
+ (when (<= xci- crosspt xci+)
+ (setf (aref arg-vec #.Argv-X) crosspt)
+ (setf (aref arg-vec #.Argv-Y) yci-)
+ (go DONE)))
+ ;;
+ (when (and (< iy yci+) ;Crossing at YCI+
+ (<= yci+ oy))
+ (setq crosspt (interpolate-crossing ix ox iy yci+ oy))
+ (when (<= xci- crosspt xci+)
+ (setf (aref arg-vec #.Argv-X) crosspt)
+ (setf (aref arg-vec #.Argv-Y) yci+)
+ (go DONE)))
+ ;;
+ (error "SINGLE-CROSS [1] Bad crossing.")
+ ;;
+ DONE))
+ ;;
+ ;; Don't allow a boxed flonum to be passed back accidentally.
+ nil)
+
+;;;-------------------------------------------------------------
+
+(defun dual-cross (arg-vec &aux (crosspt 0.0) (xe 0.0) (ye 0.0)
+ (xl 0.0) (yl 0.0) (entering? nil) (leaving? nil))
+ ;;
+ (declare (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type (member nil t) entering? leaving?)
+ (type single-float crosspt xe ye xl yl))
+ ;;
+ (let ((ix (aref arg-vec #.Argv-Ix))
+ (iy (aref arg-vec #.Argv-Iy))
+ (ox (aref arg-vec #.Argv-Ox))
+ (oy (aref arg-vec #.Argv-Oy))
+ (xci- (aref arg-vec #.Argv-Xci-))
+ (xci+ (aref arg-vec #.Argv-Xci+))
+ (yci- (aref arg-vec #.Argv-Yci-))
+ (yci+ (aref arg-vec #.Argv-Yci+)))
+ ;;
+ ;; IX, IY - coordinates of INITIAL endpoint.
+ ;; OX, OY - coordinates of TERMINAL endpoint.
+ ;; Both endpoints known to be outside, and either or both endpoints
+ ;; can have one or both coordinates equalling one of the border
+ ;; values.
+ ;;
+ ;; Returns 5 values: T/NIL [whether line segment crosses portal],
+ ;; X and Y of ENTER crossing and then X and Y of LEAVE crossing.
+ ;; If first value is NIL the rest of them are meaningless - a
+ ;; default of 0.0 or values left over from flushed edge or corner
+ ;; grazings.
+ ;;
+ (declare (type single-float ix iy ox oy xci- xci+ yci- yci+))
+ ;;
+ (when (and (<= ix xci-) ;Entering at XCI-
+ (< xci- ox))
+ (setq crosspt (interpolate-crossing iy oy ix xci- ox))
+ (when (<= yci- crosspt yci+)
+ (setq xe xci- ye crosspt entering? t)))
+ (when (and (<= ox xci-) ;Leaving at XCI-
+ (< xci- ix))
+ (setq crosspt (interpolate-crossing iy oy ix xci- ox))
+ (when (<= yci- crosspt yci+)
+ (setq xl xci- yl crosspt leaving? t)))
+ (when (and (< ox xci+) ;Entering at XCI+
+ (<= xci+ ix))
+ (setq crosspt (interpolate-crossing iy oy ix xci+ ox))
+ (when (<= yci- crosspt yci+)
+ (setq xe xci+ ye crosspt entering? t)))
+ (when (and (< ix xci+) ;Leaving at XCI+
+ (<= xci+ ox))
+ (setq crosspt (interpolate-crossing iy oy ix xci+ ox))
+ (when (<= yci- crosspt yci+)
+ (setq xl xci+ yl crosspt leaving? t)))
+ (when (and (<= iy yci-) ;Entering at YCI-
+ (< yci- oy))
+ (setq crosspt (interpolate-crossing ix ox iy yci- oy))
+ (when (<= xci- crosspt xci+)
+ (setq xe crosspt ye yci- entering? t)))
+ (when (and (<= oy yci-) ;Leaving at YCI-
+ (< yci- iy))
+ (setq crosspt (interpolate-crossing ix ox iy yci- oy))
+ (when (<= xci- crosspt xci+)
+ (setq xl crosspt yl yci- leaving? t)))
+ (when (and (< oy yci+) ;Entering at YCI+
+ (<= yci+ iy))
+ (setq crosspt (interpolate-crossing ix ox iy yci+ oy))
+ (when (<= xci- crosspt xci+)
+ (setq xe crosspt ye yci+ entering? t)))
+ (when (and (< iy yci+) ;Leaving at YCI+
+ (<= yci+ oy))
+ (setq crosspt (interpolate-crossing ix ox iy yci+ oy))
+ (when (<= xci- crosspt xci+)
+ (setq xl crosspt yl yci+ leaving? t)))
+ ;;
+ ;; A "crossing" is legitimate only if there is an ENTER and a LEAVE.
+ ;; Corner grazings might cause one without the other, and they are
+ ;; not considered legitimate "crossings".
+ ;;
+ (setf (aref arg-vec #.Argv-Xe) xe)
+ (setf (aref arg-vec #.Argv-Ye) ye)
+ (setf (aref arg-vec #.Argv-Xl) xl)
+ (setf (aref arg-vec #.Argv-Yl) yl)
+ ;;
+ (and entering? leaving?)))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/coll-panels.cl b/prism/src/coll-panels.cl
new file mode 100644
index 0000000..6b382ee
--- /dev/null
+++ b/prism/src/coll-panels.cl
@@ -0,0 +1,1131 @@
+;;;
+;;; coll-panels
+;;;
+;;; defines the various types of collimator panels and their methods
+;;;
+;;; 5-Sep-1993 I. Kalet split off from collimators module
+;;; 1-Nov-1993 J. Unger add destroy method stub for mlc panel
+;;; 30-Dec-1993 I. Kalet add full support for MLC
+;;; 16-May-1994 I. Kalet add really full support for MLC
+;;; 2-Jun-1994 I. Kalet change display-contour-editor to
+;;; display-planar-editor, make make-collimator-panel a generic
+;;; function, move update-portal-bev to bev-graphics, make size use a
+;;; constant symbol, large.
+;;; 3-Jun-1994 J. Unger redefine attributes of combination-coll, edit
+;;; code involving combination-coll.
+;;; 27-Jun-1994 I. Kalet change labels on SFD and BEAM PORTAL buttons
+;;; on MLC subpanel.
+;;; 12-Jul-1994 J. Unger coerce some incoming numbers announced from
+;;; textlines to single-float before assigning to collim attributes.
+;;; 21-Jul-1994 J. Unger impl button for leaf-panel, impl & pass beam-for
+;;; attribute to variable-jaw-collimator upon creation.
+;;; 02-Aug-1994 J. Unger turn on leaf-panel for neutron vj coll beams.
+;;; 04-Aug-1994 J. Unger turn off again.
+;;; 05-Aug-1994 J. Unger add cnts-coll-panel class def & supporting code,
+;;; take hacks out of var-jaw-coll-panel, make nice, & move to cnts-coll-pnl
+;;; 16-Sep-1994 J. Unger add leaf chart button to mlc & cnts
+;;; collimator panels.
+;;; 11-Jan-1995 I. Kalet destroy bev of mlc panel. Make beam-for an
+;;; attribute of cnts and mlc panels, not the collimators, and name
+;;; it beam-of instead. Add plan-of, patient-of and pass to
+;;; leaf-panel, etc.
+;;; 30-Apr-1995 I. Kalet finish code to set the digitizer mag in the
+;;; MLC panel contour editor according to the SFD.
+;;; 15-Jan-1996 I. Kalet split multileaf-coll-panel into
+;;; portal-coll-panel and multileaf-coll-panel, add
+;;; electron-coll-panel and srs-coll-panel, latter from M. Phillips.
+;;; 30-Sep-1996 I. Kalet update calls to bev-draw-all for new
+;;; signature and make SFD textline numeric, put in-line code for
+;;; electron cone square in refresh-portal-editor method.
+;;; 21-Jan-1997 I. Kalet eliminate table-position.
+;;; 29-Apr-1997 I. Kalet put beam name on portal editor title bar
+;;; 4-May-1997 I. Kalet use label, not title, in sliderboxes.
+;;; 5-Jun-1997 I. Kalet machine returns object, not name
+;;; 23-Jun-1997 I. Kalet put in missing make-collimator-panel method
+;;; for cnts-coll. Fix electron portal and cone drawing code.
+;;; 3-Oct-1997 BobGian inline-expand AVERAGE - keep it simple.
+;;; 2-May-1998 I. Kalet use new chart-panel function for leaf chart.
+;;; 11-Jun-1998 I. Kalet change :beam to :beam-for in make-view call.
+;;; 17-Dec-1998 I. Kalet add energy selection to electron collimator
+;;; panel.
+;;; 25-Feb-1999 I. Kalet move find-center-vol from here to volumes.
+;;; 23-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 5-Sep-1999 I. Kalet modify portal-coll-panel, mlc-coll-panel and
+;;; electron-coll-panel for new combined mlc-panel that does both
+;;; portal contour and leaf settings.
+;;; 19-Mar-2000 I. Kalet revisions for new chart code.
+;;; 30-May-2000 I. Kalet correct error in call to chart-panel.
+;;; 10-Sep-2000 I. Kalet remove obsolete srs collimator support,
+;;; modify mlc-panel per new arrangements.
+;;; 23-Nov-2001 I. Kalet add open-portal button, remove obsolete
+;;; :angle input to mlc-panel.
+;;; 15-May-2002 I. Kalet fix electron-coll-panel so that cutout
+;;; contour rotates with collimator. Add DRR and declutter controls.
+;;; 19-Jan-2005 I. Kalet change make-contour-editor to make-planar-editor
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+;;; these numbers represent space available on the beam panel
+;;;---------------------------------------------
+
+(defvar *coll-pan-width* 290)
+(defvar *coll-pan-height* 325)
+
+;;;---------------------------------------------
+
+(defclass collimator-panel ()
+
+ ((coll-for :accessor coll-for
+ :initarg :coll-for
+ :documentation "The collimator controlled by this panel")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame containing the
+collimator controls")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "The busy flag for updates of settings")
+
+ )
+
+ (:documentation "The base collimator panel class has the common
+elements of a reference to the collimator itself, the frame for the
+panel and the busy flag.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp collimator-panel)
+ &rest initargs)
+
+ (setf (panel-frame cp)
+ (apply #'sl:make-frame *coll-pan-width* *coll-pan-height*
+ :border-width 0 initargs)))
+
+;;;---------------------------------------------
+
+(defmethod destroy ((cp collimator-panel))
+
+ (sl:destroy (panel-frame cp)))
+
+;;;---------------------------------------------
+
+(defclass symmetric-jaw-coll-panel (collimator-panel)
+
+ ((sx :accessor sx
+ :documentation "The slider for the x jaw setting")
+
+ (sy :accessor sy
+ :documentation "The slider for the y jaw setting")
+
+ )
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-collimator-panel ((coll symmetric-jaw-coll) &rest initargs)
+
+ "returns a collimator panel for collimator coll, and connects the
+collimator settings to the panel sliders or other controls. The type
+of panel returned matches the type of collimator provided."
+
+ (apply #'make-instance 'symmetric-jaw-coll-panel
+ :coll-for coll :allow-other-keys t initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp symmetric-jaw-coll-panel)
+ &rest initargs)
+
+ (let* ((sw 260) ;; magic numbers from beam panel
+ (sh 30)
+ (fr (panel-frame cp))
+ (win (sl:window fr))
+ (font (sl:font fr)) ;; use font provided or defaulted
+ (coll (coll-for cp))
+ (x-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL X: " :parent win
+ :ulc-x 0 :ulc-y 0
+ :setting (x coll) :font font
+ initargs))
+ (y-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL Y: " :parent win
+ :ulc-x 0 :ulc-y 70
+ :setting (y coll) :font font
+ initargs)))
+ ;; install them and connect them up to the collimator settings
+ (setf (sx cp) x-sl
+ (sy cp) y-sl)
+ (ev:add-notify cp (sl:value-changed x-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (x (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-x coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sx pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:value-changed y-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (y (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-y coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sy pan)) val)
+ (setf (busy pan) nil))))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((cp symmetric-jaw-coll-panel))
+
+ (sl:destroy (sx cp))
+ (sl:destroy (sy cp))
+ (ev:remove-notify cp (new-coll-x (coll-for cp)))
+ (ev:remove-notify cp (new-coll-y (coll-for cp))))
+
+;;;---------------------------------------------
+
+(defclass variable-jaw-coll-panel (collimator-panel)
+
+ ((sx-sup :accessor sx-sup
+ :documentation "The slider for the x-sup jaw setting")
+
+ (sy-sup :accessor sy-sup
+ :documentation "The slider for the y-sup jaw setting")
+
+ (sx-inf :accessor sx-inf
+ :documentation "The slider for the x-inf jaw setting")
+
+ (sy-inf :accessor sy-inf
+ :documentation "The slider for the y-inf jaw setting")
+
+ )
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-collimator-panel ((coll variable-jaw-coll) &rest initargs)
+
+ (apply #'make-instance 'variable-jaw-coll-panel
+ :coll-for coll :allow-other-keys t initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp variable-jaw-coll-panel)
+ &rest initargs)
+
+ (let* ((sw 260) ;; magic numbers from beam panel
+ (sh 30)
+ (fr (panel-frame cp))
+ (win (sl:window fr))
+ (font (sl:font fr)) ;; use font provided or defaulted
+ (coll (coll-for cp))
+ (xsup-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL X SUP: " :parent win
+ :ulc-x 0 :ulc-y 0
+ :setting (x-sup coll) :font font
+ initargs))
+ (ysup-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL Y SUP: " :parent win
+ :ulc-x 0 :ulc-y 70
+ :setting (y-sup coll) :font font
+ initargs))
+ (xinf-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL X INF: " :parent win
+ :ulc-x 0 :ulc-y 140
+ :setting (x-inf coll) :font font
+ initargs))
+ (yinf-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL Y INF: " :parent win
+ :ulc-x 0 :ulc-y 210
+ :setting (y-inf coll) :font font
+ initargs)))
+ ;; install them and connect them up to the collimator settings
+ (setf (sx-sup cp) xsup-sl
+ (sy-sup cp) ysup-sl
+ (sx-inf cp) xinf-sl
+ (sy-inf cp) yinf-sl)
+ (ev:add-notify cp (sl:value-changed xsup-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (x-sup (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-x-sup coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sx-sup pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:value-changed ysup-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (y-sup (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-y-sup coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sy-sup pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:value-changed xinf-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (x-inf (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-x-inf coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sx-inf pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:value-changed yinf-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (y-inf (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-y-inf coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sy-inf pan)) val)
+ (setf (busy pan) nil))))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((cp variable-jaw-coll-panel))
+
+ (sl:destroy (sx-sup cp))
+ (sl:destroy (sy-sup cp))
+ (sl:destroy (sx-inf cp))
+ (sl:destroy (sy-inf cp))
+ (ev:remove-notify cp (new-coll-x-sup (coll-for cp)))
+ (ev:remove-notify cp (new-coll-y-sup (coll-for cp)))
+ (ev:remove-notify cp (new-coll-x-inf (coll-for cp)))
+ (ev:remove-notify cp (new-coll-y-inf (coll-for cp))))
+
+;;;---------------------------------------------
+
+(defclass cnts-coll-panel (variable-jaw-coll-panel)
+
+ ((beam-of :initarg :beam-of
+ :accessor beam-of
+ :documentation "The beam containing the collimator.")
+
+ (plan-of :initarg :plan-of
+ :accessor plan-of
+ :documentation "The plan containing the beam.")
+
+ (patient-of :initarg :patient-of
+ :accessor patient-of
+ :documentation "The current patient.")
+
+ (leaf-btn :accessor leaf-btn
+ :documentation "The leaf display button.")
+
+ (leaf-panel :accessor leaf-panel
+ :initform nil
+ :documentation "The leaf panel for this collimator panel.")
+
+ (chart-btn :accessor chart-btn
+ :documentation "The leaf chart button for this coll panel.")
+
+ )
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-collimator-panel ((coll cnts-coll) &rest initargs)
+
+ (apply #'make-instance 'cnts-coll-panel
+ :coll-for coll :allow-other-keys t initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp cnts-coll-panel) &rest initargs)
+
+ (setf (leaf-btn cp)
+ (apply #'sl:make-button 120 25
+ :label "LEAF EDIT" :parent (sl:window (panel-frame cp))
+ :ulc-x 0 :ulc-y 290 ;; arbitrary
+ initargs))
+ (setf (chart-btn cp)
+ (apply #'sl:make-button 120 25
+ :label "LEAF CHART" :parent (sl:window (panel-frame cp))
+ :ulc-x 150 :ulc-y 290
+ initargs))
+ (ev:add-notify cp (sl:button-on (leaf-btn cp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (setf (leaf-panel pan)
+ (make-mlc-panel :beam-of (beam-of pan)
+ :plan-of (plan-of pan)
+ :patient-of (patient-of pan)))
+ (ev:add-notify pan (deleted (leaf-panel pan))
+ #'(lambda (pan lp)
+ (declare (ignore lp))
+ (setf (leaf-panel pan) nil)
+ (unless (busy pan)
+ (setf (busy pan) t)
+ (setf (sl:on (leaf-btn cp)) nil)
+ (setf (busy pan) nil))))))
+ (ev:add-notify cp (sl:button-off (leaf-btn cp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (unless (busy pan)
+ (setf (busy pan) t)
+ (destroy (leaf-panel pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:button-on (chart-btn cp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (chart-panel 'leaf
+ (patient-of pan) (plan-of pan)
+ (beam-of pan))
+ (setf (sl:on (chart-btn cp)) nil))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((cp cnts-coll-panel))
+
+ (when (sl:on (leaf-btn cp)) (setf (sl:on (leaf-btn cp)) nil))
+ (sl:destroy (leaf-btn cp))
+ (sl:destroy (chart-btn cp)))
+
+;;;---------------------------------------------
+
+(defclass combination-coll-panel (collimator-panel)
+
+ ((sx-sup :accessor sx-sup
+ :documentation "The slider for the x-sup jaw setting")
+
+ (sx-inf :accessor sx-inf
+ :documentation "The slider for the x-inf jaw setting")
+
+ (sy :accessor sy
+ :documentation "The slider for the y jaw setting")
+
+ )
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-collimator-panel ((coll combination-coll)
+ &rest initargs)
+
+ (apply #'make-instance 'combination-coll-panel
+ :coll-for coll :allow-other-keys t initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp combination-coll-panel)
+ &rest initargs)
+
+ (let* ((sw 260) ;; magic numbers from beam panel
+ (sh 30)
+ (fr (panel-frame cp))
+ (win (sl:window fr))
+ (font (sl:font fr)) ;; use font provided or defaulted
+ (coll (coll-for cp))
+ (xsup-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL X SUP: " :parent win
+ :ulc-x 0 :ulc-y 0
+ :setting (x-sup coll) :font font
+ initargs))
+ (xinf-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL X INF: " :parent win
+ :ulc-x 0 :ulc-y 70
+ :setting (x-inf coll) :font font
+ initargs))
+ (y-sl (apply #'sl:make-sliderbox sw sh 0.0 45.0 45.0
+ :label "COLL Y: " :parent win
+ :ulc-x 0 :ulc-y 140
+ :setting (y coll) :font font
+ initargs)))
+ ;; install them and connect them up to the collimator settings
+ (setf (sx-sup cp) xsup-sl
+ (sx-inf cp) xinf-sl
+ (sy cp) y-sl)
+ (ev:add-notify cp (sl:value-changed xsup-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (x-sup (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-x-sup coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sx-sup pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:value-changed xinf-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (x-inf (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-x-inf coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sx-inf pan)) val)
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:value-changed y-sl)
+ #'(lambda (pan sl val)
+ (declare (ignore sl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (y (coll-for cp))
+ (coerce val 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (new-coll-y coll)
+ #'(lambda (pan c val)
+ (declare (ignore c))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (sy pan)) val)
+ (setf (busy pan) nil))))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((cp combination-coll-panel))
+
+ (sl:destroy (sx-sup cp))
+ (sl:destroy (sx-inf cp))
+ (sl:destroy (sy cp))
+ (ev:remove-notify cp (new-coll-x-sup (coll-for cp)))
+ (ev:remove-notify cp (new-coll-x-inf (coll-for cp)))
+ (ev:remove-notify cp (new-coll-y (coll-for cp))))
+
+;;;---------------------------------------------
+
+(defclass portal-coll-panel (collimator-panel)
+
+ ((beam-of :initarg :beam-of
+ :accessor beam-of
+ :documentation "The beam containing the collimator.")
+
+ (plan-of :initarg :plan-of
+ :accessor plan-of
+ :documentation "The plan containing the beam.")
+
+ (patient-of :initarg :patient-of
+ :accessor patient-of
+ :documentation "The current patient.")
+
+ (sfd-box :accessor sfd-box
+ :documentation "The textline for the source-to-film
+distance, when using the digitizer for input.")
+
+ (filmdist :type single-float
+ :accessor filmdist
+ :initarg :filmdist
+ :documentation "The source to film distance when using
+simulator or port films on the digitizer.")
+
+ )
+
+ (:default-initargs :filmdist 100.0)
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp portal-coll-panel)
+ &rest initargs)
+
+ (setf (sfd-box cp) (apply #'sl:make-textline 120 25
+ :label "SFD: "
+ :parent (sl:window (panel-frame cp))
+ :ulc-x (floor (- *coll-pan-width* 120) 2)
+ :ulc-y 50 ;; arbitrary - lots of room
+ :font (sl:font (panel-frame cp))
+ :numeric t :lower-limit 10.0 :upper-limit 200.0
+ initargs))
+ ;; initial values here, but register action in child classes
+ (setf (filmdist cp) (isodist (beam-of cp)))
+ (setf (sl:info (sfd-box cp)) (filmdist cp)))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((mp portal-coll-panel))
+
+ (sl:destroy (sfd-box mp)))
+
+;;;---------------------------------------------
+
+(defclass multileaf-coll-panel (portal-coll-panel)
+
+ ((leaf-button :accessor leaf-button
+ :documentation "The button that brings up the mlc
+contour and leaf editing panel.")
+
+ (leaf-panel :accessor leaf-panel
+ :initform nil
+ :documentation "The mlc panel for this collimator panel.")
+
+ (chart-button :accessor chart-button
+ :documentation "The leaf chart button for this collim pnl.")
+
+ )
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-collimator-panel ((coll multileaf-coll) &rest initargs)
+
+ (apply #'make-instance 'multileaf-coll-panel
+ :coll-for coll :allow-other-keys t initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp multileaf-coll-panel)
+ &rest initargs)
+
+ (let* ((btw 120) ;; magic numbers for button size etc.
+ (bth 25)
+ (ulc-x (floor (- *coll-pan-width* btw) 2))
+ (fr (panel-frame cp))
+ (win (sl:window fr))
+ (font (sl:font fr)) ;; use font provided or defaulted
+ (leaf-b (apply #'sl:make-button btw bth
+ :label "LEAF/PORTAL EDIT" :parent win
+ :ulc-x ulc-x
+ :ulc-y 120 ;; below portal SFD button
+ :font font
+ initargs))
+ (chart-b (apply #'sl:make-button btw bth
+ :label "LEAF CHART" :parent win
+ :ulc-x ulc-x :ulc-y 170
+ :font font
+ initargs)))
+ ;; install and connect up to the collimator settings
+ (setf (leaf-button cp) leaf-b
+ (chart-button cp) chart-b)
+ (ev:add-notify cp (sl:button-on leaf-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (setf (leaf-panel pan)
+ (make-mlc-panel :beam-of (beam-of pan)
+ :plan-of (plan-of pan)
+ :patient-of (patient-of pan)
+ :filmdist (filmdist pan)))
+ (ev:add-notify pan (deleted (leaf-panel pan))
+ #'(lambda (pn lp)
+ (declare (ignore lp))
+ (setf (leaf-panel pn) nil)
+ (unless (busy pn)
+ (setf (busy pn) t)
+ (setf (sl:on leaf-b) nil)
+ (setf (busy pn) nil))))))
+ (ev:add-notify cp (sl:button-off leaf-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (unless (busy pan)
+ (setf (busy pan) t)
+ (destroy (leaf-panel pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:new-info (sfd-box cp))
+ #'(lambda (pan tl info)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (let ((fd (coerce (read-from-string info)
+ 'single-float)))
+ (setf (filmdist pan) fd)
+ (setf (sl:info tl) (format nil "~5,1F" fd))
+ (when (leaf-panel pan)
+ (setf (filmdist (leaf-panel pan)) fd)))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:button-on chart-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (chart-panel 'leaf (patient-of pan)
+ (plan-of pan) (beam-of pan))
+ (setf (sl:on chart-b) nil)))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((mp multileaf-coll-panel))
+
+ (let ((lb (leaf-button mp)))
+ (when (sl:on lb) (setf (sl:on lb) nil)))
+ (sl:destroy (leaf-button mp))
+ (sl:destroy (chart-button mp)))
+
+;;;---------------------------------------------
+
+(defclass electron-coll-panel (portal-coll-panel)
+
+ ((energy-button :accessor energy-button
+ :documentation "The button that provides a menu to
+select the energy of the electron beam.")
+
+ (cone-size-button :accessor cone-size-button
+ :documentation "The button that provides a menu
+to select the cone size from the available ones.")
+
+ (open-portal-button :accessor open-portal-button
+ :documentation "Pressing this button resets the
+ portal contour to match the cone opening.")
+
+ (contour-button :accessor contour-button
+ :documentation "The button that brings up and
+removes the contour editor panel for drawing the electron cutout
+contour.")
+
+ (contour-ed :accessor contour-ed
+ :initform nil
+ :documentation "A slot for the contour editor that
+appear on the screen on demand for cutout editing.")
+
+ (bev :accessor bev
+ :initform nil
+ :documentation "A beam's eye view that is not displayed but
+used as the background for the cutout contour editor.")
+
+ (image-mediator :accessor image-mediator
+ :initform nil
+ :documentation "A single image-view-mediator to
+manage creation of DRR images as necessary for the view background.")
+
+ (window-control :accessor window-control
+ :documentation "The textline that displays and sets
+the window for the background view's image.")
+
+ (level-control :accessor level-control
+ :documentation "The textline that displays and sets
+the level for the background view's image.")
+
+ (image-button :accessor image-button
+ :documentation "The button that toggles display of
+image data in this view.")
+
+ (fg-button :accessor fg-button
+ :documentation "Brings up a popup menu of objects in the
+view to display them or not on a view by view basis.")
+
+ (viewlist-panel :accessor viewlist-panel
+ :initform nil
+ :documentation "Temporarily holds the list of
+objects visible on the screen.")
+
+ )
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod make-collimator-panel ((coll electron-coll) &rest initargs)
+
+ (apply #'make-instance 'electron-coll-panel
+ :coll-for coll :allow-other-keys t initargs))
+
+;;;---------------------------------------------
+
+(defun refresh-portal-editor (pan)
+
+ "Draws the background - everything but the portal being edited, and
+adds the electron cone square to the planar editor background.
+This is done by the electron beam draw method, but this beam is not
+drawn in the portal editor background view by bev-draw-all."
+
+ (let* ((bm (beam-of pan))
+ (coll (coll-for pan))
+ (side (* 0.5 (cone-size coll)))
+ (bev (bev pan))
+ (color (sl:color-gc (display-color bm)))
+ (prim (find coll (foreground bev) :key #'object))
+ (pts (pixel-contour (poly:rotate-vertices
+ (counter-clockwise-rectangle
+ (- side) (- side) side side)
+ (collimator-angle bm))
+ (scale bev)
+ (x-origin bev)
+ (y-origin bev))))
+ (bev-draw-all bev (plan-of pan) (patient-of pan) bm)
+ (unless prim
+ (setq prim (make-lines-prim nil color :object coll))
+ (push prim (foreground bev)))
+ (setf (color prim) color ;; note - points is a list of lists
+ (points prim) (list (nconc pts (list (first pts)
+ (second pts)))))
+ (display-view bev)) ;; redraw the primitives into the pixmap
+ (display-planar-editor (contour-ed pan)))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((cp electron-coll-panel)
+ &rest initargs)
+
+ (let* ((btw 120) ;; magic numbers for button size etc.
+ (bth 25)
+ (ulc-x 10) ;; was (floor (- *coll-pan-width* btw) 2))
+ (mid-x (floor *coll-pan-width* 2))
+ (size large) ;; size of drawing area
+ (fr (panel-frame cp))
+ (win (sl:window fr))
+ (font (sl:font fr)) ;; use font provided or defaulted
+ (coll (coll-for cp))
+ (energy-b (apply #'sl:make-button btw bth
+ :label (format nil "ENERGY: ~4,1F"
+ (energy coll))
+ :parent win :font font
+ :ulc-x ulc-x :ulc-y 100 ;; below portal SFD button
+ initargs))
+ (cone-b (apply #'sl:make-button btw bth
+ :label (format nil "CONE: ~4,1F"
+ (cone-size coll))
+ :parent win :font font
+ :ulc-x ulc-x :ulc-y 135 ;; below energy button
+ initargs))
+ (open-b (apply #'sl:make-button btw bth
+ :label "OPEN PORTAL"
+ :parent win :font font
+ :ulc-x ulc-x :ulc-y 175 ;; below cone size button
+ initargs))
+ (cont-b (apply #'sl:make-button btw bth
+ :label "CUTOUT CONTOUR" :parent win :font font
+ :ulc-x ulc-x :ulc-y 235 ;; below open portal button
+ initargs))
+ (bev (make-view size size 'beams-eye-view
+ :beam-for (beam-of cp)
+ :display-func
+ #'(lambda (vw)
+ (setf (image-cache vw) nil)
+ (draw (image (image-mediator cp)) vw)
+ (display-view vw)
+ (when (contour-ed cp)
+ (display-planar-editor (contour-ed cp)))))))
+ ;; install and connect up to the collimator settings
+ (setf (energy-button cp) energy-b
+ (open-portal-button cp) open-b
+ (contour-button cp) cont-b
+ (bev cp) bev)
+ (setf (fg-button cp) (apply #'sl:make-button btw bth
+ :font font :label "Objects" :parent win
+ :ulc-x mid-x :ulc-y 100
+ initargs))
+ (setf (image-button cp) (apply #'sl:make-button btw bth
+ :font font :label "Image" :parent win
+ :ulc-x mid-x :ulc-y 135
+ initargs))
+ (setf (window-control cp)
+ (apply #'sl:make-sliderbox btw bth 1.0 2047.0 9999.0
+ :parent win :font font :label "Win: "
+ :ulc-x (- mid-x 5) :ulc-y 170
+ :border-width 0 :display-limits nil initargs))
+ (setf (level-control cp)
+ (apply #'sl:make-sliderbox btw bth 1.0 4095.0 9999.0
+ :parent win :font font :label "Lev: "
+ :ulc-x (- mid-x 5) :ulc-y 230
+ :border-width 0 :display-limits nil initargs))
+ (setf (sl:setting (window-control cp)) (coerce (window bev) 'single-float))
+ (setf (sl:setting (level-control cp)) (coerce (level bev) 'single-float))
+ (ev:add-notify cp (sl:button-on energy-b)
+ #'(lambda (pan bt)
+ (let* ((energies (energies (collimator-info
+ (machine (beam-of pan)))))
+ (e-num (sl:popup-menu
+ (mapcar #'write-to-string energies))))
+ (when e-num
+ (setf (energy (coll-for pan))
+ (nth e-num energies))))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify cp (new-energy coll)
+ #'(lambda (pan col new-en)
+ (declare (ignore col))
+ (setf (sl:label (energy-button pan))
+ (format nil "ENERGY: ~4,1F" new-en))))
+ (setf (cone-size-button cp) cone-b)
+ (ev:add-notify cp (sl:button-on cone-b)
+ #'(lambda (pan bt)
+ (let* ((cones (cone-sizes (collimator-info
+ (machine (beam-of pan)))))
+ (size-no (sl:popup-menu
+ (mapcar #'write-to-string cones))))
+ (when size-no
+ (setf (cone-size (coll-for pan))
+ (nth size-no cones))))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify cp (sl:button-on open-b)
+ #'(lambda (pan bt)
+ (let* ((coll (coll-for pan))
+ (size (* 0.5 (cone-size coll))))
+ (setf (vertices coll)
+ (counter-clockwise-rectangle (- size) (- size)
+ size size))
+ (when (contour-ed pan)
+ (setf (vertices (contour-ed pan))
+ (poly:rotate-vertices
+ (vertices coll)
+ (collimator-angle (beam-of pan))))
+ (refresh-portal-editor pan)))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify cp (new-cone-size coll)
+ #'(lambda (pan col new-size)
+ (declare (ignore col))
+ (setf (sl:label (cone-size-button pan))
+ (format nil "CONE: ~4,1F" new-size))
+ (when (contour-ed pan)
+ (refresh-portal-editor pan))))
+ (ev:add-notify cp (sl:new-info (sfd-box cp))
+ #'(lambda (pan tl info)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (let ((fd (coerce (read-from-string info)
+ 'single-float)))
+ (setf (filmdist pan) fd)
+ (setf (sl:info tl) (format nil "~5,1F" fd))
+ (when (contour-ed pan)
+ (setf (digitizer-mag (contour-ed pan))
+ (/ fd (isodist (beam-of pan))))))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:button-on (image-button cp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (bev pan)) t)
+ (if (contour-ed pan) (refresh-portal-editor pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:button-off (image-button cp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (bev pan)) nil)
+ (if (contour-ed pan) (refresh-portal-editor pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:button-2-on (image-button cp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (case (drr-state (bev pan))
+ ;;'stopped is a noop
+ ('running (setf (drr-state (bev pan)) 'paused))
+ ('paused (setf (drr-state (bev pan)) 'running)
+ (drr-bg (bev pan))))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:button-on (fg-button cp))
+ #'(lambda (pan bt)
+ (if (contour-ed pan)
+ (progn
+ (setf (viewlist-panel pan)
+ (make-instance 'viewlist-panel
+ :refresh-fn #'(lambda (vw)
+ (display-view vw)
+ (display-planar-editor
+ (contour-ed pan)))
+ :view (bev pan)))
+ (ev:add-notify pan (deleted (viewlist-panel pan))
+ #'(lambda (pnl vlpnl)
+ (declare (ignore vlpnl))
+ (setf (viewlist-panel pnl)
+ nil)
+ (when (not (busy pnl))
+ (setf (busy pnl) t)
+ (setf (sl:on bt) nil)
+ (setf (busy pnl) nil)))))
+ (progn
+ (setf (busy pan) t)
+ (setf (sl:on bt) nil)
+ (setf (busy pan) nil)))))
+ (ev:add-notify cp (sl:button-off (fg-button cp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (viewlist-panel pan))
+ (setf (busy pan) nil))))
+ (if (image-set (patient-of cp))
+ (setf (image-mediator cp)
+ (make-image-view-mediator (image-set (patient-of cp)) bev)))
+ (setf (image-button bev) (image-button cp))
+ (setf (drr-state bev) (drr-state bev)) ;; to init the button
+ (ev:add-notify cp (bg-toggled bev)
+ #'(lambda (pan vw)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:on (image-button pan))
+ (background-displayed vw))
+ (setf (busy pan) nil))))
+ (ev:add-notify cp (sl:button-on cont-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (let* ((coll (coll-for pan))
+ (bm (beam-of pan))
+ (bev (bev pan))
+ (ce (make-planar-editor
+ :vertices (vertices coll)
+ :background (sl:pixmap (picture bev))
+ :x-origin (/ size 2)
+ :y-origin (/ size 2)
+ :scale (scale bev)
+ :title (format nil
+ "Beam Portal for ~A"
+ (name bm))
+ :digitizer-mag (/ (filmdist pan)
+ (isodist bm))
+ :color (sl:color-gc
+ (display-color bm)))))
+ (setf (contour-ed pan) ce)
+ (refresh-portal-editor pan)
+ (ev:add-notify pan (new-coll-set coll)
+ #'(lambda (pnl col)
+ (unless (busy pnl)
+ (setf (busy pnl) t)
+ (setf (vertices
+ (contour-ed pnl))
+ (poly:rotate-vertices
+ (vertices col)
+ (collimator-angle bm)))
+ (setf (busy pnl) nil))))
+ (ev:add-notify pan (new-color (beam-of cp))
+ #'(lambda (pnl bm newcolor)
+ (declare (ignore bm))
+ (setf (color (contour-ed pnl))
+ (sl:color-gc newcolor))
+ (refresh-portal-editor pnl)))
+ (ev:add-notify pan (new-vertices ce)
+ #'(lambda (pnl ced new-verts)
+ (declare (ignore ced))
+ (unless (busy pnl)
+ (setf (busy pnl) t)
+ (setf (vertices
+ (coll-for pnl))
+ (poly:rotate-vertices
+ new-verts
+ (- (collimator-angle
+ (beam-of pnl)))))
+ (setf (busy pnl) nil))))
+ (ev:add-notify pan (new-coll-angle (beam-of cp))
+ #'(lambda (pnl bm new-ang)
+ (declare (ignore bm new-ang))
+ ;; (setf (vertices
+ ;; (contour-ed pnl))
+ ;; (poly:rotate-vertices
+ ;; (vertices (contour-ed pnl))
+ ;; (- new-ang old-ang)))
+ (refresh-portal-editor pnl)))
+ (ev:add-notify pan (new-scale ce)
+ #'(lambda (pnl ced new-sc)
+ (declare (ignore ced))
+ (let ((bev (bev pnl)))
+ (setf (scale bev) new-sc)
+ (refresh-portal-editor pnl))))
+ (ev:add-notify pan (new-origin ce)
+ #'(lambda (pnl ced new-org)
+ (declare (ignore ced))
+ (let ((bev (bev pnl)))
+ (setf (origin bev) new-org)
+ (refresh-portal-editor pnl))))
+
+ (ev:add-notify pan (sl:value-changed
+ (window-control pan))
+ #'(lambda (pnl wc win)
+ (declare (ignore wc))
+ (setf (window (bev pnl))
+ (round win))
+ (if (background-displayed
+ (bev pnl))
+ (display-planar-editor
+ (contour-ed pnl)))))
+ (ev:add-notify pan (sl:value-changed
+ (level-control pan))
+ #'(lambda (pnl lc lev)
+ (declare (ignore lc))
+ (setf (level (bev pnl))
+ (round lev))
+ (if (background-displayed
+ (bev pnl))
+ (display-planar-editor
+ (contour-ed pnl)))))
+ )))
+ (ev:add-notify cp (sl:button-off cont-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (ev:remove-notify pan (sl:value-changed
+ (window-control pan)))
+ (ev:remove-notify pan (sl:value-changed
+ (level-control pan)))
+ (ev:remove-notify pan (new-coll-set (coll-for pan)))
+ (ev:remove-notify pan (new-color (beam-of pan)))
+ (ev:remove-notify pan (new-coll-angle (beam-of pan)))
+ (destroy (contour-ed pan))
+ (setf (contour-ed pan) nil)
+ (when (viewlist-panel pan)
+ (destroy (viewlist-panel pan)))))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((cp electron-coll-panel))
+
+ (let ((vw (bev cp)))
+ (when vw
+ ;; ensure that there are not any lingering
+ ;; background jobs for this view-panel
+ (remove-bg-drr vw)
+ (when (eq 'running (drr-state vw))
+ (setf (drr-state vw) 'paused))
+ (setf (image-button vw) nil)))
+ (let ((cb (contour-button cp)))
+ (when (sl:on cb) (setf (sl:on cb) nil)))
+ (if (image-mediator cp) (destroy (image-mediator cp)))
+ (if (bev cp) (destroy (bev cp)))
+ (sl:destroy (contour-button cp))
+ (sl:destroy (image-button cp))
+ (sl:destroy (window-control cp))
+ (sl:destroy (level-control cp))
+ (if (sl:on (fg-button cp)) (setf (sl:on (fg-button cp)) nil))
+ (sl:destroy (fg-button cp))
+ (ev:remove-notify cp (new-energy (coll-for cp)))
+ (sl:destroy (energy-button cp))
+ (ev:remove-notify cp (new-cone-size (coll-for cp)))
+ (sl:destroy (cone-size-button cp)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/collim-info.cl b/prism/src/collim-info.cl
new file mode 100644
index 0000000..fc3c08c
--- /dev/null
+++ b/prism/src/collim-info.cl
@@ -0,0 +1,269 @@
+;;;
+;;; collim-info
+;;;
+;;; contains the stuff defining names of collimator jaws or mlc
+;;; leaves, etc.
+;;;
+;;; 10-May-1994 J. Unger Add definitions for the collim-info objects.
+;;; 05-Aug-1994 J. Unger add cnts-collim-info class definition.
+;;; 23-Aug-1994 J. Jacky change centerline-list to edge-list
+;;; 5-Jan-1996 I. Kalet split off from therapy-machines, add
+;;; electron-collim-info and srs-collim-info.
+;;; 17-Dec-1998 I. Kalet add energies to electron-collim-info.
+;;; 10-Sep-2000 I. Kalet remove srs collimator, now obsolete. Revise
+;;; for new MLC representation. Downcase names.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defclass symmetric-jaw-collim-info ()
+
+ ((x-name :type string
+ :initarg :x-name
+ :accessor x-name
+ :documentation "Name of the x-axis collimator jaw.")
+
+ (y-name :type string
+ :initarg :y-name
+ :accessor y-name
+ :documentation "Name of the y-axis collimator jaw.")
+ )
+
+ (:documentation "Supplemental collimator attribute and value
+information for symmetric jaw collimators.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defun make-symmetric-jaw-collim-info (&rest initargs)
+
+ "make-symmetric-jaw-collim-info &rest initargs)
+
+Creates and returns a symmetric-jaw-collim-info object with the
+specified initialization args."
+
+ (apply #'make-instance 'symmetric-jaw-collim-info initargs))
+
+;;;--------------------------------------------------
+
+(defclass combination-collim-info ()
+
+ ((x-inf-name :type string
+ :initarg :x-inf-name
+ :accessor x-inf-name
+ :documentation "Name of the x-axis inferior collimator
+jaw.")
+
+ (x-sup-name :type string
+ :initarg :x-sup-name
+ :accessor x-sup-name
+ :documentation "Name of the x-axis superior collimator
+jaw.")
+
+ (x-sym-name :type string
+ :initarg :x-sym-name
+ :accessor x-sym-name
+ :documentation "Name of the x-axis collimator jaw when
+the superior and inferior jaws are the same distance from the central
+axis.")
+
+ (y-name :type string
+ :initarg :y-name
+ :accessor y-name
+ :documentation "Name of the y-axis collimator jaw.")
+ )
+
+ (:documentation "Supplemental collimator attribute and value
+information for combination jaw collimators.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defun make-combination-collim-info (&rest initargs)
+
+ "make-combination-collim-info &rest initargs)
+
+Creates and returns a combination-collim-info object with the
+specified initialization args."
+
+ (apply #'make-instance 'combination-collim-info initargs))
+
+;;;--------------------------------------------------
+
+(defclass asymmetric-jaw-collim-info ()
+
+ ((x-inf-name :type string
+ :initarg :x-inf-name
+ :accessor x-inf-name
+ :documentation "Name of the x-axis inferior collimator
+jaw.")
+
+ (x-sup-name :type string
+ :initarg :x-sup-name
+ :accessor x-sup-name
+ :documentation "Name of the x-axis superior collimator
+jaw.")
+
+ (y-inf-name :type string
+ :initarg :y-inf-name
+ :accessor y-inf-name
+ :documentation "Name of the y-axis inferior collimator
+jaw.")
+
+ (y-sup-name :type string
+ :initarg :y-sup-name
+ :accessor y-sup-name
+ :documentation "Name of the y-axis superior collimator
+jaw.")
+
+ )
+
+ (:documentation "Supplemental collimator attribute and value
+information for asymmetric jaw collimators.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defun make-asymmetric-jaw-collim-info (&rest initargs)
+
+ "make-asymmetric-jaw-collim-info &rest initargs)
+
+Creates and returns an asymmetric-jaw-collim-info object with the
+specified initialization args."
+
+ (apply #'make-instance 'asymmetric-jaw-collim-info initargs))
+
+;;;--------------------------------------------------
+
+(defclass multileaf-collim-info ()
+
+ ((col-headings :type string
+ :initarg :col-headings
+ :accessor col-headings
+ :documentation "A string, a line of text up to a page
+wide, including all the column headings for the leaf setting page of
+the chart.")
+
+ (num-leaf-pairs :type fixnum
+ :initarg :num-leaf-pairs
+ :accessor num-leaf-pairs
+ :documentation "The number of leaf pairs for the MLC.")
+
+ (edge-list :type list
+ :initarg :edge-list
+ :accessor edge-list
+ :documentation "A list of Y-coordinates of the
+edge of leaf travel for each leaf pair in the MLC, starting at
+the most positive Y-coordinate, which appears as the first line toward
+the top of the printout page. For a collimator of N leaves, there are N+1
+edge coordinates in the list")
+
+ (leaf-pair-map :type list
+ :initarg :leaf-pair-map
+ :accessor leaf-pair-map
+ :documentation "A list of (left-label right-label)
+pairs, both elements strings. The Nth pair of the list represents the
+labels to print on the left and right sides of the Nth row from the
+top of the MLC page of the chart.")
+
+ (inf-leaf-scale :type single-float
+ :initarg :inf-leaf-scale
+ :accessor inf-leaf-scale
+ :documentation "The inferior leaf scale factor, one
+of -1.0 or 1.0")
+
+ (leaf-open-limit :type single-float
+ :initarg :leaf-open-limit
+ :accessor leaf-open-limit
+ :documentation "Maximum value of leaf opening away
+from centerline, in CM. Absolute value, always positive")
+
+ (leaf-overcenter-limit :type single-float
+ :initarg :leaf-overcenter-limit
+ :accessor leaf-overcenter-limit
+ :documentation "Maximum value of leaf
+overcentering past centerline, in CM. Absolute value, always positive
+or zero")
+
+ )
+
+ (:documentation "Supplemental collimator attribute and value
+information for multileaf collimators.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defun make-multileaf-collim-info (&rest initargs)
+
+ "make-multileaf-collim-info &rest initargs)
+
+Creates and returns a multileaf-collim-info object with the specified
+initialization args."
+
+ (apply #'make-instance 'multileaf-collim-info initargs))
+
+;;;--------------------------------------------------
+
+(defclass cnts-collim-info (asymmetric-jaw-collim-info multileaf-collim-info)
+
+ ()
+
+ (:documentation "The cnts collim-info class inherits all attributes
+and from both the asymmetric-jaw-collim-info and multileaf-collim-info
+classes.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defun make-cnts-collim-info (&rest initargs)
+
+ "make-cnts-collim-info &rest initargs)
+
+Creates and returns a cnts-collim-info object with the specified
+initialization args."
+
+ (apply #'make-instance 'cnts-collim-info initargs))
+
+;;;--------------------------------------------------
+
+(defclass electron-collim-info ()
+
+ ((energies :type list
+ :initarg :energies
+ :accessor energies
+ :documentation "A list of nominal electron energies
+ available for this electron machine.")
+
+ (cone-sizes :type list
+ :initarg :cone-sizes
+ :accessor cone-sizes
+ :documentation "A list of cone sizes available for this
+electron machine.")
+
+ )
+
+ (:documentation "The electron collim-info class provides information
+about the available electron energies and cones for this machine.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defun make-electron-collim-info (&rest initargs)
+
+ "make-electron-collim-info &rest initargs)
+
+Creates and returns an electron-collim-info object with the specified
+initialization args."
+
+ (apply #'make-instance 'electron-collim-info initargs))
+
+;;;--------------------------------------------------
+;;; End.
diff --git a/prism/src/collimators.cl b/prism/src/collimators.cl
new file mode 100644
index 0000000..5216b33
--- /dev/null
+++ b/prism/src/collimators.cl
@@ -0,0 +1,673 @@
+;;;
+;;; collimators
+;;;
+;;; Definitions of collimators for radiation beams, and their methods.
+;;;
+;;; 18-Jan-1993 I. Kalet separated from beams module to prevent cycle
+;;; 11-Apr-1993 I. Kalet add events for collimator setting updates
+;;; 16-Apr-1993 I. Kalet add collimator panels
+;;; 27-Apr-1993 I. Kalet take out unnecessary function
+;;; 31-Jul-1993 I. Kalet add not-saved methods
+;;; 18-Aug-1993 I. Kalet fix error in replace-coll
+;;; 5-Sep-1993 I. Kalet move panel code to coll-panels
+;;; 30-Dec-1993 I. Kalet add full support for multileaf collimators
+;;; 18-May-1994 I. Kalet add beam-for to multileaf collimator, add
+;;; beam parameter to replace-coll, finally move beam-blocks out.
+;;; 3-Jun-1994 J. Unger redefine attributes of combination-coll, edit
+;;; code involving combination-coll.
+;;; 23-Jun-1994 I. Kalet change floats to single-floats.
+;;; 05-Aug-1994 J. Unger add cnts-coll class definition.
+;;; 11-Aug-1994 J. Unger make slight mods to replace-coll.
+;;; 24-Aug-1994 J. Unger add leaf-settings attr to cnts-coll.
+;;; 29-Aug-1994 J. Unger make cnts-coll's leaf-settings and all coll's
+;;; names not saved.
+;;; 11-Jan-1995 I. Kalet put copy-coll methods here, not in beams.
+;;; Make replace-coll a generic function. Eliminate back pointers to
+;;; beam-for everywhere. Put slot-type ignore for beam-for.
+;;; 1-Sep-1995 I. Kalet small optimizations in portal methods
+;;; 5-Jan-1996 I. Kalet add portal-coll, electron-coll, srs-coll
+;;; 4-Feb-1997 I. Kalet add methods for coll-length, coll-width,
+;;; change portal methods to return only vertices, not a contour obj.
+;;; 21-May-1997 I. Kalet move replace-coll to separate module, to make
+;;; adding collimator types easier.
+;;; 21-Jun-1997 BobGian add x-inf-coord, y-sup-coord, etc, methods to
+;;; return portal edges (jaw coordinates) independently of jaw type
+;;; for symmetric-jaw, variable-jaw, and combination collimators.
+;;; Reasons: (1) no consing (as the portal method does),
+;;; (2) naming uniformity (same name used for all coll types).
+;;; 21-Jun-1997 BobGian make (* 2.0 (coerce pi 'single-float))
+;;; be read-time-evaluated via sharpsign-dot, and reverse -> nreverse,
+;;; both efficiency hacks, in (defmethod portal ((coll srs-coll)).
+;;; 25-Aug-1997 BobGian changed #.(expression (coerce pi 'single-float))
+;;; to #.(coerce (expression pi))
+;;; that is, do math in double-precision first and then coerce to
+;;; single-float at end, all inside read-time computation.
+;;; 1-Sep-1997 BobGian simplified coll-width and coll-length methods for
+;;; multileaf collimators - no need for absolute value.
+;;; 3-Sep-1997 BobGian changed x-inf-coord, x-sup-coord ("x" is "x" or "y"),
+;;; four separate methods, to single method coll-coords for each collimator
+;;; type. Method for mlcs returns portal vertices. Used only in beam-dose.
+;;; 13-Mar-1998 BobGian remove coll-width and coll-length methods for mlc
+;;; since the information needed to compute bounding box on an mlc is not
+;;; available to the collimator object.
+;;; 18-Dec-1998 I. Kalet add energy to electron collimator, really
+;;; belongs to beam, but fits better here.
+;;; 9-Feb-2000 BobGian add new-energy to not-saved for electron-coll.
+;;; 13-Feb-2000 I. Kalet copy-coll for portal collimators (mlc and
+;;; electrons) copies or reflects portal vertices only for gantry delta
+;;; 0 or 180, otherwise just resets to 10 by 10 square.
+;;; 22-Feb-2000 I. Kalet replace copy-coll with just copy methods,
+;;; that return new instances of collimator objects. Defer the
+;;; reflection etc. to the place where needed.
+;;; 10-Sep-2000 I. Kalet remove support for obsolete srs collimator.
+;;; Modify multileaf collimator to include diaphragm jaws and make leaf
+;;; settings canonical instead of portal contour.
+;;; 11-Jun-2001 BobGian replace type-specific arithmetic macros
+;;; with THE declarations.
+;;; 19-Jun-2001 I. Kalet add to not-saved method for multileaf-coll.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defmacro counter-clockwise-rectangle (left bottom right top)
+
+ `(list (list (the single-float ,left) (the single-float ,bottom))
+ (list (the single-float ,right) (the single-float ,bottom))
+ (list (the single-float ,right) (the single-float ,top))
+ (list (the single-float ,left) (the single-float ,top))))
+
+;;;---------------------------------------------
+
+(defclass collimator (generic-prism-object)
+
+ ((new-coll-set :type ev:event
+ :accessor new-coll-set
+ :initform (ev:make-event)
+ :documentation "Announced when any of the collimator
+settings changes, so some entities need only register with this event,
+not with all the individual collimator settings.")
+
+ )
+
+ (:documentation "The base collimator class just provides this simple
+forwarding event.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((coll collimator))
+
+ (append (call-next-method) '(name new-coll-set)))
+
+;;;---------------------------------------------
+
+(defclass symmetric-jaw-coll (collimator)
+
+ ((x :type single-float
+ :accessor x
+ :initarg :x)
+
+ (y :type single-float
+ :accessor y
+ :initarg :y)
+
+ (new-coll-x :type ev:event
+ :accessor new-coll-x
+ :initform (ev:make-event)
+ :documentation "Announced when x is updated.")
+
+ (new-coll-y :type ev:event
+ :accessor new-coll-y
+ :initform (ev:make-event)
+ :documentation "Announced when y is updated.")
+
+ )
+
+ (:default-initargs :x 10.0 :y 10.0)
+
+ (:documentation "A symmetric jaw collimator system")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((coll symmetric-jaw-coll))
+
+ (append (call-next-method) '(new-coll-x new-coll-y)))
+
+;;;---------------------------------------------
+
+(defmethod coll-width ((coll symmetric-jaw-coll))
+
+ (x coll))
+
+(defmethod coll-length ((coll symmetric-jaw-coll))
+
+ (y coll))
+
+;;;---------------------------------------------
+
+(defmethod coll-coords ((coll symmetric-jaw-coll))
+ ;;
+ ;; Returns first value nil and all 4 jaw coordinates. First return
+ ;; value means this is not an mlc [or other portal collimator subtype]
+ ;; and therefore we can use blocking with this collimator type.
+ ;;
+ (let ((xval (* 0.5 (the single-float (x coll))))
+ (yval (* 0.5 (the single-float (y coll)))))
+ (declare (single-float xval yval))
+ (values nil
+ (- xval)
+ xval
+ (- yval)
+ yval)))
+
+;;;---------------------------------------------
+
+(defmethod (setf x) :after (new-x (coll symmetric-jaw-coll))
+
+ (ev:announce coll (new-coll-x coll) new-x)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf y) :after (new-y (coll symmetric-jaw-coll))
+
+ (ev:announce coll (new-coll-y coll) new-y)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod portal ((coll symmetric-jaw-coll))
+
+ "Creates a simple rectangular CCW contour centered on the isocenter,
+with width x, and height y."
+
+ (let ((xval (* 0.5 (the single-float (x coll))))
+ (yval (* 0.5 (the single-float (y coll)))))
+ (declare (single-float xval yval))
+ (counter-clockwise-rectangle (- xval) (- yval) xval yval)))
+
+;;;---------------------------------------------
+
+(defmethod copy ((old-col symmetric-jaw-coll))
+
+ (make-instance 'symmetric-jaw-coll :x (x old-col) :y (y old-col)))
+
+;;---------------------------------------------
+
+(defclass variable-jaw-coll (collimator)
+
+ ((x-sup :type single-float
+ :accessor x-sup
+ :initarg :x-sup)
+
+ (y-sup :type single-float
+ :accessor y-sup
+ :initarg :y-sup)
+
+ (x-inf :type single-float
+ :accessor x-inf
+ :initarg :x-inf)
+
+ (y-inf :type single-float
+ :accessor y-inf
+ :initarg :y-inf)
+
+ (new-coll-x-sup :type ev:event
+ :accessor new-coll-x-sup
+ :initform (ev:make-event)
+ :documentation "Announced when x-sup is updated.")
+
+ (new-coll-y-sup :type ev:event
+ :accessor new-coll-y-sup
+ :initform (ev:make-event)
+ :documentation "Announced when y-sup is updated.")
+
+ (new-coll-x-inf :type ev:event
+ :accessor new-coll-x-inf
+ :initform (ev:make-event)
+ :documentation "Announced when x-inf is updated.")
+
+ (new-coll-y-inf :type ev:event
+ :accessor new-coll-y-inf
+ :initform (ev:make-event)
+ :documentation "Announced when y-inf is updated.")
+
+ )
+
+ (:default-initargs :x-sup 5.0 :y-sup 5.0 :x-inf 5.0 :y-inf 5.0)
+
+ (:documentation "A collimator with independently movable jaws")
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((coll variable-jaw-coll))
+
+ (append (call-next-method)
+ '(new-coll-x-sup new-coll-y-sup
+ new-coll-x-inf new-coll-y-inf)))
+
+;;;---------------------------------------------
+
+(defmethod coll-width ((coll variable-jaw-coll))
+
+ (+ (the single-float (x-sup coll)) (the single-float (x-inf coll))))
+
+(defmethod coll-length ((coll variable-jaw-coll))
+
+ (+ (the single-float (y-sup coll)) (the single-float (y-inf coll))))
+
+;;;---------------------------------------------
+
+(defmethod coll-coords ((coll variable-jaw-coll))
+
+ "Returns multiple values, nil and all 4 jaw coordinates. First
+return value means this is NOT an MLC [or other portal collimator
+subtype] and therefore we CAN use blocking with this collimator type."
+
+ (values nil
+ (- (the single-float (x-inf coll)))
+ (x-sup coll)
+ (- (the single-float (y-inf coll)))
+ (y-sup coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf x-sup) :after (new-x (coll variable-jaw-coll))
+
+ (ev:announce coll (new-coll-x-sup coll) new-x)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf y-sup) :after (new-y (coll variable-jaw-coll))
+
+ (ev:announce coll (new-coll-y-sup coll) new-y)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf x-inf) :after (new-x (coll variable-jaw-coll))
+
+ (ev:announce coll (new-coll-x-inf coll) new-x)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf y-inf) :after (new-y (coll variable-jaw-coll))
+
+ (ev:announce coll (new-coll-y-inf coll) new-y)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod portal ((coll variable-jaw-coll))
+
+ "Creates a simple rectangular CCW contour with width the difference of
+x-sup and x-inf, and height the difference of y-sup and y-inf."
+
+ (counter-clockwise-rectangle (- (the single-float (x-inf coll)))
+ (- (the single-float (y-inf coll)))
+ (x-sup coll)
+ (y-sup coll)))
+
+;;;---------------------------------------------
+
+(defmethod copy ((old-col variable-jaw-coll))
+
+ (make-instance 'variable-jaw-coll
+ :x-inf (x-inf old-col) :x-sup (x-sup old-col)
+ :y-inf (y-inf old-col) :y-sup (y-sup old-col)))
+
+;;;---------------------------------------------
+
+(defclass cnts-coll (variable-jaw-coll)
+
+ ((leaf-settings :accessor leaf-settings
+ :initarg :leaf-settings
+ :initform nil
+ :documentation "A list of numbers corresponding to
+the leaf settings that will best match the portal contour -- a cache
+used in the code that writes a cnts-collimator field to the neutron
+file.")
+
+ )
+
+ (:documentation "A cnts-coll is a variable-jaw collimator with leaf
+settings.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((coll cnts-coll))
+
+ (append (call-next-method) '(leaf-settings)))
+
+;;;---------------------------------------------
+
+(defmethod slot-type ((object cnts-coll) slotname)
+
+ (case slotname
+ (beam-for :ignore)
+ (otherwise (call-next-method))))
+
+;;;---------------------------------------------
+
+(defmethod copy ((old-col cnts-coll))
+
+ (make-instance 'cnts-coll
+ :leaf-settings (leaf-settings old-col)
+ :x-inf (x-inf old-col) :x-sup (x-sup old-col)
+ :y-inf (y-inf old-col) :y-sup (y-sup old-col)))
+
+;;;---------------------------------------------
+
+(defclass combination-coll (collimator)
+
+ ((x-inf :type single-float
+ :accessor x-inf
+ :initarg :x-inf)
+
+ (x-sup :type single-float
+ :accessor x-sup
+ :initarg :x-sup)
+
+ (y :type single-float
+ :accessor y
+ :initarg :y)
+
+ (new-coll-x-inf :type ev:event
+ :accessor new-coll-x-inf
+ :initform (ev:make-event)
+ :documentation "Announced when x-inf is updated.")
+
+ (new-coll-x-sup :type ev:event
+ :accessor new-coll-x-sup
+ :initform (ev:make-event)
+ :documentation "Announced when x-sup is updated.")
+
+ (new-coll-y :type ev:event
+ :accessor new-coll-y
+ :initform (ev:make-event)
+ :documentation "Announced when y is updated.")
+
+ )
+
+ (:default-initargs :x-sup 5.0 :x-inf 5.0 :y 10.0)
+
+ (:documentation "A collimator with only one set of independently
+movable jaws.")
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((coll combination-coll))
+
+ (append (call-next-method)
+ '(new-coll-x-inf new-coll-x-sup new-coll-y)))
+
+;;;---------------------------------------------
+
+(defmethod coll-width ((coll combination-coll))
+
+ (+ (the single-float (x-sup coll)) (the single-float (x-inf coll))))
+
+(defmethod coll-length ((coll combination-coll))
+
+ (y coll))
+
+;;;---------------------------------------------
+
+(defmethod coll-coords ((coll combination-coll))
+
+ "Returns first value NIL and all 4 jaw coordinates. First return
+value means this is NOT an MLC [or other portal collimator subtype]
+and therefore we CAN use blocking with this collimator type."
+
+ (let ((yval (* 0.5 (the single-float (y coll)))))
+ (declare (single-float yval))
+ (values nil
+ (- (the single-float (x-inf coll)))
+ (x-sup coll)
+ (- yval)
+ yval)))
+
+;;;---------------------------------------------
+
+(defmethod (setf x-inf) :after (new-x-inf (coll combination-coll))
+
+ (ev:announce coll (new-coll-x-inf coll) new-x-inf)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf x-sup) :after (new-x-sup (coll combination-coll))
+
+ (ev:announce coll (new-coll-x-sup coll) new-x-sup)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf y) :after (new-y (coll combination-coll))
+
+ (ev:announce coll (new-coll-y coll) new-y)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod portal ((coll combination-coll))
+
+ "Creates a simple rectangular CCW contour with width the difference of
+x-sup and x-inf, and height y."
+
+ (let ((bottom (* 0.5 (the single-float (y coll)))))
+ (declare (single-float bottom))
+ (counter-clockwise-rectangle (- (the single-float (x-inf coll)))
+ (- bottom)
+ (x-sup coll)
+ bottom)))
+
+;;;---------------------------------------------
+
+(defmethod copy ((old-col combination-coll))
+
+ (make-instance 'combination-coll
+ :x-inf (x-inf old-col) :x-sup (x-sup old-col)
+ :y (y old-col)))
+
+;;;---------------------------------------------
+
+(defclass portal-coll (collimator contour)
+
+ ()
+
+ (:default-initargs :z 0.0 :vertices '((-5.0 -5.0) ;; 10 by 10
+ (5.0 -5.0)
+ (5.0 5.0)
+ (-5.0 5.0)))
+
+ (:documentation "A collimator that includes a portal, e.g. multileaf
+or electron cone with cutout. It includes slots from class contour to
+define the portal contour. It therefore also will inherit methods for
+drawing contours. The contour is always at z = 0.0 .")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod coll-coords ((coll portal-coll))
+
+ "Returns portal vertex list and four dummy jaw coordinates. First
+return value [must be non-nil by spec] indicates that this is an mlc
+[or other portal collimator subtype] and we don't use blocking."
+
+ (values (vertices coll) 0.0 0.0 0.0 0.0))
+
+;;;---------------------------------------------
+
+(defmethod (setf vertices) :after (new-verts (coll portal-coll))
+
+ (declare (ignore new-verts))
+ (ev:announce coll (new-coll-set coll)))
+
+;;;----------------------------------------------
+
+(defmethod portal ((coll portal-coll))
+
+ "Returns the multivertex polygon contained in COLL as a vertex-list."
+
+ (vertices coll))
+
+;;;---------------------------------------------
+
+(defmethod copy ((old-col portal-coll))
+
+ (make-instance (class-of old-col)
+ :z (z old-col)
+ :vertices (mapcar #'(lambda (pt) (list (first pt) (second pt)))
+ (vertices old-col))))
+
+;;;---------------------------------------------
+
+(defclass multileaf-coll (portal-coll)
+
+ ((leaf-settings :accessor leaf-settings
+ :initarg :leaf-settings
+ :documentation "A list of numbers corresponding to
+the leaf settings that will best match the portal contour, or those
+chosen by the dosimetrist.")
+
+ (x1 :type single-float
+ :accessor x1
+ :documentation "DICOM X1 leaves, open in -x direction")
+
+ (x2 :type single-float
+ :accessor x2
+ :documentation "DICOM X2 leaves, open in +x direction")
+
+ (y1 :type single-float
+ :accessor y1
+ :documentation "DICOM Y1 leaves, open in -y direction")
+
+ (y2 :type single-float
+ :accessor y2
+ :documentation "DICOM Y2 leaves, open in +y direction")
+
+ )
+
+ ;; No init for jaws - used only in DICOM panel.
+ (:default-initargs :leaf-settings nil)
+
+ (:documentation "A multileaf collimator. It includes slots from
+class contour to define the portal contour. It therefore also will
+inherit methods for drawing contours. The contour is always at z = 0.0 .")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod slot-type ((object multileaf-coll) slotname)
+
+ (case slotname
+ (beam-for :ignore) ;; required from past history at UW
+ (otherwise :simple)))
+
+;;;----------------------------------------------
+
+;; The leaf-settings attribute for an mlc can probably be removed
+;; from the system. There are numerous instances of this attribute
+;; in existing files, however, so deleting this attribute will require
+;; a sweep through existing data files.
+
+(defmethod not-saved ((coll multileaf-coll))
+
+ (append (call-next-method) '(leaf-settings x1 y1 x2 y2)))
+
+;;;---------------------------------------------
+;;; coll-width and coll-length methods for multileaf-col were here, but
+;;; were deleted since they can only return the correct bounding box
+;;; approximation to the MLC portal by knowing the collimator angle,
+;;; which is not available to the collimator object.
+;;;---------------------------------------------
+
+(defclass electron-coll (portal-coll)
+
+ ((energy :type single-float
+ :accessor energy
+ :initarg :energy
+ :documentation "A single electron machine includes a range
+ of energies, and the one selected is recorded here.")
+
+ (new-energy :type ev:event
+ :accessor new-energy
+ :initform (ev:make-event)
+ :documentation "Announced when energy is changed.")
+
+ (cone-size :type single-float
+ :accessor cone-size
+ :initarg :cone-size
+ :documentation "An electron collimator is a square cone
+with possibly a metal cutout fastened to it.")
+
+ (new-cone-size :type ev:event
+ :accessor new-cone-size
+ :initform (ev:make-event)
+ :documentation "Announced when cone size is changed.")
+
+ )
+
+ (:default-initargs :energy 10.0 :cone-size 10.0)
+
+ (:documentation "This collimator models the use of the electron
+beam. A single electron machine has a series of energies, so we
+include energy selection with the electron collimator.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((coll electron-coll))
+
+ (append (call-next-method) '(new-energy new-cone-size)))
+
+;;;---------------------------------------------
+
+(defmethod coll-width ((coll electron-coll))
+
+ (cone-size coll))
+
+(defmethod coll-length ((coll electron-coll))
+
+ (cone-size coll))
+
+;;;---------------------------------------------
+
+(defmethod (setf energy) :after (new-e (coll electron-coll))
+
+ (ev:announce coll (new-energy coll) new-e)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod (setf cone-size) :after (new-size (coll electron-coll))
+
+ (ev:announce coll (new-cone-size coll) new-size)
+ (ev:announce coll (new-coll-set coll)))
+
+;;;---------------------------------------------
+
+(defmethod copy ((old-col electron-coll))
+
+ (let ((new-col (call-next-method)))
+ (setf (energy new-col) (energy old-col))
+ (setf (cone-size new-col) (cone-size old-col))
+ new-col))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/contours.cl b/prism/src/contours.cl
new file mode 100644
index 0000000..1f0e8fd
--- /dev/null
+++ b/prism/src/contours.cl
@@ -0,0 +1,75 @@
+;;;
+;;; contours
+;;;
+;;; Defines polylines and contours and their methods
+;;;
+;;; 7-Sep-1992 I. Kalet taken initially from old volumes module
+;;; 23-Jul-1993 I. Kalet move make-contour here from easel
+;;; 3-Sep-1993 I. Kalet move draw methods to contour-graphics, marks
+;;; to points module
+;;; 16-Jun-1994 I. Kalet change float to single-float
+;;; 2-Jul-1997 BobGian modify :documentation string for CONTOUR class from
+;;; "the vertices must not all be collinear" to
+;;; "no three adjacent vertices can be collinear". Testing for this
+;;; will also catch the "must enclose non-zero area" requirement.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass polyline ()
+
+ ((z :type single-float
+ :initarg :z
+ :accessor z) ; z coord. of plane of definition
+
+ (vertices :type list
+ :initarg :vertices
+ :accessor vertices
+ :documentation "A list of 2-d coordinate pairs")
+
+ (display-color :type symbol
+ :initarg :display-color
+ :accessor display-color)
+
+ )
+
+ (:default-initargs :vertices nil :display-color 'sl:magenta)
+
+ (:documentation "Polylines represent any unconstrained curve in the
+plane, like a clipped isodose contour or a physician's signature.")
+
+ )
+
+;;;--------------------------------------
+
+(defclass contour (polyline)
+
+ ()
+
+ (:documentation "Contours are always part of some object, the type
+of which determines the definition plane. The vertices are a list of
+coordinate pairs because there is nothing about points that would make
+it worth having a list of point instances instead. Structurally, a
+contour is the same as a polyline but the implicit difference between
+them is that contours are non-self-intersecting, must enclose non-zero
+area, no three adjacent vertices can be collinear, and no vertices are
+duplicated. It is also understood that the last point is connected to
+the first, though it is not explicitly repeated in the vertices
+list.")
+
+ )
+
+;;;--------------------------------------
+
+(defun make-contour (&rest initargs)
+
+ "MAKE-CONTOUR &rest initargs
+
+Returns a contour with specified parameters."
+
+ (apply #'make-instance 'contour initargs)
+ )
+
+;;;--------------------------------------
diff --git a/prism/src/cstore-status.cl b/prism/src/cstore-status.cl
new file mode 100644
index 0000000..dcfa7dd
--- /dev/null
+++ b/prism/src/cstore-status.cl
@@ -0,0 +1,78 @@
+;;;
+;;; cstore-status
+;;;
+;;; Dictionary of Elekta CSTORE status codes from Table 17 in DICOM Conformance
+;;; Statement for Elekta Precise Treatment System Release 2.01 24 March 2000.
+;;; Contains data used in Client only.
+;;;
+;;; 1-Dec-2000 J. Jacky Copied from Elekta conformance statement 2.01
+;;; 26-Mar-2001 J. Jacky Add a few more codes from 3.00
+;;; 23-Jan-2002 BobGian Move to Prism package and :Prism system.
+;;; 04-Nov-2004 BobGian *CSTORE-STATUS-ALIST* -> *STATUS-ALIST* in
+;;; preparation for adding codes for more operations.
+
+(in-package :Prism)
+
+;;;=============================================================
+
+(defparameter *status-alist*
+
+ '((#x0000 . "Success")
+
+ ;; Refused
+
+ ;; #xA7XX Out of resources
+
+ (#xA701 . "Patient locked")
+ (#xA702 . "Feature not licensed")
+
+ ;; Error
+
+ ;; #xA9XX Data set does not match SOP class
+
+ (#xA901 . "Invalid Dicom message")
+ (#xA902 . "Invalid Beam Sequence")
+ (#xA903 . "Invalid Dose Reference Sequence")
+ (#xA904 . "Invalid Tolerance Table Sequence")
+ (#xA905 . "Invalid Patient Setup Sequence")
+ (#xA906 . "Invalid Fraction Group Sequence")
+
+ ;; #xCXXX Cannot Understand
+
+ (#xC001 . "Missing Patient Identification data")
+ (#xC002 . "Inconsistent Patient data")
+ (#xC003 . "Missing Treatment Machine Name")
+ (#xC004 . "Unrecognized Linac")
+ (#xC005 . "Invalid Linac Energy or Radiation Type")
+ (#xC006 . "Invalid Beam Limiting Device")
+ (#xC007 . "Incomplete Beam Limiting Device combination")
+ (#xC008 . "Unrecognized Block Tray ID")
+ (#xC009 . "Inconsistent Block Tray ID")
+ (#xC00A . "Unsupported Dosimeter Unit")
+ (#xC00B . "Unsupported Wedge")
+ (#xC00C . "Under-specified Wedge Position Sequence")
+ (#xC00D . "Applicator specified with X-rays")
+ (#xC00E . "Unsupported Applicator")
+ (#xC00F . "MLC shape specified with Electrons")
+ (#xC010 . "Geometric parameter out of customized range")
+ (#xC011 . "Unsupported machine movements")
+ (#xC012 . "Beam too complex")
+ (#xC013 . "Missing Cumulative Meterset Weight")
+ (#xC014 . "Segment Meterset too small")
+ (#xC015 . "Plan contains Brachy data")
+ (#xC016 . "Unsupported Treatment Delivery Type")
+ (#xC017 . "Unsupported Fraction Dosimetry")
+ (#xC018 . "Inconsistent Tolerance Table data")
+ (#xC019 . "Invalid MLC shape or Leaf Positions")
+ (#xC01A . "Under-specified Energy changes")
+
+ ;; Warning
+
+ (#xB000 . "Coercion of Data Elements")
+ (#xB007 . "Data Set does not match SOP Class")
+ (#xB006 . "Elements Discarded")
+
+ ))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/dicom-panel.cl b/prism/src/dicom-panel.cl
new file mode 100644
index 0000000..8ea1d21
--- /dev/null
+++ b/prism/src/dicom-panel.cl
@@ -0,0 +1,1777 @@
+;;;
+;;; dicom-panel
+;;;
+;;; The Dicom panel GUI.
+;;; Contains functions used in Client only.
+;;;
+;;; 22-Jun-2000 J. Jacky Based on write-neutron.cl
+;;; Change "neutron" to "dicom" throughout (but leave "np" and "np-" prefixes)
+;;; so old write-neutron becomes write-dicom.
+;;; Remove phys-name, presc-dose from panel
+;;; initialize-instance: get-therapy-machine SL20A-6MV-MLC not CNTS-BLOCKS
+;;; initialize-instance: add np-vert-fudge 45 to make more room for SL20 leaves
+;;; defmethod :after new-plan: multileaf-coll not cnts-coll
+;;; 26-Jun-2000 J. Jacky Rename file to dicom-panel.cl
+;;; Break up write-dicom into assemble-,log-,send-dicom
+;;; 29-Jun-2000 J. Jacky Separate out assemble-dicom etc. to dicom-rtplan.cl
+;;; 11-Sep-2000 J. Jacky Add textboxes for machine name, X1, X2, Y1, Y2
+;;; 12-Sep-2000 J. Jacky Exchange positions of Y1, Y2 textboxes on panel
+;;; Invert sign of edited Elekta Y2 leaves (-x side)
+;;; 8-Dec-2000 J. Jacky show ack box with send-dicom status, msgs
+;;; 9-Jul-2001 J. Jacky write-file-b confirm: ".. a few minutes" not seconds
+;;; add-beam-b: check constraint-violations
+;;; 10-Jul-2001 J. Jacky Change several textlines, buttons to readouts:
+;;; gan-start gan-stop n-treat mu-treat col-ang
+;;; couch-ang wdg-sel wdg-rot mach
+;;; Add machine id readout
+;;; add-notify's so can edit X1,X2,Y1,Y2
+;;; 12-Jul-2001 J. Jacky beam-s: add beam-problems, separate out set-leaves
+;;; 13-Jul-2001 J. Jacky set-leaves: open leaves at ends of field if needed
+;;; add-beam-b: show no more than 25 constraint viol'ns
+;;; 26-Jul-2001 J. Jacky Round leaf, jaw settings to 0.1mm and display same
+;;; 30-Jul-2001 J. Jacky Get rid of "No Machine" after "Machine: " in caption
+;;; Uncomment call to chart-panel
+;;; 31-Jul-2001 J. Jacky Call dicom-chart-panel not chart-panel
+;;; 2-Aug-2001 J. Jacky New row of buttons: Preview Chart, Add Segments etc.
+;;; Remove date-rdt to make room (put data in plan-rdt)
+;;; 3-Aug-2001 J. Jacky reverse beam list in calls to dicom-chart-panel
+;;; display total and daily MU to 0.1
+;;; 27-Aug-2001 J. Jacky fix set-leaves-jaws: handle out-of-range ymin,ymax
+;;; 28-Aug-2001 J. Jacky fix leaf left-tlns add-notify: Elekta Y2 leaf sign
+;;; 28-Aug-2001 J. Jacky set-leaves-jaws: call new make-flagpole
+;;; 6-Sep-2001 J. Jacky add-beam-b shows confirm box with new beam-warnings
+;;; 7-Sep-2001 J. Jacky Fix range check on left-leaf-tlns consistent w/28Aug
+;;; Add flag-diff, shape-diff
+;;; 11-Sep-2001 J. Jacky Move out several functions to mlc-collimators.cl
+;;; rename beam-warnings to collim-warnings, pass colls
+;;; rename constraint-violations to collim-constraint-..
+;;; 12-Sep-2001 J. Jacky Delete set-leaves-jaws,call make-multileaf-coll etc.
+;;; 12-Sep-2001 J. Jacky send-dicom second value is just string,not list of..
+;;; 13-Sep-2001 J. Jacky add-seg-b, add-beam-b both call new add-beam
+;;; 14-Sep-2001 J. Jacky Pass beam-info to assemble-dicom, dicom-chart-panel
+;;; beam-info contains segment information
+;;; 18-Sep-2001 J. Jacky add-beam uses new beam-rec struct
+;;; send-beam calls new calc-seg-info, uses new seg-rec
+;;; 19-Sep-2001 J. Jacky Use list instead of beam-rec struct so can copy-tree
+;;; 20-Sep-2001 J. Jacky calc-seg-info: support new bnum field in seg-rec
+;;; first-segment: add :initform nil
+;;; add-beam, segment-violations: fix bugs
+;;; dicom-panel, add-beam: support new segment-color
+;;; 21-Sep-2001 J. Jacky Remove first-segment, just use tail of OUTPUT-ALIST,
+;;; separate out del-beam function
+;;; 26-Sep-2001 J. Jacky calc-seg-info: calculate new cum field in seg-rec
+;;; 01-Oct-2001 J. Jacky Move out calc-seg-info, segment-violations
+;;; new ADD-SEG-INFO calls CALC-SEG-INFO.
+;;; 12-Oct-2001 J. Jacky beam-prolems: test machine-id's with equal not eq
+;;; 24-Oct-2001 J. Jacky Fix :label :info confusion in mach-, wdg- rdt's
+;;; 26-Oct-2001 J. Jacky Distinguish warnings from failures in write-file-b
+;;; 31-Oct-2001 J. Jacky Accommodate VJC collimators as well as MLC
+;;; 2-Nov-2001 J. Jacky beam-problems: ext. wedge, blocks not in same beam
+;;; 5-Dec-2001 J. Jacky write-file-b: prompt for patient ID for DICOM-RT/RTD
+;;; 10-Dec-2001 J. Jacky write-file-b: pass dicom-pat-id to dicom-chart-panel
+;;; (but only after actual transfer, not chart preview)
+;;; 31-Jan-2002 I. Kalet move round-digits from here to
+;;; mlc-collimators to remove circular module dependency.
+;;; 12-Feb-2002 BobGian Two calls to dicom-chart-panel -> chart-panel.
+;;; 29-May-2003 M Phillips added Dose Monitor Points section.
+;;; 09-Aug-2002 BobGian Add interface from panel to Dicom engine for
+;;; Dose Monitoring Points.
+;;; Rename var "np" and prefix "np-" -> "dp", "dp-".
+;;; DOTIMES/NTH -> DO, IF -> WHEN/UNLESS/COND,
+;;; LET* -> LET, and similar source->source
+;;; simplifications and optimizations when possible.
+;;; 27-Aug-2003 BobGian add Dose-Monitoring Points.
+;;; 05-Sep-2003 BobGian regularize slot/accessor and local-variable names:
+;;; Type: Slot/Accessor: Local var:
+;;; BUTTON xxx-button xxx-bn
+;;; FRAME xxx-frame xxx-frm
+;;; READOUT xxx-label xxx-lbl
+;;; READOUT xxx-readout xxx-rd
+;;; SCROLLING-LIST xxx-scrollinglist xxx-sl
+;;; SPREADSHEET xxx-spreadsheet xxx-ss
+;;; TEXTLINE xxx-textline xxx-tl
+;;; 12-Sep-2003 BobGian regularize some internal function names:
+;;; ADD-BEAM -> ADD-BEAM-FCN
+;;; Add DMPLIST arg to ADD-BEAM-FCN to convey DMPs
+;;; to OUTPUT-ALIST.
+;;; DEL-BEAM -> DEL-BEAM-FCN
+;;; Change association lists [PLAN-ALIST, BEAM-ALIST, and
+;;; OUTPUT-ALIST] from CDR-keyed [using ACONS and RASSOC]
+;;; to more understandable CAR-keyed [CONS and ASSOC].
+;;; 19-Sep-2003 BobGian Add new slot, COORDS, to DMP struct, carrying list
+;;; of X,Y,Z coords in Dicom convention, millimeters,
+;;; rounded to fixed precision [two decimal places].
+;;; 03-Oct-2003 BobGian Add type declarations to DICOM-PANEL slots.
+;;; 07-Oct-2003 BobGian Move ADD-SEG-INFO here -> "imrt-segments.cl".
+;;; 20-Oct-2003 BobGian Move DMP defstruct here -> "dicom-rtplan"
+;;; to simplify dependencies.
+;;; 03-Nov-2003 BobGian Remove read-time evaluation for constant expressions
+;;; where compile can optimize based on DEFCONSTANT in
+;;; same file.
+;;; Action fcns for Select-Plan and Select-Beam events
+;;; clear DMPLIST directly rather than calling
+;;; Deselect-Point action function.
+;;; 18-Nov-2003 BobGian Got deselect-point action function business all
+;;; screwed up. Redid it correctly. Ready for testing
+;;; against real Elekta server. Also: Added CONFIRM
+;;; popup if no DMPs selected when ADD-BEAM invoked.
+;;; 24-Nov-2003 BobGian: DMP auto-replication scheme altered. As DMPs are
+;;; selected for a beam/segment, any existing dose values are pushed onto
+;;; lists in the the "OTHER-xxx-DOSES" slots, the current slots cleared,
+;;; and the current slots then accumulate dose values representing the
+;;; current beam/segment only. Also, if point is deselected from a beam,
+;;; corresponding DMP must be tested for sharing: if shared, pop current
+;;; beam from beams contributing to this DMP; if not shared, deleted DMP
+;;; from current DMPLIST. [See changelog notes, same date, in files
+;;; "dicom-rtplan" and "imrt-segments".]
+;;; 25-Nov-2003 BobGian: ADD-SEG-INFO needs DMP-CNT arg to allow continued
+;;; counting while auto-replicating DMPs.
+;;; 16-Dec-2003 BobGian: COMPUTE-DOSE-POINTS only called when a DMP is first
+;;; selected. Later operations are guaranteed that point-doses are valid.
+;;; NUMBER-OF-FRACS-TEXTLINE -> REMAINING-FRACS-READOUT [read/only].
+;;; 19-Dec-2003 BobGian:
+;;; Number of treatments [fractions] clarified:
+;;; NUM-TOTAL-FRAC is total number of fractions [set by (N-TREATMENTS <BI>)
+;;; in Prism plan] and is read/only here.
+;;; NUM-TREATED-FRAC is number of fractions already administered,
+;;; modifiable in DICOM-PANEL.
+;;; NUM-REMAINING-FRAC is difference between above two, calculated here.
+;;; UPDATE-DMP-SPREADSHEET, DISPLAY-DMP-SPREADSHEET, ERASE-DMP-SPREADSHEET:
+;;; All now only called at one point - open-coded at point of call.
+;;; REFRESH-DMP-SPREADSHEET: Order of args changed.
+;;; 23-Dec-2003 BobGian: Added missing DESTROY calls for DICOM-PANEL resources.
+;;; 25-Dec-2002 BobGian: Flushed all "OTHER-..." slots. Now we allocate a
+;;; separate DMP object for each segment in which the DMP appears, linking
+;;; them through the list in the DMP-SEGLIST slot of each so that dose can
+;;; be accumulated properly across all segments in a single beam.
+;;; 28-Dec-2003 BobGian: DMP slots ...-dose -> ...-cGy to emphasize dose units.
+;;; 30-Dec-2003 BobGian, Mark Phillips: Decided to factor apart the packaging
+;;; of Prism beams into multisegmented beams from the allocation of DMPs
+;;; to beams. Also, users is free to allocate DMPs to any subset of beams
+;;; desired - no auto-replication of DMPs whose dose comes from multiple
+;;; beams. These design choices considerable simplify beam/DMP allocation
+;;; logic and user interface model, at cost of extra pop-up menus.
+;;; 31-Dec-2003 BobGian: ADD-SEG-INFO no longer needs DMP-CNT - no replicating.
+;;; 20-Jan-2004 M Phillips: modified DMP panel.
+;;; 27-Jan-2004 BobGian integrated Mark's work with rest of Dicom panel.
+;;; 10-Feb-2004 BobGian replaced ROUND-DIGITS with COERCE [to SINGLE-FLOAT],
+;;; since object generator prints flonums rounded to 2 decimal places.
+;;; 27-Jan-2004 BobGian began integration of new DMP Panel by Mark Phillips
+;;; with rest of Dicom Panel and interface to Dicom SCU.
+;;; 15-Feb-2004 BobGian: ADD-BEAM-FCN no longer handles DMPs. New version of
+;;; DMP mechanism is based on factoring of DICOM panel into two panels,
+;;; Dicom Panel for segment aggregation into beams and DMP Panel for
+;;; allocation of DMPs to [aggregated or "Dicom"] beams.
+;;; 19-Feb-2004 BobGian - introduced uniform naming convention explained
+;;; in file "imrt-segments". This includes:
+;;; ADD-BEAM-FCN -> ADD-PRISM-BEAM-FCN
+;;; BEAM-ALIST -> PRISM-BEAM-ALIST
+;;; BEAM-LABEL -> PRISM-BEAM-LABEL
+;;; BEAM-PROBLEMS -> PRISM-BEAM-PROBLEMS
+;;; BEAM-READOUT -> PRISM-BEAM-READOUT
+;;; BEAM-SCROLLINGLIST -> PRISM-BEAM-SCROLLINGLIST
+;;; DEL-BEAM-FCN -> DEL-PRISM-BEAM-FCN
+;;; 25-Feb-2004 BobGian - ADD-SEG-INFO -> GENERATE-PBEAM-INFO.
+;;; 26-Feb-2004 BobGian completed DMP integration.
+;;; 27-Feb-2004 BobGian made DICOM-PANEL operate at pushed event level.
+;;; 28-Feb-2004 BobGian - undo pushed event level for Dicom Panel.
+;;; Reverse second arg to ADD-PRISM-BEAM-FCN [fixes grouper bug].
+;;; 01-Mar-2004 BobGian place constraint-checking on beams/DMPs about to be
+;;; sent immediately on Send-Beams button press, before Patient ID typein.
+;;; WRITE-FILE-BUTTON slot [and local var] -> SEND-BEAMS-BUTTON.
+;;; 29-Apr-2004 BobGian: Added declaration in SEGMENT-VIOLATIONS.
+;;; 30-Apr-2004 BobGian: Renamed a few function parameters and local vars to
+;;; better distinguish between Original and Current Prism beam instances.
+;;; 03-May-2004 BobGian:
+;;; 1. Segmented SETF :after method of CURRENT-PRISM-BI into two separate
+;;; functions, CLEAR-CURRENT-PRISM-BI and SETUP-CURRENT-PRISM-BI, to
+;;; simplify operation. Placed appropriate function call at each point
+;;; of assignment operation.
+;;; 2. Fixed bug in incorrect assignment of new collimator to
+;;; ORIGINAL-PRISM-BI slot of DICOM-PANEL object.
+;;; 12-May-2004 BobGian:
+;;; SEGMENT-VIOLATIONS - reversed args [consistent with other comparisons].
+;;; Also one of the arguments to FORMAT was mislabeled.
+;;; 17-May-2004 BobGian complete process of extending all instances of Original
+;;; and Current Prism beam instances to include Copied beam instance too,
+;;; to provide copy for comparison with Current beam without mutating
+;;; Original beam instance.
+;;; CLEAR-CURRENT-PRISM-BI -> CLEAR-PRISM-BI-TRIPLE
+;;; SETUP-CURRENT-PRISM-BI -> SETUP-PRISM-BI-TRIPLE
+;;; 24-May-2004 BobGian: Remove check for matching machine name when adding
+;;; segment in SEGMENT-VIOLATIONS. Proper test [for matching first element
+;;; of IDENT slot of MACHINE] is already done by PRISM-BEAM-PROBLEMS.
+;;; Add matching energy check when adding new segment in ADD-PRISM-BEAM-FCN.
+;;; Proceeding on mismatch is confirmable rather than being disallowed.
+;;; 27-May-2004 BobGian: Fix bugs in ADD-PRISM-BEAM-FCN. Add checks for empty
+;;; beam list [in slot OUTPUT-ALIST of DP] in places where users of data
+;;; assume non-empty lists. Fix ambiguities in ACKNOWLEDGE messages
+;;; relevant to "No beam selected" and "No beams/segs added" situations.
+;;; 19-Sep-2004 BobGian: Call to CHECK-BEAM-DMP-CONSTRAINTS changed to
+;;; CHECK-BEAM-CONSTRAINTS.
+;;; 05-Oct-2004 BobGian fixed a few lines to fit within 80 cols.
+;;; 01-Nov-2004 BobGian add forgotten check for "New Segment" in check for
+;;; Wedge IN/OUT segment pair, altered leaf settings, in ADD-PRISM-BEAM-FCN.
+;;; 04-Nov-2004 BobGian add default error message for *STATUS-ALIST*.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defclass dicom-panel ( )
+
+ ((frame :type sl:frame
+ :accessor frame
+ :documentation "The Slik frame that contains the Dicom panel.")
+
+ ;; Three buttons along top, copied from neutron panel.
+
+ (del-panel-button :type sl::button
+ :accessor del-panel-button
+ :documentation "The Delete-Panel button for this panel.")
+
+ (add-prism-beam-button :type sl::button
+ :accessor add-prism-beam-button
+ :documentation "The Add-Beam button for this panel.")
+
+ (send-beams-button :type sl::button
+ :accessor send-beams-button
+ :documentation "The Send-Beams button for this panel.")
+
+ ;; Three new buttons along top, right below top row.
+
+ (preview-chart-button :type sl::button
+ :accessor preview-chart-button
+ :documentation "The Preview-Chart button.")
+
+ (add-seg-button :type sl::button
+ :accessor add-seg-button
+ :documentation "The Add-Segment button for this panel.")
+
+ (dmp-panel-button :type sl::button
+ :accessor dmp-panel-button
+ :documentation "The DMP button creates the DMP panel.")
+
+ (comments-box :type sl::textbox
+ :accessor comments-box
+ :documentation "The Plan-Comments box for this panel.")
+
+ (comments-label :type sl::readout
+ :accessor comments-label
+ :documentation "The label for this panel's comments box.")
+
+ (prism-beam-readout :type sl::readout
+ :accessor prism-beam-readout
+ :documentation "The beam readout for this panel.")
+
+ (plan-readout :type sl::readout
+ :accessor plan-readout
+ :documentation "The plan name and date readout.")
+
+ (plan-scrollinglist :type sl::scrolling-list
+ :accessor plan-scrollinglist
+ :documentation "A scrolling list of available plans.")
+
+ (plan-label :type sl::readout
+ :accessor plan-label
+ :documentation "The label for the plans scrolling list.")
+
+ (prism-beam-scrollinglist
+ :type sl::scrolling-list
+ :accessor prism-beam-scrollinglist
+ :documentation "A scrolling list of available Prism beams.")
+
+ (prism-beam-label
+ :type sl::readout
+ :accessor prism-beam-label
+ :documentation "The label for the Prism-beams scrolling list.")
+
+ (output-scrollinglist :type sl::scrolling-list
+ :accessor output-scrollinglist
+ :documentation "A scrolling list of Prism beams
+to be output by the Dicom panel.")
+
+ (output-label :type sl::readout
+ :accessor output-label
+ :documentation "The label for the output scrolling list.")
+
+ (gantry-start-readout :type sl::readout
+ :accessor gantry-start-readout
+ :documentation "The gantry starting angle readout.")
+
+ (gantry-stop-readout :type sl::readout
+ :accessor gantry-stop-readout
+ :documentation "The gantry stopping angle readout.")
+
+ (n-treat-readout :type sl::readout
+ :accessor n-treat-readout
+ :documentation "The num treatments readout.")
+
+ (tot-mu-readout :type sl::readout
+ :accessor tot-mu-readout
+ :documentation "The total monitor units readout.")
+
+ (mu-treat-readout :type sl::readout
+ :accessor mu-treat-readout
+ :documentation "The monitor units per treatment readout.")
+
+ (coll-angle-readout :type sl::readout
+ :accessor coll-angle-readout
+ :documentation "The collimator angle readout.")
+
+ (couch-angle-readout :type sl::readout
+ :accessor couch-angle-readout
+ :documentation "The couch angle readout.")
+
+ (wedge-sel-readout :type sl::readout
+ :accessor wedge-sel-readout
+ :documentation "The wedge selection readout.")
+
+ (wedge-rot-readout :type sl::readout
+ :accessor wedge-rot-readout
+ :documentation "The wedge rotation readout.")
+
+ (left-leaf-textlines
+ :type list
+ :accessor left-leaf-textlines
+ :initform nil
+ :documentation "A list of left side mlc leaf textlines.")
+
+ (right-leaf-textlines
+ :type list
+ :accessor right-leaf-textlines
+ :initform nil
+ :documentation "A list of right side mlc leaf textlines.")
+
+ (plan-alist :type list
+ :accessor plan-alist
+ :initform nil
+ :documentation "An association list of buttons and plans in
+the panel's scrolling list of plans.")
+
+ ;; This stores original uncopied Prism beams from Prism plans in an alist.
+ (prism-beam-alist :type list
+ :accessor prism-beam-alist
+ :initform nil
+ :documentation "An association list of buttons and
+Prism [original] beam instances in the panel's scrolling list of beams.")
+
+ ;; Use original/copied/current-beam triples to flag changed items on chart.
+ ;; This list is maintained in REVERSE order (new items pushed) while using
+ ;; panel to accumulate beam-segments. Order is reversed in
+ ;; GENERATE-PBEAM-INFO before passing data to Dicom interface.
+ (output-alist :type list
+ :accessor output-alist
+ :initform nil
+ :documentation
+ "The association list of buttons and beam-descriptor
+objects [ <OrigBmInst> <CopyBmInst> <CurrBmInst> ... ]
+in the panel's scrolling list of Prism beams to be output.")
+
+ (current-patient :type patient
+ :accessor current-patient
+ :initarg :current-patient
+ :documentation "The current patient for the
+Dicom panel, supplied at initialization time.")
+
+ (current-plan :type plan
+ :accessor current-plan
+ :initform nil
+ :documentation "The plan that the Dicom panel is
+currently displaying.")
+
+ ;; Beam instance here is original Prism beam, not copied, and containing
+ ;; beam's original DOSE-RESULT object.
+ (original-prism-bi :type beam
+ :accessor original-prism-bi
+ :initform nil
+ :documentation "The original version of the
+Prism beam instance that the Dicom panel is currently displaying.")
+
+ ;; Beam instance here is copied from original Prism beam but not mutated.
+ ;; Its collimator is changed to MLC for comparison against copy in
+ ;; CURRENT-PRISM-BI, but it itself is NOT mutated by user actions.
+ ;; Does NOT contain DOSE-RESULT object.
+ (copied-prism-bi :type beam
+ :accessor copied-prism-bi
+ :initform nil
+ :documentation "The copied original version of the
+Prism beam instance that the Dicom panel is currently displaying.")
+
+ ;; Beam instance here is copied and user-mutated from original Prism beam.
+ ;; Does NOT contain DOSE-RESULT object.
+ (current-prism-bi :type beam
+ :accessor current-prism-bi
+ :initform nil
+ :documentation "The Prism beam instance that the
+Dicom panel is currently displaying and modifying.")
+
+ (collim-info :accessor collim-info
+ :documentation "A cache for the collimator info of the
+current Prism beam instance.")
+
+ ;; New stuff to support Elekta accelerators
+
+ (machine-readout :type sl::readout
+ :accessor machine-readout
+ :documentation "The machine selection readout.")
+
+
+ (id-readout :type sl::readout
+ :accessor id-readout
+ :documentation "The machine identification readout.")
+
+ (x1-textline :type sl::textline
+ :accessor x1-textline
+ :documentation "The X1 diaphragm textline.")
+
+ (x2-textline :type sl::textline
+ :accessor x2-textline
+ :documentation "The X2 diaphragm textline.")
+
+ (y1-textline :type sl::textline
+ :accessor y1-textline
+ :documentation "The Y1 diaphragm textline.")
+
+ (y2-textline :type sl::textline
+ :accessor y2-textline
+ :documentation "The Y2 diaphragm textline.")
+
+ (dicom-dmp-list :accessor dicom-dmp-list
+ :initform '()
+ :documentation "List that contains dose monitoring points
+[Dicom sense: a DMP associated with a Dicom beam]. Used to initialize the
+DMP Panel and to accumulate added DMPs.")
+
+ (dicom-dmp-cnt :type fixnum
+ :accessor dicom-dmp-cnt
+ :initarg :dicom-dmp-cnt
+ :documentation "Instance counter for created DMPs.
+Stored in Dicom Panel so DMP Panel can be initialized correctly."))
+
+ (:documentation "The Dicom panel is used to select plans, to group Prism
+beams [IMRT segments] into Dicom beams, and to send the Dicom beams
+using DICOM-RT, acting as the Dicom client (SCU).")
+
+ )
+
+;;;-------------------------------------------------------------
+
+(defparameter color-seq
+ (vector 'sl:red 'sl:green 'sl:yellow 'sl:magenta 'sl:cyan))
+
+;;;=============================================================
+;;; Defconstants for Dicom panel.
+
+(defconstant dp-off 10) ; Intercontrol spacing factor
+(defconstant dp-rd-ht 30) ; readout height
+(defconstant dp-rd-base 80) ; base readout width
+(defconstant dp-sl-ht (* 4 dp-rd-ht)) ; scrolling list height
+(defconstant dp-tb-ht (* 3 dp-rd-ht)) ; textbox height
+(defconstant dp-ht
+ (+ (* 11 dp-rd-ht) ; height of DMP Panel section
+ (* 12 dp-off)
+ dp-sl-ht
+ 45 ;extra space for more SL20 leaves - any larger won't fit on 1024 x 768
+ dp-tb-ht)) ; panel height
+(defconstant pln-sl-width (round (* 1.5 dp-rd-base)))
+
+;;;=============================================================
+;;; Main panel functionality
+;;;=============================================================
+
+(defmethod initialize-instance :after ((dp dicom-panel) &rest initargs)
+
+ "Initializes the Dicom panel GUI."
+
+ (let* ((cur-pat (current-patient dp)) ; The patient object
+
+ (dp-tl-color 'sl:green) ; textline border color
+ (dp-rd-color 'sl:white) ; readout border color
+ (dp-bt-color 'sl:cyan) ; button border color
+
+ (frm (apply #'sl:make-frame
+ ;; Width of DMP Panel section
+ (+ (* 6 dp-off) ; panel width
+ (* 10 dp-rd-base))
+ dp-ht ; height of DMP Panel section
+ :title
+ (format nil "Prism Dicom Panel -- ~A" (name cur-pat))
+ initargs))
+ (frm-win (sl:window frm))
+
+ (plan-sl (apply #'sl:make-radio-scrolling-list
+ (round (* 1.5 dp-rd-base)) dp-sl-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 3 dp-off) (* 3 dp-rd-ht))
+ :border-color dp-bt-color
+ initargs))
+ (p-bm-sl (apply #'sl:make-radio-scrolling-list
+ (round (* 1.5 dp-rd-base)) dp-sl-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 dp-off) pln-sl-width)
+ :ulc-y (+ (* 3 dp-off) (* 3 dp-rd-ht))
+ :border-color dp-bt-color
+ initargs))
+ (output-sl (apply #'sl:make-scrolling-list
+ (* 3 dp-rd-base) dp-sl-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 2 pln-sl-width))
+ :ulc-y (+ (* 3 dp-off) (* 3 dp-rd-ht))
+ :enable-delete t
+ :border-color dp-bt-color
+ initargs))
+
+ ;; Three buttons along top row
+ (del-panel-bn (apply #'sl:make-button
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off :ulc-y dp-off
+ :label "Delete Panel"
+ :button-type :momentary
+ :border-color dp-bt-color
+ initargs))
+
+ (add-prism-beam-bn (apply #'sl:make-button
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 dp-off) (* 2 dp-rd-base))
+ :ulc-y dp-off
+ :label "Add Beam"
+ :button-type :momentary
+ :border-color dp-bt-color
+ initargs))
+ (dmp-panel-bn (apply #'sl:make-button
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 4 dp-rd-base))
+ :ulc-y dp-off
+ :label "Dose Monitor Pts"
+ :button-type :momentary
+ :border-color dp-bt-color
+ initargs))
+ ;; Three buttons right underneath
+ (preview-chart-bn (apply #'sl:make-button
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 2 dp-off) dp-rd-ht)
+ :label "Preview Chart"
+ :button-type :momentary
+ :border-color dp-bt-color
+ initargs))
+ (add-seg-bn (apply #'sl:make-button
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 dp-off) (* 2 dp-rd-base))
+ :ulc-y (+ (* 2 dp-off) dp-rd-ht)
+ :label "Add Segment"
+ :button-type :momentary
+ :border-color dp-bt-color
+ initargs))
+ (send-beams-bn (apply #'sl:make-button
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 4 dp-rd-base))
+ :ulc-y (+ (* 2 dp-off) dp-rd-ht)
+ :label "Send Beams"
+ :button-type :momentary
+ :border-color dp-bt-color
+ initargs))
+
+ ;; New stuff to support Elekta accelerators
+ (x1-tl (apply #'sl:make-textline
+ (round (* 1.5 dp-rd-base)) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off ; x position like gan-start
+ :ulc-y (+ (* 12 dp-off) (* 14 dp-rd-ht) dp-sl-ht)
+ :label "X1: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 20.0
+ :border-color dp-tl-color
+ initargs))
+
+ (x2-tl (apply #'sl:make-textline
+ (round (* 1.5 dp-rd-base)) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (round (* 1.5 dp-off))
+ (round (* 1.5 dp-rd-base)))
+ :ulc-y (+ (* 12 dp-off) (* 14 dp-rd-ht) dp-sl-ht)
+ :label "X2: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 20.0
+ :border-color dp-tl-color
+ initargs))
+
+ ;; Y1 textline appears to right of Y2 textline because it's +X jaw
+ (y1-tl (apply #'sl:make-textline
+ (- (round (* 1.5 dp-rd-base)) 4) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (round (* 3.5 dp-off))
+ (round (* 4.5 dp-rd-base)))
+ :ulc-y (+ (* 12 dp-off) (* 14 dp-rd-ht) dp-sl-ht)
+ :label "Y1: "
+ :numeric t
+ :lower-limit -12.5 :upper-limit 20.0
+ :border-color dp-tl-color
+ initargs))
+
+ (y2-tl (apply #'sl:make-textline
+ (round (* 1.5 dp-rd-base)) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 3 dp-rd-base)) ;gan-stop
+ :ulc-y (+ (* 12 dp-off) (* 14 dp-rd-ht) dp-sl-ht)
+ :label "Y2: "
+ :numeric t
+ :lower-limit -12.5 :upper-limit 20.0
+ :border-color dp-tl-color
+ initargs))
+
+ (no-bm-sel-msg "No beam selected yet.")
+ (no-bms/segs-msg "No beams or segments added yet."))
+
+ (setf (frame dp) frm
+
+ (comments-box dp)
+ (apply #'sl:make-textbox
+ (+ (* 6 dp-rd-base) (* 2 dp-off))
+ dp-tb-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 6 dp-off) (* 6 dp-rd-ht) dp-sl-ht)
+ :border-color dp-rd-color
+ initargs)
+
+ (comments-label dp)
+ (apply #'sl:make-readout
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 6 dp-off) (* 5 dp-rd-ht) dp-sl-ht)
+ :border-color 'sl:black
+ :label "Plan Comments:"
+ initargs)
+
+ (prism-beam-readout dp)
+ (apply #'sl:make-readout
+ (+ (* 6 dp-rd-base) (* 2 dp-off))
+ dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 5 dp-off) (* 4 dp-rd-ht) dp-sl-ht)
+ :border-color dp-rd-color
+ :label "Beam Name: "
+ initargs)
+
+ (plan-readout dp)
+ (apply #'sl:make-readout
+ (+ (* 6 dp-rd-base) (* 2 dp-off))
+ dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 4 dp-off) (* 3 dp-rd-ht) dp-sl-ht)
+ :border-color dp-rd-color
+ :label "Plan: "
+ initargs)
+
+ (plan-label dp) (apply #'sl:make-readout
+ (round (* 1.5 dp-rd-base)) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 2 dp-rd-ht) (* 2 dp-off))
+ :border-color 'sl:black
+ :label "Plans:"
+ initargs)
+
+ (plan-scrollinglist dp) plan-sl
+
+ (prism-beam-label dp) (apply #'sl:make-readout
+ (round (* 1.5 dp-rd-base)) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 dp-off) pln-sl-width)
+ :ulc-y (+ (* 2 dp-rd-ht) (* 2 dp-off))
+ :border-color 'sl:black
+ :label "Beams:"
+ initargs)
+
+ (prism-beam-scrollinglist dp) p-bm-sl
+
+ (output-label dp) (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 2 pln-sl-width))
+ :ulc-y (+ (* 2 dp-rd-ht) (* 2 dp-off))
+ :border-color 'sl:black
+ :label "Output:"
+ initargs)
+
+ (output-scrollinglist dp) output-sl
+ (del-panel-button dp) del-panel-bn
+ (add-prism-beam-button dp) add-prism-beam-bn
+ (send-beams-button dp) send-beams-bn
+ (preview-chart-button dp) preview-chart-bn
+ (add-seg-button dp) add-seg-bn
+ (dmp-panel-button dp) dmp-panel-bn
+
+ (gantry-start-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 8 dp-off) (* 10 dp-rd-ht) dp-sl-ht)
+ :label "Gan start: "
+ :border-color dp-rd-color
+ initargs)
+
+ (gantry-stop-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 3 dp-rd-base))
+ :ulc-y (+ (* 8 dp-off) (* 10 dp-rd-ht) dp-sl-ht)
+ :label "Gan Stop: "
+ :border-color dp-rd-color
+ initargs)
+
+ (n-treat-readout dp)
+ (apply #'sl:make-readout
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 11 dp-off) (* 13 dp-rd-ht) dp-sl-ht)
+ :label "N Treat: "
+ :border-color dp-rd-color
+ initargs)
+
+ (tot-mu-readout dp)
+ (apply #'sl:make-readout
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 4 dp-rd-base))
+ :ulc-y (+ (* 11 dp-off) (* 13 dp-rd-ht) dp-sl-ht)
+ :label "Tot Mu: "
+ :border-color dp-rd-color
+ initargs)
+
+ (mu-treat-readout dp)
+ (apply #'sl:make-readout
+ (* 2 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 dp-off) (* 2 dp-rd-base))
+ :ulc-y (+ (* 11 dp-off) (* 13 dp-rd-ht) dp-sl-ht)
+ :label "Mu/Treat: "
+ :border-color dp-rd-color
+ initargs)
+
+ (coll-angle-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 9 dp-off) (* 11 dp-rd-ht) dp-sl-ht)
+ :label "Collim Ang: "
+ :border-color dp-rd-color
+ initargs)
+
+ (couch-angle-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 3 dp-rd-base))
+ :ulc-y (+ (* 9 dp-off) (* 11 dp-rd-ht) dp-sl-ht)
+ :label "Couch Ang: "
+ :border-color dp-rd-color
+ initargs)
+
+ (wedge-sel-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 10 dp-off) (* 12 dp-rd-ht) dp-sl-ht)
+ :label "Wedge Sel: "
+ :border-color dp-rd-color
+ initargs)
+
+ (wedge-rot-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 3 dp-rd-base))
+ :ulc-y (+ (* 10 dp-off) (* 12 dp-rd-ht) dp-sl-ht)
+ :label "Wedge Rot: "
+ :border-color dp-rd-color
+ initargs)
+
+ (machine-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x dp-off
+ :ulc-y (+ (* 7 dp-off) (* 9 dp-rd-ht) dp-sl-ht)
+ :label "Machine: "
+ :border-color dp-rd-color
+ initargs)
+
+ (id-readout dp)
+ (apply #'sl:make-readout
+ (* 3 dp-rd-base) dp-rd-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 dp-off) (* 3 dp-rd-base))
+ :ulc-y (+ (* 7 dp-off) (* 9 dp-rd-ht) dp-sl-ht)
+ :label "Machine ID: "
+ :border-color dp-rd-color
+ initargs)
+
+ (x1-textline dp) x1-tl
+ (x2-textline dp) x2-tl
+ (y1-textline dp) y1-tl
+ (y2-textline dp) y2-tl)
+
+ ;; Set the collim-info cache for the panel.
+ ;; (previously we used SL20C-6MV-MLC in the therapy-machines database)
+ (setf (collim-info dp) *sl-collim-info*)
+
+ ;; Setup leaf textlines
+ (do* ((collim-data (collim-info dp))
+ (column-len (num-leaf-pairs collim-data))
+ (leaf-tl-height (round (/ (float (- dp-ht (* 2 dp-off)))
+ column-len)))
+ (leaf-pairs (leaf-pair-map collim-data) (cdr leaf-pairs))
+ (leaf-tl-y dp-off (+ leaf-tl-y leaf-tl-height))
+ (left-tls '())
+ (right-tls '())
+ (idx 0 (the fixnum (1+ idx))))
+ ((= idx column-len)
+ (setf (left-leaf-textlines dp) (nreverse left-tls))
+ (setf (right-leaf-textlines dp) (nreverse right-tls)))
+ (declare (type fixnum column-len leaf-tl-height leaf-tl-y idx))
+ (push (sl:make-textline
+ (* 2 dp-rd-base) leaf-tl-height
+ :parent frm-win
+ :ulc-x (+ (* 6 dp-rd-base) (* 4 dp-off))
+ :ulc-y leaf-tl-y
+ :numeric t
+ :lower-limit (- (leaf-overcenter-limit collim-data))
+ :upper-limit (leaf-open-limit collim-data)
+ :label (format nil "Leaf ~2 at A: " (first (first leaf-pairs)))
+ :border-color dp-tl-color
+ :volatile-width 4) ; shows up better
+ left-tls)
+ (push (sl:make-textline
+ (* 2 dp-rd-base) leaf-tl-height
+ :parent frm-win
+ :ulc-x (+ (* 8 dp-rd-base) (* 5 dp-off))
+ :ulc-y leaf-tl-y
+ :numeric t
+ :lower-limit (- (leaf-overcenter-limit collim-data))
+ :upper-limit (leaf-open-limit collim-data)
+ :label (format nil "Leaf ~2 at A: " (second (first leaf-pairs)))
+ :border-color dp-tl-color
+ :volatile-width 4) ; shows up better
+ right-tls))
+
+ ;; Setup plan scrolling list
+ (dolist (pln (coll:elements (plans cur-pat)))
+ (let ((btn (sl:make-list-button plan-sl (name pln))))
+ (sl:insert-button btn plan-sl)
+ (push (cons btn pln) (plan-alist dp))))
+
+ ;; Select-Plan button pressed.
+ (ev:add-notify dp (sl:selected plan-sl)
+ #'(lambda (dp ann p-bn)
+ (declare (ignore ann))
+ (when (current-prism-bi dp)
+ (ev:remove-notify dp (new-id (wedge (current-prism-bi dp))))
+ (ev:remove-notify dp (new-rotation (wedge (current-prism-bi dp)))))
+ (setf (original-prism-bi dp) nil)
+ (setf (copied-prism-bi dp) nil)
+ (setf (current-prism-bi dp) nil)
+ (clear-prism-bi-triple dp)
+ ;; Set plan.
+ (setf (current-plan dp)
+ (cdr (assoc p-bn (plan-alist dp) :test #'eq)))))
+
+ ;; Deselect-Plan button pressed.
+ (ev:add-notify dp (sl:deselected plan-sl)
+ #'(lambda (dp a btn)
+ (declare (ignore a btn))
+ (setf (current-plan dp) nil)))
+
+ ;; Select-Prism-Beam button pressed.
+ (ev:add-notify dp (sl:selected p-bm-sl)
+ #'(lambda (dp ann b-bn)
+ (declare (ignore ann))
+ (let* ((orig-pbi (cdr (assoc b-bn (prism-beam-alist dp) :test #'eq)))
+ (pl (prism-beam-problems orig-pbi dp)))
+ ;; ORIG-PBI is original Prism beam instance, not a copy.
+ (cond
+ ((consp pl)
+ (push (format nil "Cannot select ~S." (name orig-pbi)) pl)
+ (sl:acknowledge pl))
+ (t (when (current-prism-bi dp)
+ (ev:remove-notify dp
+ (new-id (wedge (current-prism-bi dp))))
+ (ev:remove-notify dp
+ (new-rotation (wedge (current-prism-bi dp)))))
+
+ ;; Original uncopied Prism beam, containing DOSE-RESULT obj.
+ (setf (original-prism-bi dp) orig-pbi)
+
+ ;; COPIED-PRISM-BI must be copy of ORIG-PBI so that mutation
+ ;; of its collimator in SETUP-PRISM-BI-TRIPLE does not change
+ ;; beam object in original Prism plan.
+ (setf (copied-prism-bi dp) (copy orig-pbi))
+
+ (let ((new-pbi (copy orig-pbi)))
+ (setf (current-prism-bi dp) new-pbi)
+ (setup-prism-bi-triple new-pbi dp))
+
+ ;; Register with the current Prism beam instance's
+ ;; wedge ID and rotation events.
+ (ev:add-notify dp (new-id (wedge (current-prism-bi dp)))
+ #'(lambda (dp wdg id)
+ (declare (ignore wdg))
+ (when (zerop id)
+ (setf (sl:info (wedge-rot-readout dp)) "NONE"))
+ (setf (sl:info (wedge-sel-readout dp))
+ (wedge-label
+ id (machine (current-prism-bi dp))))))
+
+ (ev:add-notify dp (new-rotation (wedge (current-prism-bi dp)))
+ #'(lambda (dp wdg rot)
+ (cond ((zerop (id wdg))
+ (setf (sl:info (wedge-rot-readout dp)) "NONE"))
+ (t (let ((mach (machine (current-prism-bi dp))))
+ (setf (sl:info (wedge-rot-readout dp))
+ (first (scale-angle
+ rot
+ (wedge-rot-scale mach)
+ (wedge-rot-offset
+ mach))))))))))))))
+
+ ;; Deselect-Prism-Beam button pressed.
+ (ev:add-notify dp (sl:deselected p-bm-sl)
+ #'(lambda (dp a btn)
+ (declare (ignore a btn))
+ (when (current-prism-bi dp)
+ (ev:remove-notify dp (new-id (wedge (current-prism-bi dp))))
+ (ev:remove-notify dp (new-rotation (wedge (current-prism-bi dp)))))
+ (setf (original-prism-bi dp) nil)
+ (setf (copied-prism-bi dp) nil)
+ (setf (current-prism-bi dp) nil)
+ (clear-prism-bi-triple dp)))
+
+ ;; Add-Prism-Beam button pressed.
+ (ev:add-notify dp (sl:button-on add-prism-beam-bn)
+ #'(lambda (dp a)
+ (declare (ignore a))
+ (add-prism-beam-fcn dp t) ;New beam
+ (setf (sl:on add-prism-beam-bn) nil)))
+
+ ;; Add-Segment button pressed.
+ (ev:add-notify dp (sl:button-on add-seg-bn)
+ #'(lambda (dp a)
+ (declare (ignore a))
+ (add-prism-beam-fcn dp nil) ;Successor segment
+ (setf (sl:on add-seg-bn) nil)))
+
+ ;; Delete-Prism-Beam button pressed.
+ (ev:add-notify dp (sl:deleted output-sl)
+ #'(lambda (dp a btn)
+ (declare (ignore a))
+ (del-prism-beam-fcn dp btn)))
+
+ ;; "Dose Monitor Pts" button pressed.
+ (ev:add-notify dp (sl:button-on dmp-panel-bn)
+ ;;
+ ;; (OUTPUT-ALIST dp) is list [in reverse order] of objects, each:
+ ;; ( <Button> <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan>
+ ;; <New-Bm?> <SegColor> )
+ ;; <New-Bm? T:Static/:Dynamic[1st-of-seq], NIL:subsequent-of-seq>
+ ;;
+ ;; This list contains all Prism beams - that is, all segments for all
+ ;; Dicom beams, arranged int Dicom-beam order - all segments for one
+ ;; Dicom beam followed by all segments for the next, and so forth.
+ ;;
+ ;; CopyBmInst and CurrBmInst are both copied beams so that any changes
+ ;; to their collimators will not side-effect real Prism beam objects.
+ ;;
+ #'(lambda (dp a)
+ (declare (ignore a))
+ (let ((o-alist (output-alist dp)))
+ ;; Check to see if dose is calculated for all Prism beams.
+ ;; Allocation of DMPs requires all Prism-beam [segment] doses
+ ;; to be available.
+ (cond
+ ((consp o-alist)
+ (dolist (o-bmdata o-alist)
+ ;; Beam used for dose calculation is Original Prism beam.
+ ;; Only it contains DOSE-RESULT object in RESULT slot.
+ ;; It is passed indirectly as a component buried in patient's
+ ;; PLAN, which is first arg [fifth of O-BMDATA].
+ (unless (valid-points (result (second o-bmdata)))
+ (compute-dose-points (fifth o-bmdata) cur-pat)
+ (return)))
+ ;; Group Prism beam instances into Dicom beams here. Lists of
+ ;; Beams and DMPs passed to DMP Panel [and values cached on
+ ;; return] are Dicom-Beams and Dicom-DMPs.
+ (cond ((current-plan dp)
+ (run-dmp-panel
+ :parent-panel dp
+ :dicom-beam-list (pbeam->dbeam-grouper o-alist)
+ :dicom-dmp-list (dicom-dmp-list dp)
+ :dicom-dmp-cnt (dicom-dmp-cnt dp)))
+ (t (sl:acknowledge "No plan selected yet."))))
+ (t (sl:acknowledge no-bms/segs-msg)))
+ (setf (sl:on dmp-panel-bn) nil))))
+
+ ;; Send-Beams button pressed.
+ (ev:add-notify dp (sl:button-on send-beams-bn)
+ #'(lambda (dp a &aux dicom-pat-id p-bm-info (o-alist (output-alist dp))
+ (d-dmp-list (dicom-dmp-list dp)))
+
+ (declare (type list p-bm-info o-alist d-dmp-list)
+ (ignore a))
+
+ (block send-beams
+
+ (unless (consp o-alist)
+ (sl:acknowledge "No beams added; no beams transferred.")
+ (return-from send-beams))
+
+ ;; P-BM-INFO is a list, in forward order, each entry:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <PrismBmObj> )
+ ;; with one entry for each segment. Note that the list
+ ;; contains all Prism beams - that is, all segments for
+ ;; all Dicom beams. They are grouped into Dicom beams
+ ;; in order - all segments for one Dicom beam followed by
+ ;; all segs for the next, and so forth.
+ ;;
+ ;; CopyBmInst and CurrBmInst are both copied beams so that changes
+ ;; to their collimators will not side-effect real Prism beams.
+ ;;
+ (setq p-bm-info (generate-pbeam-info o-alist))
+
+ (unless (check-beam-constraints p-bm-info d-dmp-list)
+ (sl:acknowledge "Cancelled; no beams transferred.")
+ (return-from send-beams))
+
+ (unless (sl:confirm
+ '("Ready to transfer beams, but first you must enter"
+ "a nonblank Patient ID in the next dialog box."
+ ""
+ "The transfer may take a few minutes."
+ "A chart dialog box will be displayed when finished."
+ "During transfer, please wait for chart dialog box."
+ ""
+ "Ok to continue?"))
+ (sl:acknowledge "Transmission aborted; no beams transferred.")
+ (return-from send-beams))
+
+ (setq dicom-pat-id (sl:popup-textline
+ "" 600
+ :label
+ (format nil "Enter ID for ~A ~A: "
+ (hospital-id cur-pat)
+ (name cur-pat))
+ :title "Patient ID"))
+ (unless (and (typep dicom-pat-id 'simple-base-string)
+ (> (length (the simple-base-string dicom-pat-id)) 0))
+ (sl:acknowledge "No patient ID; no beams transferred.")
+ (return-from send-beams))
+
+ (sl:push-event-level) ; Long wait coming up - ignore user input.
+
+ (multiple-value-bind (status msg)
+ (send-dicom (assemble-dicom cur-pat p-bm-info
+ dicom-pat-id d-dmp-list)
+ d-dmp-list)
+ (declare (type fixnum status)
+ (type simple-base-string msg))
+ (cond
+ ((or (= status 0) ; success
+ (= status #xB000) ; codes defined by Elekta
+ (= status #xB006)
+ (= status #xB007))
+ (chart-panel 'dicom cur-pat nil
+ p-bm-info
+ (date-time-string)
+ "DICOM transfer"
+ dicom-pat-id))
+ (t (sl:acknowledge
+ (cond
+ ((< status 0)
+ ;; might look nicer if centered
+ (list "DICOM transfer failed." msg))
+ (t (list "DICOM transfer failed."
+ (format nil "~A (#x~4,'0X)"
+ (or (cdr (assoc status *status-alist*
+ :test #'=))
+ "Unknown error")
+ status))))))))
+
+ (sl:pop-event-level)) ; wait is over
+ (setf (sl:on send-beams-bn) nil)))
+
+ ;; Action function for X1 diaphragm textline.
+ ;; Elekta X1,X2 Y1,Y2 are Prism/Dicom y2,y1 x2,x2 respectively
+ (ev:add-notify dp (sl:new-info x1-tl) ; Elekta X1 is Prism Y2
+ #'(lambda (dp a info)
+ (declare (ignore a))
+ (cond ((current-prism-bi dp)
+ ;; Need FLOAT or COERCE here, or compiled code crashes.
+ ;; Had ROUND-DIGITS, but should no longer be necessary.
+ ;; Side-effect here on collimator of CURRENT-PRISM-BI while
+ ;; preserving collimator of original beam in real Prism plan.
+ (let ((data (coerce (read-from-string info) 'single-float)))
+ (setf (y2 (collimator (current-prism-bi dp))) data)
+ (setf (sl:info x1-tl) (format nil "~7,2F" data))))
+ (t (sl:acknowledge no-bm-sel-msg)
+ (setf (sl:info x1-tl) "")))))
+
+ ;; Action function for X2 diaphragm textline.
+ (ev:add-notify dp (sl:new-info x2-tl) ; Elekta X2 is Prism -Y1
+ #'(lambda (dp a info)
+ (declare (ignore a))
+ (cond ((current-prism-bi dp)
+ ;; Need FLOAT or COERCE here, or compiled code crashes.
+ ;; Had ROUND-DIGITS, but should no longer be necessary.
+ ;; Side-effect here on collimator of CURRENT-PRISM-BI while
+ ;; preserving collimator of original beam in real Prism plan.
+ (let ((data (coerce (read-from-string info) 'single-float)))
+ (setf (y1 (collimator (current-prism-bi dp))) (- data))
+ (setf (sl:info x2-tl) (format nil "~7,2F" data))))
+ (t (sl:acknowledge no-bm-sel-msg)
+ (setf (sl:info x2-tl) "")))))
+
+ ;; Action function for Y1 diaphragm textline.
+ (ev:add-notify dp (sl:new-info y1-tl) ; Elekta Y1 is Prism X2
+ #'(lambda (dp a info)
+ (declare (ignore a))
+ (cond ((current-prism-bi dp)
+ ;; Need FLOAT or COERCE here, or compiled code crashes.
+ ;; Had ROUND-DIGITS, but should no longer be necessary.
+ ;; Side-effect here on collimator of CURRENT-PRISM-BI while
+ ;; preserving collimator of original beam in real Prism plan.
+ (let ((data (coerce (read-from-string info) 'single-float)))
+ (setf (x2 (collimator (current-prism-bi dp))) data)
+ (setf (sl:info y1-tl) (format nil "~7,2F" data))))
+ (t (sl:acknowledge no-bm-sel-msg)
+ (setf (sl:info y1-tl) "")))))
+
+ ;; Action function for Y2 diaphragm textline.
+ (ev:add-notify dp (sl:new-info y2-tl) ; Elekta Y2 is Prism -X1
+ #'(lambda (dp a info)
+ (declare (ignore a))
+ (cond ((current-prism-bi dp)
+ ;; Need FLOAT or COERCE here, or compiled code crashes.
+ ;; Had ROUND-DIGITS, but should no longer be necessary.
+ ;; Side-effect here on collimator of CURRENT-PRISM-BI while
+ ;; preserving collimator of original beam in real Prism plan.
+ (let ((data (coerce (read-from-string info) 'single-float)))
+ (setf (x1 (collimator (current-prism-bi dp))) (- data))
+ (setf (sl:info y2-tl) (format nil "~7,2F" data))))
+ (t (sl:acknowledge no-bm-sel-msg)
+ (setf (sl:info y2-tl) "")))))
+
+ ;; Action function for Leaf textlines.
+ (do ((left-tls (left-leaf-textlines dp) (cdr left-tls))
+ (right-tls (right-leaf-textlines dp) (cdr right-tls)))
+ ((null left-tls))
+
+ ;; Action function for Left-Leaf textline.
+ (ev:add-notify dp (sl:new-info (car left-tls))
+ #'(lambda (dp tln info)
+ (cond
+ ((current-prism-bi dp)
+ ;; Need FLOAT or COERCE here, or compiled code crashes.
+ ;; Had ROUND-DIGITS, but should no longer be necessary.
+ ;; Side-effect here on collimator of CURRENT-PRISM-BI while
+ ;; preserving collimator of original beam in Prism plan.
+ (let ((pos (position tln (left-leaf-textlines dp) :test #'eq))
+ (ls (leaf-settings (collimator (current-prism-bi dp))))
+ (data (coerce (read-from-string info) 'single-float)))
+ (setf (sl:info tln) (format nil "~6,2F" data))
+ (setf (first (nth pos ls)) (- data)))) ; Elekta Y2, - sign
+ (t (sl:acknowledge no-bm-sel-msg)
+ (setf (sl:info tln) "")))))
+
+ ;; Action function for Right-Leaf textline.
+ (ev:add-notify dp (sl:new-info (car right-tls))
+ #'(lambda (dp tln info)
+ (cond
+ ((current-prism-bi dp)
+ ;; Need FLOAT or COERCE here, or compiled code crashes.
+ ;; Had ROUND-DIGITS, but should no longer be necessary.
+ ;; Side-effect here on collimator of CURRENT-PRISM-BI while
+ ;; preserving collimator of original beam in Prism plan.
+ (let ((pos (position tln (right-leaf-textlines dp) :test #'eq))
+ (ls (leaf-settings (collimator (current-prism-bi dp))))
+ (data (coerce (read-from-string info) 'single-float)))
+ (setf (sl:info tln) (format nil "~6,2F" data))
+ (setf (second (nth pos ls)) data))) ; Elekta Y1, same sign
+ (t (sl:acknowledge no-bm-sel-msg)
+ (setf (sl:info tln) ""))))))
+
+ ;; Preview-Chart button pressed.
+ (ev:add-notify dp (sl:button-on preview-chart-bn)
+ #'(lambda (dp a)
+ (declare (ignore a))
+ ;; Note in preview here, we do NOT use DICOM-PAT-ID as Patient ID
+ (let ((o-alist (output-alist dp)))
+ (cond ((consp o-alist)
+ (chart-panel 'dicom cur-pat nil
+ (generate-pbeam-info o-alist)
+ (date-time-string)
+ "Chart preview"
+ (hospital-id cur-pat)))
+ (t (sl:acknowledge no-bms/segs-msg))))
+ (setf (sl:on preview-chart-bn) nil)))
+
+ ;; Delete-Panel button pressed.
+ (ev:add-notify dp (sl:button-on del-panel-bn)
+ #'(lambda (dp a)
+ (declare (ignore a))
+ (destroy dp)))))
+
+;;;-------------------------------------------------------------
+
+(defmethod (setf current-plan) :after (new-plan (dp dicom-panel))
+
+ (let ((p-bm-sl (prism-beam-scrollinglist dp)))
+ (cond (new-plan
+ ;; Fill up Prism-beams scrolling list and alist w/ new info --
+ ;; only beams w/collimators of type multileaf-coll are considered.
+ ;; ORIG-PBI is an [uncopied] Original-Prism-Beam instance.
+ (dolist (orig-pbi (coll:elements (beams new-plan)))
+ (let ((b-bn (sl:make-list-button p-bm-sl (name orig-pbi))))
+ (sl:insert-button b-bn p-bm-sl)
+ (push (cons b-bn orig-pbi) (prism-beam-alist dp))))
+ ;; fill in plan readout
+ (setf (sl:info (plan-readout dp))
+ (format nil "~A ~A"
+ (name new-plan) (time-stamp new-plan)))
+ ;; fill in plan-specific info on panel
+ (setf (sl:info (comments-box dp)) (comments new-plan)))
+
+ ;; Clean out Prism-beams scrolling list and alist.
+ (t (dolist (b-bn (sl:buttons p-bm-sl))
+ (sl:delete-button b-bn p-bm-sl))
+ (setf (prism-beam-alist dp) nil) ;; clear plan info on panel
+ (setf (sl:info (plan-readout dp)) "")
+ (setf (sl:info (comments-box dp)) '(""))))))
+
+;;;-------------------------------------------------------------
+
+(defun prism-beam-problems (orig-pbi dp)
+
+ "prism-beam-problems orig-pbi dp
+
+Returns a list of strings describing problems with Prism beam
+instance ORIG-PBI on panel DP, or NIL if there are none."
+
+ (let* ((mach (machine orig-pbi))
+ (wedge-id (id (wedge orig-pbi)))
+ (mach-name (name mach))
+ (mach-ident (ident mach))
+ ;; BEAMS-TO-GO is list of CurrBmInst objects.
+ (beams-to-go (mapcar #'fourth (output-alist dp)))
+ (problem-list '()))
+
+ (when (and (> wedge-id 0)
+ (string/= (wedge-label wedge-id mach) "Fixed Wedge")
+ (coll:elements (blocks orig-pbi)))
+ (push "External wedge and external blocks not possible in same beam."
+ problem-list))
+
+ (cond ((and (consp mach-ident)
+ (= (length mach-ident) 5))
+ (let ((machine-id (first mach-ident)))
+ (when (consp beams-to-go)
+ (let ((send-machine-id
+ (first (ident (machine (car beams-to-go))))))
+ (unless (string= machine-id send-machine-id)
+ (push (format nil "~A ID ~A differs from ~A in output list."
+ mach-name machine-id send-machine-id)
+ problem-list))))))
+ (t (push (format nil "No Dicom server defined for ~A." mach-name)
+ problem-list)))
+
+ problem-list))
+
+;;;-------------------------------------------------------------
+
+(defun add-prism-beam-fcn (dp new-beam? &aux segl vl wl (e1 0.0) (e2 0.0)
+ (o-alist (output-alist dp))
+ ;; Original [uncopied] Prism beam:
+ (orig-pbi (original-prism-bi dp))
+ ;; Current copied/non-mutated BmInst:
+ (copy-pbi (copied-prism-bi dp))
+ ;; Current copied/mutated BmInst:
+ (curr-pbi (current-prism-bi dp))
+ last-seg-info last-pbi curr-mach)
+
+ "add-prism-beam-fcn dp new-beam?
+
+Adds triple of OrigBmInst, CopyBmInst, and CurrBmInst [and some other data]
+to (output-alist dp). If NEW-BEAM? is T, it is an independent beam or first
+in a multi-segment Dicom beam. If NEW-BEAM? is NIL, handle it as a successor
+segment in multisegment beam."
+
+ ;; OUTPUT-ALIST is still in reverse order [last beam added is at front].
+
+ (declare (type (member nil t) new-beam?)
+ (type list o-alist)
+ (type single-float e1 e2))
+
+ (cond
+ ((null (current-plan dp))
+ (sl:acknowledge "No plan selected yet."))
+
+ ;; Before invoking this function, user must have selected a beam
+ ;; [via pressing the "Select-Prism-Beam" button], which checks
+ ;; that the selected beam comes from the same physical machine
+ ;; as did any previous segments [different energy is OK].
+ ;; That user has already selected a beam is checked here.
+ ((or (null orig-pbi)
+ (null copy-pbi)
+ (null curr-pbi))
+ (sl:acknowledge "No beam selected yet."))
+
+ ;; Attempt to add a segment on first beam addition.
+ ((and (null o-alist)
+ (not new-beam?))
+ (sl:acknowledge "You must add a beam before you add a segment."))
+
+ ((progn
+ ;; CURR-PBI must be non-NIL [checked above].
+ (setq curr-mach (machine curr-pbi)) ;Machine of current BmInst
+ (when (consp o-alist)
+ (setq last-seg-info (cdr (first o-alist)) ;Previously-added beam info
+ last-pbi (third last-seg-info))) ;Prev current/mutated BmInst
+ ;; Return NIL so COND clause processing continues.
+ nil))
+
+ ;; LAST-SEG-INFO [if O-ALIST is non-empty] is:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <New-Bm?> <SegColor> )
+ ;; <New-Bm? T:Static/:Dynamic[1st-of-seq], NIL:subsequent-of-seq>
+ ;;
+ ;; CopyBmInst and CurrBmInst are both copied beams so that changes
+ ;; to their collimators will not side-effect real Prism beams.
+
+ ;; Check segment matches preceding segments.
+ ((setq segl (and (not new-beam?)
+ (consp o-alist)
+ (segment-violations last-pbi curr-pbi)))
+ (sl:acknowledge
+ (cons (format nil
+ "~S does not match preceding segment; cannot add."
+ (name curr-pbi))
+ segl)))
+
+ ;; Check for Wedge IN/OUT segment pair with altered leaf settings.
+ ((and (not new-beam?) ;Forgotten condition added Nov 1 2004.
+ (= (length o-alist) 1) ;2 segs [including one being added]
+ ;; O-ALIST non-empty -> LAST-PBI is a legitimate beam.
+ (let ((wedge-name1 (wedge-label (id (wedge last-pbi)) curr-mach))
+ (wedge-name2 (wedge-label (id (wedge curr-pbi)) curr-mach)))
+ (declare (type simple-base-string wedge-name1 wedge-name2))
+ (and (or (and (string= wedge-name1 "Fixed Wedge")
+ (string/= wedge-name2 "Fixed Wedge"))
+ (and (string/= wedge-name1 "Fixed Wedge")
+ (string= wedge-name2 "Fixed Wedge")))
+ (not (equal (leaf-settings (collimator last-pbi))
+ (leaf-settings (collimator curr-pbi))))
+ (not (sl:confirm
+ '("Leaf-settings changed on"
+ "Wedge IN/OUT segment pair."
+ ""
+ "OK to proceed?")))))))
+
+ ;; Check energy constraints [this is a warning for successor
+ ;; segments, not an enforceable constraint]. If new beam, or
+ ;; if segment but energies are equal, or if seg and energies differ
+ ;; but user confirms positively, continue. Otherwise trap.
+ ;;
+ ;; NB: If NEW-BEAM? is NIL, then O-ALIST must be non-empty [checked
+ ;; above] and therefore LAST-PBI must be a legitimate beam.
+ ((not (or new-beam?
+ (= (setq e1 (energy (machine last-pbi)))
+ (setq e2 (energy curr-mach)))
+ (sl:confirm
+ (list "Energy difference between segments:"
+ (format nil "~F <--> ~F" e1 e2)
+ ""
+ "Add this segment anyway?")))))
+
+ ;; Check collim-constraint-violations.
+ ((setq vl (collim-constraint-violations (collimator curr-pbi)))
+ (let ((vll (last vl 25))) ; vl might be very long!
+ (sl:acknowledge
+ (cons (format nil "Constraint violation in ~S; cannot send."
+ (name curr-pbi))
+ vll))))
+
+ (t (setq wl (collim-warnings (collimator copy-pbi)
+ (collimator curr-pbi)))
+ (when (if wl
+ ;; Check COLLIM-WARNINGS, optionally exit.
+ (sl:confirm
+ (append
+ (list (format nil "Warnings for ~A"
+ (name curr-pbi)))
+ (if (<= (length wl) 25)
+ wl
+ (subseq wl 0 25))
+ '("" "Add beam to output list anyway?")))
+ t)
+ ;; OK - add the Prism beam instances to the output list.
+ (let ((a-bn (sl:make-list-button
+ (output-scrollinglist dp)
+ (format nil "~A - ~A"
+ (name curr-pbi)
+ (if new-beam?
+ (name (current-plan dp))
+ "SEGMENT"))
+ :button-type :momentary))
+ (seg-color (if (consp last-seg-info)
+ (sixth last-seg-info)
+ 0)))
+ (declare (type fixnum seg-color))
+ (when new-beam?
+ ;; Change color on each new Dicom beam.
+ (setq seg-color
+ (mod (the fixnum (1+ seg-color))
+ (length (the (simple-array t 1) color-seq)))))
+ (setf (sl:bg-color a-bn)
+ (svref (the (simple-array t 1) color-seq) seg-color)
+ (sl:fg-color a-bn) 'sl:black)
+ (sl:insert-button a-bn (output-scrollinglist dp))
+ ;; We use this list much like a struct, but we use
+ ;; LIST not STRUCT, so COPY-TREE works right; we must
+ ;; avoid sharing structure. First element A-BN is key, and
+ ;; rest of list is the datalist portion of the assoc list.
+ (push (list a-bn
+ orig-pbi ;Original Prism beam
+ copy-pbi ;Copied original beam
+ curr-pbi ;Copied/mutated beam
+ (current-plan dp)
+ new-beam?
+ seg-color)
+ (output-alist dp)))))))
+
+;;;-------------------------------------------------------------
+
+(defun segment-violations (last-seg-pbi curr-pbi)
+
+ "segment-violations last-seg-pbi curr-pbi
+
+Returns a list of strings describing why CURR-PBI cannot be a segment
+in the multisegment Dicom beam whose last segment was LAST-SEG-PBI,
+or NIL if there are none [everything is OK]."
+
+ ;; All beam instances here [LAST-SEG-PBI and CURR-PBI] are copies made
+ ;; from original beam in Prism plan.
+
+ (let ((gan1 (gantry-angle last-seg-pbi))
+ (gan2 (gantry-angle curr-pbi))
+ (coll1 (collimator-angle last-seg-pbi))
+ (coll2 (collimator-angle curr-pbi))
+ (nfrac1 (n-treatments last-seg-pbi))
+ (nfrac2 (n-treatments curr-pbi))
+ (turnt1 (couch-angle last-seg-pbi))
+ (turnt2 (couch-angle curr-pbi))
+ (lat1 (couch-lateral last-seg-pbi))
+ (lat2 (couch-lateral curr-pbi))
+ (long1 (couch-longitudinal last-seg-pbi))
+ (long2 (couch-longitudinal curr-pbi))
+ (hght1 (couch-height last-seg-pbi))
+ (hght2 (couch-height curr-pbi))
+ ;; If external wedge, must be the same.
+ ;; MLC fields can't have blocks.
+ (problem-list nil))
+
+ (declare (type single-float gan1 gan2 coll1 coll2 turnt1 turnt2
+ lat1 lat2 long1 long2 hght1 hght2)
+ (type fixnum nfrac1 nfrac2))
+
+ (unless (poly:nearly-equal hght1 hght2)
+ (push (format nil "Couch height ~5,1F differs from ~5,1F" hght2 hght1)
+ problem-list))
+ (unless (poly:nearly-equal long1 long2)
+ (push (format nil "Couch longitudinal position ~5,1F differs from ~5,1F"
+ long2 long1)
+ problem-list))
+ (unless (poly:nearly-equal lat1 lat2)
+ (push (format nil "Couch lateral position ~5,1F differs from ~5,1F"
+ lat2 lat1)
+ problem-list))
+ (unless (poly:nearly-equal turnt1 turnt2)
+ (push (format nil "Couch angle ~5,1F differs from ~5,1F" turnt2 turnt1)
+ problem-list))
+ (unless (poly:nearly-equal coll1 coll2)
+ (push (format nil "Collimator angle ~5,1F differs from ~5,1F"
+ coll2 coll1)
+ problem-list))
+ (unless (poly:nearly-equal gan1 gan2)
+ (push (format nil "Gantry angle ~5,1F differs from ~5,1F" gan2 gan1)
+ problem-list))
+ (when (< 0.1 (arc-size last-seg-pbi))
+ (push "Last segment was an arc field" problem-list))
+ (when (< 0.1 (arc-size curr-pbi))
+ (push "Current Prism beam is an arc field" problem-list))
+ (unless (= nfrac1 nfrac2)
+ (push (format nil "Number of fractions ~D differs from ~D" nfrac2 nfrac1)
+ problem-list))
+
+ problem-list))
+
+;;;-------------------------------------------------------------
+
+(defun del-prism-beam-fcn (dp btn &aux (o-alist (output-alist dp)))
+
+ "del-prism-beam-fcn dp btn
+
+Delete the Prism beam instances indicated by BTN from output list on panel DP.
+If deleted beam is initial segment in a sequence, mark next segment initial."
+
+ ;; PAIR is an item of this form:
+ ;; ( <Button> <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan>
+ ;; <New-Bm?> <SegColor> )
+ ;; <New-Bm? T:Static/:Dynamic[1st-of-seq], NIL:subsequent-of-seq>
+ ;;
+ ;; (OUTPUT-ALIST dp) and the variable O-ALIST is a list [in reverse order]
+ ;; of objects, each of form shown above.
+ ;;
+ (cond ((consp o-alist)
+ (let* ((pair (assoc btn o-alist :test #'eq))
+ (pair-pos (position pair o-alist :test #'eq)))
+ ;; Prev will be next - O-ALIST is in reverse order.
+ (when (> pair-pos 0)
+ (let* ((prev-pos (1- pair-pos))
+ (prev-pair (nth prev-pos o-alist)))
+ ;; If deleting first in sequence, mark next as initial.
+ (when (and (sixth pair)
+ (not (sixth prev-pair)))
+ (setf (sixth prev-pair) t))))
+ (setf (output-alist dp) (delete pair o-alist :test #'eq))))
+ (t (sl:acknowledge "No beams or segments added yet."))))
+
+;;;-------------------------------------------------------------
+
+(defun setup-prism-bi-triple (new-pbi dp)
+
+ ;; NEW-PBI is a Current-Prism-Beam instance [ie, copy of OrigBmInst].
+ ;; Places copies of collimator of OrigBmInst in COPIED-PRISM-BI [converted
+ ;; to MLC but not later modified] and in CURRENT-PRISM-BI [converted to MLC,
+ ;; modified by MAKE-FLAGPOLE and MAKE-ADJUSTED-ENDS, and possibly later
+ ;; modified by user].
+ ;;
+ ;; This copying provides a MLC for comparison between COPIED-PRISM-BI's and
+ ;; CURRENT-PRISM-BI's collimators, to check for user modifications, while
+ ;; protecting original Prism plan's collimator from side-effects.
+
+ (let ((mach (machine new-pbi)))
+
+ (let ((collim (make-multileaf-coll
+ (collimator-angle new-pbi)
+ (typecase (collimator new-pbi)
+ (multileaf-coll (get-mlc-vertices new-pbi))
+ ;; VJC, rotate by collimator-angle
+ ;; to compensate for rotation in MAKE-MULTILEAF-COLL.
+ ;; See GET-MLC-VERTICES in "mlc.cl".
+ ;; What's distinction between portal and vertices?
+ (variable-jaw-coll
+ (poly:rotate-vertices
+ (portal (collimator new-pbi))
+ (collimator-angle new-pbi)))
+ (otherwise nil))
+ (typecase (collimator new-pbi)
+ (multileaf-coll (collim-info dp))
+ (otherwise *sl-collim-info*)))))
+
+ (setf (collimator (copied-prism-bi dp)) collim)
+ (setf (collimator new-pbi) (make-adjusted-ends (make-flagpole collim))))
+
+ (setf (sl:info (prism-beam-readout dp)) (name new-pbi))
+
+ (setf (sl:info (gantry-start-readout dp))
+ (format nil "~6,1F" (first (scale-angle
+ (gantry-angle new-pbi)
+ (gantry-scale mach)
+ (gantry-offset mach)))))
+ (setf (sl:info (gantry-stop-readout dp))
+ (format nil "~6,1F"
+ (mod (+ (gantry-angle new-pbi)
+ (arc-size new-pbi))
+ 360.0)))
+
+ (setf (sl:info (couch-angle-readout dp))
+ (format nil "~6,1F" (first (scale-angle
+ (couch-angle new-pbi)
+ (turntable-scale mach)
+ (turntable-offset mach)))))
+
+ (let ((mu-tot (monitor-units new-pbi))
+ (num-frac (n-treatments new-pbi)))
+ (declare (type single-float mu-tot)
+ (type fixnum num-frac))
+ (setf (sl:info (n-treat-readout dp)) num-frac)
+ (setf (sl:info (tot-mu-readout dp)) (format nil "~6,1F" mu-tot))
+ (setf (sl:info (mu-treat-readout dp))
+ (format nil "~6,1F" ;Division by zero check.
+ (cond ((= num-frac 0) 0.0)
+ (t (/ mu-tot num-frac))))))
+
+ (setf (sl:info (coll-angle-readout dp))
+ (format nil "~6,1F" (first (scale-angle
+ (collimator-angle new-pbi)
+ (collimator-scale mach)
+ (collimator-offset mach)))))
+
+ (setf (sl:info (wedge-sel-readout dp))
+ (wedge-label (id (wedge new-pbi)) mach))
+ (setf (sl:info (wedge-rot-readout dp))
+ (cond ((= (id (wedge new-pbi)) 0)
+ "NONE")
+ (t (first (scale-angle
+ (rotation (wedge new-pbi))
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach))))))
+
+ ;; set the leaf textline values
+ (do* ((left-tls (left-leaf-textlines dp) (cdr left-tls))
+ (right-tls (right-leaf-textlines dp) (cdr right-tls))
+ (leaves (leaf-settings (collimator new-pbi)) (cdr leaves))
+ (leaf-pair (first leaves) (first leaves)))
+ ((null leaves))
+ (setf (sl:info (car left-tls))
+ ;; Elekta Y2 leaves in -x plane are shown as positive positions
+ (format nil "~6,2F" (- (first leaf-pair))))
+ (setf (sl:info (car right-tls))
+ (format nil "~6,2F" (second leaf-pair))))
+
+ ;; Elekta X1,X2, Y1,Y2 are Prism/Dicom y2,-y1, x2,-x1 respectively
+ (setf (sl:info (x1-textline dp))
+ (format nil "~7,2F" (y2 (collimator new-pbi))))
+ (setf (sl:info (x2-textline dp))
+ (format nil "~7,2F" (- (y1 (collimator new-pbi)))))
+ (setf (sl:info (y1-textline dp))
+ (format nil "~7,2F" (x2 (collimator new-pbi))))
+ (setf (sl:info (y2-textline dp))
+ (format nil "~7,2F" (- (x1 (collimator new-pbi)))))
+
+ (setf (sl:info (machine-readout dp)) (name mach))
+ (setf (sl:info (id-readout dp)) (car (ident mach)))))
+
+;;;-------------------------------------------------------------
+
+(defun clear-prism-bi-triple (dp)
+
+ (setf (sl:info (prism-beam-readout dp)) "")
+ (setf (sl:info (gantry-start-readout dp)) "")
+ (setf (sl:info (gantry-stop-readout dp)) "")
+ (setf (sl:info (couch-angle-readout dp)) "")
+ (setf (sl:info (n-treat-readout dp)) "")
+ (setf (sl:info (tot-mu-readout dp)) "")
+ (setf (sl:info (mu-treat-readout dp)) "")
+ (setf (sl:info (coll-angle-readout dp)) "")
+ (setf (sl:info (wedge-sel-readout dp)) "")
+ (setf (sl:info (wedge-rot-readout dp)) "")
+
+ (mapc #'(lambda (l-rd r-rd)
+ (setf (sl:info l-rd) "")
+ (setf (sl:info r-rd) ""))
+ (left-leaf-textlines dp)
+ (right-leaf-textlines dp))
+
+ (setf (sl:info (x1-textline dp)) "")
+ (setf (sl:info (x2-textline dp)) "")
+ (setf (sl:info (y1-textline dp)) "")
+ (setf (sl:info (y2-textline dp)) "")
+ (setf (sl:info (id-readout dp)) "")
+ (setf (sl:info (machine-readout dp)) ""))
+
+;;;=============================================================
+
+(defun make-dicom-panel (cur-pat &rest initargs)
+
+ "make-dicom-panel cur-pat &rest initargs
+
+Creates and returns a Dicom panel with the specified initargs."
+
+ (cond ((> (the fixnum (patient-id cur-pat)) 0)
+ (apply #'make-instance 'dicom-panel
+ :current-patient cur-pat
+ :dicom-dmp-cnt 0
+ initargs))
+ (t (sl:acknowledge "Please select a patient first."))))
+
+;;;-------------------------------------------------------------
+
+(defmethod destroy ((dp dicom-panel))
+
+ "Unmap the panel's frame."
+
+ (setf (plan-alist dp) nil)
+ (setf (prism-beam-alist dp) nil)
+ (setf (output-alist dp) nil)
+ (setf (current-patient dp) nil)
+ (setf (current-plan dp) nil)
+ (let ((tmp (current-prism-bi dp)))
+ (when (and tmp (setq tmp (wedge tmp)))
+ (ev:remove-notify dp (new-id tmp))
+ (ev:remove-notify dp (new-rotation tmp))))
+ (setf (original-prism-bi dp) nil)
+ (setf (copied-prism-bi dp) nil)
+ (setf (current-prism-bi dp) nil)
+ (clear-prism-bi-triple dp)
+ (setf (collim-info dp) nil)
+ (sl:destroy (del-panel-button dp))
+ (sl:destroy (add-prism-beam-button dp))
+ (sl:destroy (send-beams-button dp))
+ (sl:destroy (preview-chart-button dp))
+ (sl:destroy (add-seg-button dp))
+ (sl:destroy (dmp-panel-button dp))
+ (sl:destroy (comments-box dp))
+ (sl:destroy (comments-label dp))
+ (sl:destroy (prism-beam-readout dp))
+ (sl:destroy (plan-readout dp))
+ (sl:destroy (prism-beam-label dp))
+ (sl:destroy (plan-label dp))
+ (sl:destroy (output-label dp))
+ (sl:destroy (gantry-start-readout dp))
+ (sl:destroy (gantry-stop-readout dp))
+ (sl:destroy (n-treat-readout dp))
+ (sl:destroy (tot-mu-readout dp))
+ (sl:destroy (mu-treat-readout dp))
+ (sl:destroy (coll-angle-readout dp))
+ (sl:destroy (couch-angle-readout dp))
+ (sl:destroy (wedge-sel-readout dp))
+ (sl:destroy (wedge-rot-readout dp))
+ (sl:destroy (x1-textline dp))
+ (sl:destroy (x2-textline dp))
+ (sl:destroy (y1-textline dp))
+ (sl:destroy (y2-textline dp))
+ (mapc #'sl:destroy (left-leaf-textlines dp))
+ (mapc #'sl:destroy (right-leaf-textlines dp))
+ (setf (left-leaf-textlines dp) nil)
+ (setf (right-leaf-textlines dp) nil)
+ ;; Remove event notifications before destroying scrolling lists.
+ (dolist (sl (list (plan-scrollinglist dp)
+ (prism-beam-scrollinglist dp)
+ (output-scrollinglist dp)))
+ (setf (sl:selected sl) nil)
+ (setf (sl:deselected sl) nil)
+ (setf (sl:inserted sl) nil)
+ (setf (sl:deleted sl) nil)
+ (sl:destroy sl))
+ (sl:destroy (machine-readout dp))
+ (sl:destroy (id-readout dp))
+ (sl:destroy (frame dp)))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/dicom-rtplan.cl b/prism/src/dicom-rtplan.cl
new file mode 100644
index 0000000..c35d858
--- /dev/null
+++ b/prism/src/dicom-rtplan.cl
@@ -0,0 +1,1177 @@
+;;;
+;;; dicom-rtplan
+;;;
+;;; Support for Dicom RT Plan and related modules.
+;;; Contains functions used in Client only.
+;;;
+;;; 29-Jun-2000 J. Jacky Separate out from dicom-panel.cl
+;;; 2-Aug-2000 J. Jacky Finish first version with stub send-dicom
+;;; Aug-2000 BobGian Fill in send-dicom, add delistify-leaves,
+;;; cm to mm conversion, other minor revisions
+;;; 30-Aug-2000 J. Jacky Add beam type, radiation type, machine name,
+;;; beam energy
+;;; Put tags in ascending tag number order
+;;; 31-Aug-2000 J. Jacky More tag order fixes
+;;; Add several missing type 1 and 2 attributes
+;;; 1-Sep-2000 J. Jacky More minor fixes
+;;; delistify-leaves: rearrange leaf order also
+;;; 5-Sep-2000 J. Jacky Prism = IEC1217 so don't scale gan-,couch-,coll-rot
+;;; delistify-leaves: also reverse y-ordering of leaves
+;;; 6-Sep-2000 J. Jacky Y diaphragms(coll-ymin,ymax) cover all closed leaves
+;;; 8-Sep-2000 J. Jacky assemble-beams:use cached leaf-settings,don't recalc
+;;; 11-Sep-2000 J. Jacky dicom-date-time: fix single-digit-hour bug
+;;; Calc coll-xmin etc. from new x1 etc. collimator
+;;; 8-Nov-2000 J. Jacky Always include Wedge Position Seq. #x0116 in ctrl pt
+;;; so can simplify list construction, omit appends
+;;; Cumulative Meterset Weight #x0134 is always 100
+;;; in static field
+;;; Final Cum. Meterset Weight #x010E is always 100
+;;; Absolute monitor units specified only in
+;;; Beam Meterset #x0086
+;;; 13-Nov-2000 J. Jacky In Wedge Pos. Seq., put Pos,Num in ascending order
+;;; Nest Wedge Pos. Seq. one level deeper using (list )
+;;; 1-Dec-2000 J. Jacky Rename Dicom.Log to ~/dicom/log/dicom.dat
+;;; Rename *dicom-log-file* to *dicom-data-file*
+;;; Rename log-dicom to log-dicom-data
+;;; New log-dicom-transfer
+;;; 8-Dec-2000 J. Jacky send-dicom: collect, return RUN-CLIENT status, msgs
+;;; 19-Jun-2001 J. Jacky send-dicom: handle :send-enabled feature
+;;; 21-Jun-2001 J. Jacky use Prism machine ident not name for machine-name B2
+;;; use Prism machine name for beam description C3
+;;; 21-Jun-2001 BobGian remove :send-enabled feature for "production" vers.
+;;; 27-Jul-2001 J. Jacky read-from-string with :start to get case-id
+;;; Revise description items so RTD display more helpful
+;;; 31-Aug-2001 BobGian SEND-DICOM and RUN-CLIENT return status message
+;;; as single string rather than as list of strings.
+;;; 14-Sep-2001 J. Jacky assemble-fractions,-beams: handle segment info
+;;; 18-Sep-2001 J. Jacky assemble-fractions,-beams: use new beam-rec,seg-rec
+;;; 19-Sep-2001 J. Jacky assemble-fractions: preprocess out segments first
+;;; replace beam-rec with list
+;;; 24-Sep-2001 J. Jacky replace assemble-beams w/new assemble-beam-sequence
+;;; 28-Sep-2001 J. Jacky remove r-mu-per-frac, not useful for segmented beams
+;;; 1-Oct-2001 J. Jacky assemble-control-point: include wedge, collim at cp1
+;;; 26-Oct-2001 J. Jacky assemble-beam: represent ext. wedge as shadow tray
+;;; 2-Nov-2001 J. Jacky assemble-beam: represent ext. blocks as shadow tray
+;;; 5-Dec-2001 J. Jacky assemble-dicom: dicom-pat-id argument
+;;; 10-Dec-2001 J. Jacky log-dicom-transfer: log new dicom-pat-id
+;;; 23-Jan-2002 BobGian *dicom-data-file* -> *pdr-data-file* (maybe temp).
+;;; 18-Feb-2002 BobGian dicom::*dicom-log-dir* -> Prism pkg.
+;;; 9-Apr-2002 J.Jacky assemble-control-point: fix round error in cp0-mu
+;;; 9-May-2002 BobGian arg to RUN-CLIENT changed from :C-Store-RTPlan
+;;; to :C-Store-RTPlan-RQ (consistency w frag version).
+;;; 19-Jun-2002 J.Jacky assemble beam: make 300A,00C4 "STATIC" not "DYNAMIC"
+;;; 16-Sep-2002 J.Jacky Remove client-ae-title argument from RUN-CLIENT
+;;; 27-Aug-2003 BobGian add Dose-Monitoring Points.
+;;; 08-Sep-2003 BobGian ASSEMBLE-FRACTIONS -> ASSEMBLE-FRACTION-GROUPS.
+;;; 19-Sep-2003 BobGian DMP carries coords in Dicom convention [in mm,
+;;; rounded to fixed precision], so these are used to
+;;; construct data rather than rounding here.
+;;; 03-Oct-2003 BobGian: Change defstruct name and slot names in SEG-REC-...
+;;; to SEGMENT-DESCRIPTOR-... to make DMP code more readable.
+;;; Ditto with a few local variables.
+;;; STATIC, DYNAMIC, SEGMENT (Prism pkg) -> Keyword pkg.
+;;; 20-Oct-2003 BobGian: Move DMP defstruct "dicom-panel" -> here
+;;; to simplify dependencies.
+;;; 30-Oct-2003 BobGian: dicom::DUMP-DICOM-DATA, new pretty-printer and data
+;;; formatter, replaces old LOG-DICOM-DATA to enable finer-grained
+;;; debugging. Same dumper is used for Server, so code is moved to
+;;; "utilities.cl" (file common to both). LOG-DICOM-DATA serves
+;;; as driver to send dicom::DUMP-DICOM-DATA output to file.
+;;; Also much debugging to finish and correct implementation of DMPs.
+;;; 14-Nov-2003 BobGian: Modularize function ASSEMBLE-BEAM-SEQUENCE.
+;;; More testing and debugging.
+;;; 18-Nov-2003 BobGian:
+;;; 1: Fixed a few stubborn bugs involving pooling of DMPs over all segments
+;;; in a beam. Tests producing dumped output now match desired [from
+;;; Dicom spec] completely. Ready for testing against real Elekta server.
+;;; 2: If slot is empty, tag not sent either [for DMPs only - some tags and
+;;; empty slots are required for other items].
+;;; 3: Implemented and optimized uniquization of DMPs.
+;;; 4: DMP auto-replication [one per beam + one for group of shared beams]
+;;; added - must be in post-processing [while generating data stream,
+;;; after all user-interface operations completed].
+;;; 5: ASSEMBLE-BEAM-SEQUENCE modularized/factored for better clarity.
+;;; 19-Nov-2003 BobGian: Correct implementation of auto-replication of DMPs
+;;; to get one for per-beam use and one for use shared by common beams.
+;;; 21-Nov-2003 BobGian:
+;;; 1: Plan name, slots 300A:0002 and 300A:0003 (formerly timestamp) changed.
+;;; If Prism plan name fits in 16 chars, 300A:0002 holds it and 300A:0003
+;;; is present but empty. If plan name fits in 64 chars, 300A:0002 is a
+;;; dummy stub "RT-Plan" while 300A:0003 holds Prism plan name. Ditto if
+;;; plan name > 64 chars except plan name is truncated to 64 chars. This
+;;; is because 300A:0002 is limited to 16 and 300A:0003 to 64 chars.
+;;; 2: Rounding after cGy -> Gy removed because cGy inputs already are
+;;; represented as fixnum values anyway.
+;;; 24-Nov-2003 BobGian:
+;;; 1: DMP auto-replication scheme altered. DMP slots renamed.
+;;; TOTAL-DOSE, DAILY-DOSE, and PRIOR-DOSE are accumulated values for
+;;; a single beam only. If same DMP is selected for another beam too
+;;; [ie, becomes shared between beams], existing values of these slots
+;;; are pushed onto stacks held in slots OTHER-xxx-DOSES and current slots
+;;; are cleared any used for current-beam-only values. When data are
+;;; passed from Dicom panel to the Dicom interface, ADD-SEG-INFO expands
+;;; and auto-replicates shared DMPs automatically, using the current and
+;;; the OTHER-xxx-DOSES slot values. [See changelog notes, same date, in
+;;; files "dicom-panel" and "imrt-segments".]
+;;; 2: Added NAME slot to DMP; holds POINT name unless DMP is shared by more
+;;; than one beam, in which case each auto-replicated DMP gets a name
+;;; formed by concatenating point name and beam name.
+;;; 26-Nov-2003 BobGian:
+;;; 1: DMP auto-replication scheme polished, esp dose coefficient portion.
+;;; 2: Plan name [see 21-Nov-2003, #1] modified to put full plan name in
+;;; slot 300A:0002 and leave out 300A:0003 if name fits. Otherwise, put
+;;; first 16 chars in 300A:0002 and rest in 300A:0003 [truncated to 64
+;;; chars total if necessary].
+;;; 3: Fixed LOG-DICOM-TRANSFER - wrong tag group number for plan timestamp.
+;;; 4: Slot 300A:0004 Plan Description truncated to 1024 chars if necessary.
+;;; 5: Slot 300A:00C2 Beam Name truncated to 64 chars if necessary.
+;;; 300A:0016 DMP Name limited to 64 chars, checked when DMP created.
+;;; 0010:0010 and 0010:1000 limited to 64 chars but checked elsewhere.
+;;; 28-Nov-2003 BobGian: Move DMP defstruct here -> "imrt-segments" to
+;;; simplify dependencies.
+;;; 01-Dec-2003 BobGian:
+;;; 1: Fix slots where dose may contribute to single DMP from multiple beams
+;;; (300A:001A, 300A:0027).
+;;; 2: Fix slots where dose at DMP is calculated as proportion of dose to
+;;; result object (300A:0084, 300A:010C).
+;;; 04-Dec-2003 BobGian: SEGMENT-DESCRIPTOR-... -> SEGDATA-... (less clutter).
+;;; 25-Dec-2003 BobGian: Flushed all "...OTHER-..." slots. Now allocate a
+;;; separate DMP object for each segment in which the DMP appears, linking
+;;; them through the list in the DMP-SEGLIST slot of each so that dose can
+;;; be accumulated properly across all segments in a single beam.
+;;; 28-Dec-2003 BobGian: DMP slots ...-dose -> ...-cGy to emphasize dose units.
+;;; 27-Jan-2004 BobGian began integration of new DMP Panel by Mark Phillips
+;;; with rest of Dicom Panel and interface to Dicom SCU.
+;;; 19-Feb-2004 BobGian: Modfied norm-point mechanism to use a fictitious
+;;; norm point with dose 1.0 Gray and coordinates (0.0 0.0 0.0)
+;;; [coordinates are ignored by Elekta].
+;;; 19-Feb-2004 BobGian - introduced uniform naming convention explained
+;;; in file "imrt-segments". This includes:
+;;; SEGDATA-... -> PR-BEAM-...
+;;; 26-Feb-2004 BobGian completed DMP integration.
+;;; 27-Feb-2004 BobGian added constraint checking on DMPs: every DMP receives
+;;; dose, every DMP is in some beam, and every beam has at least one DMP.
+;;; Constraints checked when Send-Dicom button is pressed.
+;;; 01-Mar-2004 BobGian more constraint-checking on beams/DMPs about to be
+;;; sent out of ASSEMBLE-DICOM to new fcn CHECK-BEAM-CONSTRAINTS called
+;;; on Send-Beams button press immediately before ASSEMBLE-DICOM.
+;;; 07-Mar-2003 BobGian: Fixed bug in CUM-DOSE-DATA to track segment doses at
+;;; each DMP properly when accumulating doses for control point sequence.
+;;; Added NFRAC arg to CUM-MU-DATA and CUM-DOSE-DATA. Removed one
+;;; superfluous argument from each.
+;;; 10-Mar-2004 BobGian: DI-DMP-PRIOR-CGY and DI-DMP-TOTAL-CGY changed
+;;; to type FIXNUM to better accord with rounding conventions used by
+;;; Elekta RT-Desktop: integral centigray doses.
+;;; 04-Apr-2004 BobGian: Change DI-DMP-TOTAL-CGY to record EITHER computed
+;;; dose or user-textline-typed dose [using DI-DMP-DOSE-TYPE to indicate
+;;; via value :Computed or :User, respectively], with per-control-point
+;;; DMP segment dose calculated accordingly: from Prism segment doses for
+;;; :Computed and from DI-DMP-TOTAL-CGY divided equally per fraction
+;;; and per contributing Dicom beam for :User dose-types. Changes to mode
+;;; of segment-dose calculation are in CUM-DOSE-DATA.
+;;; 08-Apr-2004 BobGian: Simplified logic for [TRAY-]ACCESSORY-CODE.
+;;; 29-Apr-2004 BobGian - To fix MU and dose roundoff problems:
+;;; 1. Add 300A:00B3 to Beams Module (Primary Dosimeter Unit, Value: "MU")
+;;; 2. Convert 300A:0086 "Beam Meterset" integer -> float.
+;;; 3. Convert 300A:010E "Final Cumulative Meterset Weight" integer -> float.
+;;; 4. Convert 300A:0134 "Cumulative Meterset Weight" integer -> float.
+;;; Also STRING-TRIMmed leading/trailing spaces in 300A:00C2 "Beam Name".
+;;; 17-May-2004 BobGian complete process of extending all instances of Original
+;;; and Current Prism beam instances to include Copied beam instance too,
+;;; to provide copy for comparison with Current beam without mutating
+;;; Original beam instance.
+;;; 01-Jul-2004 BobGian: Energy sent at all control points so that it can vary
+;;; from segment to segment. This is legal in DICOM standard and is
+;;; accepted by Elekta. No harm comes from sending it every segment even
+;;; in cases where it does not vary.
+;;; 15-Jul-2004 BobGian: SEND-DICOM prints MACH-NAME, MACH-ID, and MACH-IDENT
+;;; to background window using "~S" rather than "~A".
+;;; 07-Sep-2004 BobGian: Prepend plan timestamp to 300A:0004 (Plan descrip).
+;;; 10-Sep-2004 BobGian: Pass DMP list to LOG-DICOM-DATA via SEND-DICOM.
+;;; LOG-DICOM-DATA now prints information about each DMP, including
+;;; DMP number, DMP name, name of original Prism point, Prior-cGy,
+;;; Total-cGy, and dose type (computed by Prism or typed by user).
+;;; This is followed by formatted dump of data-stream sent to server.
+;;; 12-Sep-2004 BobGian: Modify CUM-MU-DATA to use renamed and new slots
+;;; PR-BEAM-CUM-MU-INC and PR-BEAM-CUM-MU-EXC, allowing EXACT computation
+;;; of MU on accumulating segment MU values without roundoff accumulation
+;;; between control points, which was triggering a bug in Elekta server.
+;;; 19-Sep-2004 BobGian: Add to CHECK-BEAM-CONSTRAINTS check that each
+;;; radiating segment [ie, all segments for us] has at least 1.0 MU.
+;;; This is an Elekta-specific constraint.
+;;; 05-Oct-2004 BobGian fixed a few lines to fit within 80 cols.
+;;; 12-Oct-2004 BobGian "treated" -> "prior" in log and in description of
+;;; "previously-treated" dose and DI-DMP-TREATED-CGY -> DI-DMP-PRIOR-CGY
+;;; slot name change, for better consistency with Dicom-RT standard and
+;;; Elekta documentation. DI-DMP-TOTAL-CGY -> DI-DMP-ACCUM-CGY and
+;;; DI-DMP-TOTAL-CGY to fix inconsistency between spec and implementation.
+;;; Modify computation of DMP dose to get Total-cGy = Prior-cGy + Accum-cGy.
+;;; 14-Oct-2004 BobGian modify LOG-DICOM-DATA to print Prior, Accum, and Total
+;;; dose for each DMP [was Prior and incorrect Total before].
+;;; 04-Nov-2004 BobGian add default error message for *STATUS-ALIST*.
+;;; 17-Feb-2005 A. Simms replace Allegro getenv with misc.cl wrapper getenv.
+;;; 26-Jun-2005 I. Kalet replace single-float call with coerce
+;;; 6-Jul-2007 I. Kalet replace remaining single-float calls missed prev.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defun check-beam-constraints (p-bm-info d-dmp-list)
+
+ "check-beam-constraints p-bm-info d-dmp-list
+
+checks DMP/Beam constraints. Returns T -> no constraints are violated
+or some are but user chooses to proceed anyway, NIL -> violations and user
+chooses not to continue."
+
+ ;; P-BM-INFO is a list, in forward order, each entry being:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <Prism-Beam-Object> )
+ ;; with one entry for each segment - constructed by GENERATE-PBEAM-INFO.
+
+ (dolist (d-dmp-obj d-dmp-list)
+ ;; Calculate total dose at DMP, if user has not previously
+ ;; set it from textline or calculated it via "Calc-Dose" button.
+ ;; If computed here, set DI-DMP-DOSE-TYPE to :Computed.
+ (unless (di-dmp-dose-type d-dmp-obj)
+ (let ((accum-dose 0.0))
+ (declare (type single-float accum-dose))
+ ;; For each DMP, iterate over all the Dicom-Beams
+ ;; contributing to that DMP and all the segment [ORIG-PBI] doses
+ ;; making up the segments of each Dicom Beam.
+ (dolist (doselist (di-dmp-pdoses d-dmp-obj))
+ (do ((seg-doses doselist (cdr seg-doses)))
+ ((null seg-doses))
+ (incf accum-dose (the single-float (car seg-doses)))))
+ ;; Now add Prior dose to Accum dose to get Total dose.
+ (setf (di-dmp-total-cGy d-dmp-obj)
+ (+ (the fixnum (di-dmp-prior-cGy d-dmp-obj))
+ (setf (di-dmp-accum-cGy d-dmp-obj) (round accum-dose))))
+ (setf (di-dmp-dose-type d-dmp-obj) :Computed))))
+
+ ;; Verify that constraints are satisfied:
+ ;; 1. Every DMP receives some non-zero dose.
+ ;; 2. Every DMP is contributed to by at least one beam.
+ ;; 3. Every beam contributes to at least one DMP.
+ (let ((violated-constraints '()))
+ (declare (type list violated-constraints))
+
+ (dolist (d-dmp-obj d-dmp-list)
+ ;; DI-DMP-ACCUM-CGY must be a valid [computed or typed] dose here.
+ (unless (> (the fixnum (di-dmp-accum-cGy d-dmp-obj)) 0)
+ (push (format nil "DMP ~S receives no dose." (di-dmp-name d-dmp-obj))
+ violated-constraints))
+ (unless (consp (di-dmp-dbeams d-dmp-obj))
+ (push (format nil "DMP ~S is in no beams." (di-dmp-name d-dmp-obj))
+ violated-constraints)))
+
+ (dolist (p-bmdata p-bm-info)
+
+ ;; Check that each radiating segment has at least 1.0 MU per fraction.
+ ;; This is an Elekta-specific constraint.
+ ;; First expression is Total MU for given segment [Prism beam].
+ ;; Second expression is number of fractions for this segment.
+ (let ((MU/frac (/ (the single-float (pr-beam-tot-mu (fifth p-bmdata)))
+ (coerce (n-treatments (third p-bmdata))
+ 'single-float))))
+ (declare (type single-float MU/frac))
+ (when (< MU/frac 1.0)
+ (push (format nil "Segment ~S has insufficient MU: ~F."
+ (name (first p-bmdata))
+ MU/frac)
+ violated-constraints)))
+
+ ;; ORIG-PBIs in list checked against ORIG-PBIs in DI-BEAM-OPBI-LIST slot.
+ ;; Each ORIG-PBI here is an Original-Prism-Beam instance, the first
+ ;; segment in a Dicom beam [ie, its SEGTYPE is :STATIC or :DYNAMIC].
+ (unless (eq (pr-beam-segtype (fifth p-bmdata)) :segment)
+ (let ((orig-pbi (first p-bmdata)))
+ (block beam-hits-DMP
+ (dolist (d-dmp-obj d-dmp-list)
+ (dolist (d-bm-obj (di-dmp-dbeams d-dmp-obj))
+ (when (member orig-pbi (di-beam-opbi-list d-bm-obj) :test #'eq)
+ (return-from beam-hits-DMP))))
+ (push (format nil "Beam ~S hits no DMP(s)." (name orig-pbi))
+ violated-constraints)))))
+
+ (or (null violated-constraints)
+ (sl:confirm `("Violated constraints:"
+ ""
+ ,@(nreverse violated-constraints)
+ ""
+ "Continue?"
+ ""
+ "PROCEED -> Yes, do transmission"
+ "CANCEL -> No, return to panel")))))
+
+;;;-------------------------------------------------------------
+
+(defun assemble-dicom (cur-pat p-bm-info dicom-pat-id d-dmp-list)
+
+ "assemble-dicom cur-pat p-bm-info dicom-pat-id d-dmp-list
+
+Returns DICOM-ALIST, a Dicom-RT Plan for patient CUR-PAT, which can be
+processed by SEND-DICOM and LOG-DICOM-DATA."
+
+ ;; The RT Plan is an association list. The car of each
+ ;; list element is the Dicom tag, the cdr is the data itself. When the
+ ;; tag indicates a sequence (DICOM VR SQ), the cdr is the entire
+ ;; sequence, another association list of Dicom tags and data, which can
+ ;; contain more sequences etc.
+
+ ;; The Dicom tags *MUST* appear in exactly the order they are coded here
+ ;; (the Dicom standard requires tags within each nesting level to
+ ;; appear in ascending numeric order)
+
+ ;; P-BM-INFO is a list, in forward order, each entry being:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <Prism-Beam-Object> )
+ ;; with one entry for each segment - constructed by GENERATE-PBEAM-INFO.
+ ;;
+ ;; This list contains all Prism beams - that is, all segments for all Dicom
+ ;; beams, grouped into Dicom beams in order - all segments for one Dicom
+ ;; beam followed by all segs for the next, and so forth.
+
+ (declare (type list p-bm-info d-dmp-list))
+
+ ;; Attributes values - some type coercions too (fixnum -> string)
+ (let* ((prism-pat-id (format nil "~D" (patient-id cur-pat)))
+ (case-id-string (format nil "~D" (case-id cur-pat)))
+ (pln (fourth (first p-bm-info))) ; just first beam's plan
+ (plan-name (name pln))
+ (small-plan-name "") (big-plan-name "")
+ (plan-timestamp (time-stamp pln)))
+
+ (declare (type simple-base-string prism-pat-id case-id-string
+ plan-name small-plan-name big-plan-name plan-timestamp))
+
+ (cond ((<= (length plan-name) 16)
+ (setq small-plan-name plan-name))
+ (t (setq small-plan-name (subseq plan-name 0 16)
+ big-plan-name (subseq plan-name 16))
+ (when (> (length big-plan-name) 64)
+ (setq big-plan-name (subseq big-plan-name 0 64)))))
+
+ (multiple-value-bind (plan-date plan-time)
+ (dicom-date-time plan-timestamp)
+
+ ;; Association list of attribute tag-value pairs.
+ ;; Dicom std says items must appear in order of ascending tag value
+ ;; (within each nesting level).
+ ;; This is NOT the order items appear in Dicom std or Elekta statement.
+
+ `(((#x0008 . #x0016) "1.2.840.10008.5.1.4.1.1.481.5")
+ ((#x0008 . #x0018) "9.9.9.9")
+
+ ;; Study module, items with low tag values
+ ((#x0008 . #x0020))
+ ((#x0008 . #x0030))
+ ((#x0008 . #x0050))
+
+ ;; Series module, item with low tag values
+ ((#x0008 . #x0060) "RTPLAN")
+
+ ;; General Equipment module, not used by Elekta but required
+ ((#x0008 . #x0070))
+
+ ;; Study module again
+ ((#x0008 . #x0090))
+
+ ;; RT general plan module
+ ;; Dicom operator is Prism user who transfered plan
+ ((#x0008 . #x1070)
+ ,(progn (getenv "USER")))
+
+ ;; Patient module
+ ((#x0010 . #x0010) ,(name cur-pat)) ;64 chars max.
+ ((#x0010 . #x0020) ,dicom-pat-id)
+ ((#x0010 . #x0030))
+ ((#x0010 . #x0040))
+ ((#x0010 . #x1000) ;64 chars max.
+ ,(format nil "~A ~A ~A"
+ prism-pat-id case-id-string
+ (let ((h-id (hospital-id cur-pat)))
+ (declare (type simple-base-string h-id))
+ (if (> (length h-id) 0) h-id "99-99-99-99"))))
+
+ ;; Study module, not used by Elekta but required
+ ((#x0020 . #x000D) "9.9.9.9")
+
+ ;; Series module
+ ((#x0020 . #x000E) "9.9.9.9")
+
+ ;; Study module
+ ((#x0020 . #x0010))
+
+ ;; Series module, not used by Elekta but required
+ ((#x0020 . #x0011))
+
+ ;; RT General Plan module
+ ((#x300A . #x0002) ,small-plan-name) ;0 -> 16 chars, Required
+
+ ,@(and (> (length big-plan-name) 0)
+ `(((#x300A . #x0003) ,big-plan-name))) ;0 -> 64 chars, Optional
+
+ ((#x300A . #x0004) ;Plan description, 1024 chars max.
+ ;; Possible need to truncate to length 1024 since COMMENTS
+ ;; fields here can be of arbitrary length.
+ ,(let ((descrip
+ (format
+ nil
+ "~A~%~A~%DS: ~A Prism patient: ~A case: ~A~{~%~A~}~{~%~A~}"
+ plan-timestamp
+ plan-name (plan-by pln)
+ prism-pat-id case-id-string
+ (comments pln) (comments cur-pat))))
+ (declare (type simple-base-string descrip))
+ (cond ((<= (length descrip) 1024) descrip)
+ (t (subseq descrip 0 1024)))))
+
+ ((#x300A . #x0006) ,plan-date)
+ ((#x300A . #x0007) ,plan-time)
+ ((#x300A . #x000C) "PATIENT")
+
+ ;; RT Prescription module - optional [present if DMPs available]
+ ;; Transmit all DMPs, no matter in which Dicom beam they appear.
+ ,@(and
+ (consp d-dmp-list)
+ `(((#x300A . #x0010)
+ ,@(mapcar
+ #'(lambda (d-dmp-obj &aux (pt (di-dmp-point d-dmp-obj)))
+ `(((#x300A . #x0012) ,(di-dmp-counter d-dmp-obj))
+ ;;
+ ((#x300A . #x0014) "COORDINATES")
+ ;;
+ ;; 64-character-maximum-length string here.
+ ((#x300A . #x0016) ,(di-dmp-name d-dmp-obj))
+ ;;
+ ((#x300A . #x0018)
+ ,(* 10.0 (the single-float (x pt)))
+ ,(* 10.0 (the single-float (y pt)))
+ ,(* 10.0 (the single-float (z pt))))
+ ;;
+ ((#x300A . #x001A) ;FLOAT, in Gy.
+ ,(* 0.01 ;cGY -> Gy
+ (coerce
+ (the fixnum
+ (di-dmp-prior-cGy d-dmp-obj))
+ 'single-float)))
+ ;;
+ ((#x300A . #x0020) "TARGET")
+ ;;
+ ;; DI-DMP-TOTAL-CGY must be a valid
+ ;; [computed or typed] dose here.
+ ((#x300A . #x0027) ;FLOAT, in Gy.
+ ,(* 0.01 ;cGY -> Gy
+ (coerce
+ (the fixnum
+ (di-dmp-total-cGy d-dmp-obj))
+ 'single-float)))))
+ ;;
+ d-dmp-list))))
+
+ ;; RT Fraction Scheme module - prescribed MU, N of fractions here
+ ((#x300A . #x0070)
+ ,@(assemble-fraction-groups p-bm-info))
+
+ ;; RT Beams module
+ ((#x300A . #x00B0)
+ ,@(assemble-beam-sequence p-bm-info d-dmp-list))))))
+
+;;;-------------------------------------------------------------
+
+(defun assemble-fraction-groups (p-bm-info &aux p-bm-seq (seq-num 0))
+
+ "assemble-fraction-groups p-bm-info
+
+Assemble Dicom-RT Fraction Group Sequence portion of DICOM-ALIST."
+
+ (declare (type list p-bm-info)
+ (type fixnum seq-num))
+
+ ;; P-BM-INFO is a list, in forward order, each entry being:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <Prism-Beam-Object> )
+ ;; with one entry for each segment.
+
+ ;; Within each fraction group, all beams have the same number of fractions.
+ ;; In each fraction group, there is a sequence of beam number/MU pairs.
+
+ (setq
+
+ ;; P-BM-SEQ [Prism-beam sequence] is a list of
+ ;; ( <Seq-Number> <Num-Fractions> <Total-MU-per-frac> )
+ ;; for each Prism beam.
+ p-bm-seq (mapcar
+ #'(lambda (p-bmdata) ;Each item in P-BM-INFO
+ (let ((nfrac (n-treatments (third p-bmdata)))
+ (p-bm-obj (fifth p-bmdata)))
+ (declare (type fixnum nfrac))
+ (list (setq seq-num (the fixnum (1+ seq-num)))
+ nfrac
+ (/ (the single-float (pr-beam-tot-mu p-bm-obj))
+ (coerce nfrac 'single-float)))))
+ ;; Input is list of items as in P-BM-INFO except only for
+ ;; :STATIC and :DYNAMIC beams - not for subsequent :SEGMENTs.
+ (remove-if #'(lambda (p-bmdata)
+ (eq (pr-beam-segtype (fifth p-bmdata)) :segment))
+ p-bm-info)))
+
+ ;; Dicom Fraction Group Sequence with tags.
+ (let ((frac-seq '())
+ (idx 0))
+
+ (declare (type list frac-seq)
+ (type fixnum idx))
+
+ ;; FRAC-SEQ [fraction sequence] is list of distinct N in P-BM-SEQ.
+ ;; This loop uniquizes the list of NUM-FRACTIONS for each item in P-BM-SEQ,
+ ;; while preserving the order of the items in the list being uniquized.
+ ;; cl:REMOVE-DUPLICATES does NOT guarantee to preserve order.
+ (dolist (frac-num (mapcar #'second p-bm-seq))
+ (unless (member frac-num frac-seq :test #'=)
+ (push frac-num frac-seq)))
+ (setq frac-seq (nreverse frac-seq))
+
+ (mapcar
+ #'(lambda (frac-num frac-group)
+ `(((#x300A . #x0071) ;Fraction Group Number
+ ,(setq idx (the fixnum (1+ idx))))
+ ((#x300A . #x0078) ,frac-num) ;Number of Fractions Planned
+ ((#x300A . #x0080) ,(length frac-group)) ;Number of Dicom beams
+ ((#x300A . #x00A0) 0) ;Number of Brachy Application Setups
+ ((#x300C . #x0004) ;Referenced Dicom beam Sequence
+ ,@(mapcar
+ #'(lambda (frac-item)
+ ;; FRAC-ITEM:
+ ;; ( <Seq-Num> <Num-Fractions> <Total-MU-per-frac> )
+ ;; Coord sign conventions ignored here.
+ ;; Dicom requires slot, but Elekta ignores it.
+ ;; Fictitious DicomDMP used as normalization point -
+ ;; its arbitrary coordinates and dose [of 1.0 Gray]
+ ;; are; used as norm-point values to represent all
+ ;; DicomDMPs. Assumption is that every Dicom beam
+ ;; will have at least one DicomDMP in it. If not,
+ ;; the first two slots here optionally can be missing.
+ `(
+ ;; Beam Dose Specification Point - optional.
+ ;; Present if DicomDMPs are available.
+ ((#x300A . #x0082) 0.0 0.0 0.0)
+ ;; Beam Dose - optional, present if DMPs available.
+ ((#x300A . #x0084) 1.0) ;Gray.
+ ;; Beam Meterset, absolute MU per fraction.
+ ((#x300A . #x0086) ,(third frac-item)) ;Total-MU
+ ;; Beam number [cross-reference index].
+ ((#x300C . #x0006) ,(first frac-item))))
+ frac-group))))
+ frac-seq
+ ;; Second arg is elements of P-BM-SEQ grouped by N from FRAC-SEQ.
+ (mapcar #'(lambda (frac)
+ (declare (type fixnum frac))
+ (remove-if-not
+ #'(lambda (data)
+ (= frac (the fixnum (second data))))
+ p-bm-seq))
+ frac-seq))))
+
+;;;-------------------------------------------------------------
+
+(defun assemble-beam-sequence (p-bm-info d-dmp-list)
+
+ "assemble-beam-sequence p-bm-info d-dmp-list
+
+Assemble Dicom-RT Beam Sequence portion of DICOM-ALIST."
+
+ ;; P-BM-INFO is a list, in forward order, each entry being:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <Prism-Beam-Object> )
+ ;; with one entry for each segment.
+
+ (declare (type list p-bm-info d-dmp-list))
+
+ (do ((p-bm-attrs nil) ; list of Prism-beam attributes
+ (dbeam-sequence nil) ; Dicom beam sequence
+ (nfrac 0) ; num fractions in current beam
+ (cps nil) ; control point sequence
+ (mach) (wedge-id 0) (wedge-name "") (curr-coll)
+ (p-bms p-bm-info) ;P-BMS gets CDRed at end of this function.
+ (first-seg? nil nil) ;Tracks segment starting a new Dicom beam.
+ #+:Ignore
+ (energy-change? nil nil) ;Energy changes during this Dicom beam.
+ (cp-index 0)
+ (p-bmdata) (orig-pbi) (p-bm-obj))
+ ((null p-bms)
+ (nreverse dbeam-sequence))
+ (declare (type list p-bm-attrs dbeam-sequence cps p-bms p-bmdata)
+ (type simple-base-string wedge-name)
+ (type (member nil t) first-seg? #+:Ignore energy-change?)
+ (type fixnum nfrac wedge-id cp-index))
+ (setq p-bmdata (car p-bms)) ;Each item in P-BM-INFO
+ (setq orig-pbi (first p-bmdata)) ;Original Prism beam instance
+ (setq nfrac (n-treatments orig-pbi))
+ (setq mach (machine orig-pbi))
+ (setq wedge-id (id (wedge orig-pbi)))
+ (setq wedge-name (wedge-label wedge-id mach))
+ ;; NB: Current-Prism-Beam [rather than Original] instance used for
+ ;; collimator since collimator attributes can be altered in Dicom Panel.
+ ;; Collimator attributes are ONLY ones that can be so edited. All other
+ ;; beam attributes [including especially all dose-calc results] come from
+ ;; the Original-Prism-beam instance.
+ (setq curr-coll (collimator (third p-bmdata)))
+ (setq p-bm-obj (fifth p-bmdata)) ;Prism-Beam structure instance
+ (unless (eq (pr-beam-segtype p-bm-obj) :segment)
+ (setq first-seg? t)
+ (setq cp-index 0)
+ (setq cps '())
+ (setq
+ p-bm-attrs
+ (let ((mach-name (name mach))
+ (rad-type (case (particle mach)
+ ((photon) "PHOTON")
+ ((electron) "ELECTRON")
+ ((neutron) "NEUTRON")
+ ((otherwise "UNKNOWN"))))
+ (ext-wdg? (not (or (zerop wedge-id)
+ (string= wedge-name "Fixed Wedge"))))
+ (ext-blks? (coll:elements (blocks orig-pbi)))
+ (attrs nil)) ;accumulated list of Dicom beam attributes
+
+ (setq
+ attrs
+ `(
+ ;; (0008,1090) is Dicom Manufacturer Model Name
+ ;; but we use it here for Prism machine name so we can
+ ;; use (300A,003C) Beam Description for other stuff
+ ((#x0008 . #x1090) ,mach-name) ;64 char max.
+ ((#x300A . #x00B2) ,(car (ident mach)))
+ ((#x300A . #x00B3) "MU") ;Primary Dosimeter Unit
+
+ ;; Beam limiting device seq
+ ((#x300A . #x00B6)
+ (((#x300A . #x00B8) "ASYMX")
+ ((#x300A . #x00BC) 1))
+ (((#x300A . #x00B8) "ASYMY")
+ ((#x300A . #x00BC) 1))
+ (((#x300A . #x00B8) "MLCX")
+ ((#x300A . #x00BC) 40)))
+
+ ;; Dicom Beam number, name, description, type, radiation type
+ ((#x300A . #x00C0)
+ ,(pr-beam-dbeam-num p-bm-obj))
+
+ ((#x300A . #x00C2) ;Beam name, 64 chars max.
+ ,(let ((str (string-trim " " (name orig-pbi))))
+ (declare (type simple-base-string str))
+ (cond ((<= (length str) 64) str)
+ (t (subseq str 0 64)))))
+
+ ((#x300A . #x00C3)
+ ;; Field length limited to 1024 chars here.
+ ,(format
+ nil
+ "Machine: ~A~%Modality: ~A~%Energy: ~A MV~%Wedge: ~A"
+ mach-name
+ rad-type
+ (energy mach)
+ wedge-name))
+
+ ;; Our dynamic beams must be called "STATIC" not
+ ;; "DYNAMIC" in Dicom. Step-and-shoot is "STATIC".
+ ;; See Andrew Long's email 14-Jun-2002
+ ((#x300A . #x00C4)
+ ,(case (pr-beam-segtype p-bm-obj)
+ (:static "STATIC")
+ (:dynamic "STATIC") ; sic - see comment
+ (otherwise "UNKNOWN"))) ; RTD will reject
+ ((#x300A . #x00C6) ,rad-type)
+
+ ;; Wedge seq, Elekta internal wedge *only*.
+ ;; External wedges are represented as shadow trays.
+ ;; If we include wedge seq, must also include
+ ;; wedge position seq in each control point.
+ ;; Can say wedge is out at each control point.
+ ((#x300A . #x00D0) 1)
+ ((#x300A . #x00D1)
+ (((#x300A . #x00D2) 1)
+ ((#x300A . #x00D3) "MOTORIZED")
+ ((#x300A . #x00D5)) ; D5,6,8 are required but ignored
+ ((#x300A . #x00D6)) ; must be present but can be empty
+ ((#x300A . #x00D8))))
+
+ ;; Compensators, boli: there are none
+ ((#x300A . #x00E0) 0)
+ ((#x300A . #x00ED) 0)
+
+ ;; Represent external wedges or blocks as shadow tray,
+ ;; so number of blocks is 1
+ ((#x300A . #x00F0) ,(if (or ext-wdg? ext-blks?) 1 0))))
+
+ ;; Purpose of this block sequence is just to identify the tray.
+ (when (or ext-wdg? ext-blks?)
+ (setq attrs
+ (nconc
+ attrs
+ `(((#x300A . #x00F4) ; Block Sequence
+ (((#x300A . #x00E1)) ; 2C, required but ignored
+ ((#x300A . #x00F5) ; Shadow Tray
+ ,(cond (ext-wdg?
+ (accessory-code
+ (find wedge-id (wedges mach)
+ :key #'ID)))
+ (t (tray-accessory-code mach))))
+ ((#x300A . #x00F6)) ; 2C, required but ignored
+ ((#x300A . #x00F8)
+ ,(if ext-wdg? "EXTERNAL WEDGE" "EXTERNAL BLOCKS"))
+ ((#x300A . #x00FA)) ; 2C, required but ignored
+ ((#x300A . #x00FC) 1) ; So RTD will say "Block 1"
+ ((#x300A . #x00FE)
+ ,(if ext-wdg? wedge-name ""))
+ ((#x300A . #x0100)) ; 2C, required but ignored
+ ((#x300A . #x0102)) ; 2C, required but ignored
+ ((#x300A . #x0104)) ; 2C, required but ignored
+ ((#x300A . #x0106)) ; 2C, required but ignored
+ ))))))
+
+ ;; Total MU per fraction - absolute MU, not percent, for now.
+ ;; Transfered as FLOAT rather than INTEGER as formerly.
+ (nconc attrs `(((#x300A . #x010E)
+ ,(/ (the single-float (pr-beam-tot-mu p-bm-obj))
+ (coerce nfrac 'single-float))))))))
+
+ ;; Even-numbered control points indicate start of beam segment.
+ ;; Control point for first segment contains everything.
+ ;; Control points for successive segments contain only those components
+ ;; that change over course of segments.
+ (push
+ `(((#x300A . #x0112) ,cp-index)
+ ((#x300A . #x0114) ,(energy mach))
+ ,(wedge-data wedge-name)
+ ,(leaf/diaphragm-data curr-coll)
+ ,@(and first-seg? (gantry/coll/couch-data orig-pbi))
+ ,(cum-mu-data p-bm-obj nfrac t)
+ ,@(and (consp d-dmp-list)
+ ;; Referenced Dose Reference Sequence - present if DMPs are.
+ (cum-dose-data d-dmp-list orig-pbi nfrac t)))
+ cps)
+
+ (setq cp-index (the fixnum (1+ cp-index)))
+
+ ;; Odd-numbered control points indicate end of beam segment.
+ ;; Contains all components that change over course of segments.
+ (push
+ `(((#x300A . #x0112) ,cp-index)
+ ((#x300A . #x0114) ,(energy mach))
+ ,(wedge-data wedge-name)
+ ,(leaf/diaphragm-data curr-coll)
+ ,(cum-mu-data p-bm-obj nfrac nil)
+ ,@(and (consp d-dmp-list)
+ ;; Referenced Dose Reference Sequence - present if DMPs are.
+ (cum-dose-data d-dmp-list orig-pbi nfrac nil)))
+ cps)
+
+ (setq cp-index (the fixnum (1+ cp-index)))
+ (when (or (null (setq p-bms (cdr p-bms))) ;Now doing last P-BMDATA object
+ ;; Or next P-BMDATA object is NOT a successor segment.
+ (not (eq (pr-beam-segtype (fifth (car p-bms))) :segment)))
+ ;; Which implies this P-BMDATA obj is the LAST segment of a Dicom beam.
+ ;; 300A:0110 and 0111 are N control points and control point seq,
+ ;; the last two elements in the P-BM-ATTRS list, just NCONC to end.
+ (push (nconc p-bm-attrs
+ `(((#x300A . #x0110) ,(length cps))
+ ((#x300A . #x0111) . ,(nreverse cps))))
+ dbeam-sequence))))
+
+;;;-------------------------------------------------------------
+
+(defun cum-mu-data (p-bm-obj nfrac even?)
+
+ (declare (type (member nil t) even?)
+ (type fixnum nfrac))
+
+ `((#x300A . #x0134)
+ ,(/ (the single-float
+ (cond (even?
+ (pr-beam-cum-mu-exc p-bm-obj))
+ (t (pr-beam-cum-mu-inc p-bm-obj))))
+ (coerce nfrac 'single-float))))
+
+;;;-------------------------------------------------------------
+;;; D-DMP-LIST is guaranteed non-empty here.
+
+(defun cum-dose-data (d-dmp-list orig-pbi nfrac even?
+ &aux (dmp-doses '()) (dmp-counters '()))
+
+ (declare (type list d-dmp-list dmp-doses dmp-counters)
+ (type (member nil t) even?)
+ (type fixnum nfrac))
+
+ ;; Iterate over all DMPs contributed to by current beam.
+ ;; D-DMP-LIST contains ALL DMPs. Must filter so as so accumulate dose
+ ;; only from those contributed to by the beam in question.
+ ;; These accumulated beam/segment doses do NOT include any Prior dose,
+ ;; which is why Prior-cGy is subtracted from Total-cGy here.
+ ;; Doses here are from DI-DMP-PDOSES, which are cGy as SMALL-FLOAT values.
+ (dolist (d-dmp-obj d-dmp-list)
+ (let* ((d-bmlist (di-dmp-dbeams d-dmp-obj))
+ (user-dose? (eq (di-dmp-dose-type d-dmp-obj) :User))
+ (per-beam-dose (/ (coerce
+ (- (the fixnum (di-dmp-total-cgy d-dmp-obj))
+ (the fixnum (di-dmp-prior-cgy d-dmp-obj)))
+ 'single-float)
+ (coerce (the fixnum (length d-bmlist))
+ 'single-float))))
+ ;; D-BMLIST checked above to be non-empty.
+ (declare (type list d-bmlist)
+ (type single-float per-beam-dose)
+ (type (member nil t) user-dose?))
+ (do ((d-bms d-bmlist (cdr d-bms))
+ (doselist (di-dmp-pdoses d-dmp-obj) (cdr doselist))
+ (dbeam-seglist))
+ ((null d-bms))
+ (declare (type list d-bms doselist dbeam-seglist))
+ ;; All ORIG-PBIs must be [uncopied] Original-Prism-Beam instances.
+ ;; Only generate data points if current ORIG-PBI segment is in the
+ ;; list for the DicomBmInst contributing to the current DMP point.
+ (when (member orig-pbi
+ (setq dbeam-seglist (di-beam-opbi-list (car d-bms)))
+ :test #'eq)
+ ;; Cumulative dose [actual, not per-MU] in Gray PER FRACTION at DMP
+ ;; due to all segments up to but EXCLUDING current ORIG-PBI [segment
+ ;; at current control-point pair] for EVEN control point and up to
+ ;; and INCLUDING current ORIG-PBI for ODD control point.
+ (do ((orig-pbi-list dbeam-seglist (cdr orig-pbi-list))
+ (seg-doses (car doselist) (cdr seg-doses))
+ (per-seg-dose (/ per-beam-dose (length dbeam-seglist)))
+ (this-seg-dose 0.0) (accum-dose 0.0))
+ ((null seg-doses)
+ (error "CUM-DOSE-DATA [1] Ran off end."))
+ (declare (type list orig-pbi-list seg-doses)
+ (type single-float per-seg-dose this-seg-dose accum-dose))
+ ;; ORIG-PBI-LIST: list of uncopied original Prism beam instances.
+ ;; SEG-DOSES: list of Prism segment doses [total, not per-frac].
+ (setq this-seg-dose (cond (user-dose? per-seg-dose)
+ (t (the single-float (car seg-doses)))))
+ (cond ((eq orig-pbi (car orig-pbi-list))
+ (unless even?
+ (incf accum-dose this-seg-dose))
+ (push (di-dmp-counter d-dmp-obj) dmp-counters)
+ (push (/ (* 0.01 accum-dose) ;cGy -> Gray
+ (coerce nfrac 'single-float)) ;Per FRACTION
+ dmp-doses)
+ (return))
+ (t (incf accum-dose this-seg-dose))))
+ ;; ORIG-PBI can be in only one Dicom beam. Therefore, once we have
+ ;; found its beam and accumulated doses across the beam's segment
+ ;; list, we are done with this DMP. There may be more DMPs
+ ;; contributed to by this ORIG-PBI [that is, other DMPs contributed
+ ;; to by this dicom beam], so we must continue scan.
+ (return)))))
+
+ ;; We use a fictitious DMP as the normalization point and an arbitrary
+ ;; dose of 1.0 Gray as the norm-point value to represent all DMPs.
+ `(((#x300C . #x0050)
+ ,@(mapcar
+ #'(lambda (dmp-dose dmp-counter)
+ `(((#x300A . #x010C)
+ ;; Cumulative Dose Reference Coefficient
+ ;; Number computed here [a single-float ratio] times
+ ;; norm-point dose in Gy gives accumulated dose [Gy]
+ ;; for current control point pair at current DMP due to
+ ;; all Prism beams in this Dicom beam.
+ ,dmp-dose)
+ ((#x300C . #x0051)
+ ;; Referenced Dose Reference Number [cross-ref index].
+ ,dmp-counter)))
+ (nreverse dmp-doses)
+ (nreverse dmp-counters)))))
+
+;;;-------------------------------------------------------------
+
+(defun wedge-data (wedge-name)
+
+ (declare (type simple-base-string wedge-name))
+
+ `((#x300A . #x0116)
+ (((#x300A . #x0118)
+ ,(if (string= wedge-name "Fixed Wedge") "IN" "OUT"))
+ ((#x300C . #x00C0) 1))))
+
+;;;-------------------------------------------------------------
+
+(defun leaf/diaphragm-data (curr-coll)
+
+ ;; CURR-COLL is [copied and possibly mutated] from <CurrBmInst> since that
+ ;; collimator contains fitted-to-portal and adjusted-to-flagpole leaves and
+ ;; backup diaphragms [possibly modified by user].
+
+ `((#x300A . #x011A)
+ ;; diaphragms
+ (((#x300A . #x00B8) "ASYMX")
+ ((#x300A . #x011C)
+ ,(* 10.0 (the single-float (x1 curr-coll)))
+ ,(* 10.0 (the single-float (x2 curr-coll)))))
+ (((#x300A . #x00B8) "ASYMY")
+ ((#x300A . #x011C)
+ ,(* 10.0 (the single-float (y1 curr-coll)))
+ ,(* 10.0 (the single-float (y2 curr-coll)))))
+ ;; leaves
+ (((#x300A . #x00B8) "MLCX")
+ ((#x300A . #x011C)
+ ,@(delistify-leaves (leaf-settings curr-coll))))))
+
+;;;-------------------------------------------------------------
+
+(defun delistify-leaves (leaf-pos &aux (x1-bank '()) (x2-bank '()))
+
+ "delistify-leaves leaf-pos
+
+converts Prism-format leaf positions (list of N pairs, coords in CM)
+to Dicom-format (list of 2N scalars, coords in MM), also rearranges order"
+
+ ;; Rearrange order from pairs of opposed leaves,
+ ;; to all the X1 (-x) leaves, then all the X2 (+x) leaves.
+ ;; Furthermore must rearrange order of leaves in each bank, because
+ ;; edge-list passed to COMPUTE-MLC is arranged from +y end to -y end,
+ ;; but Dicom wants leaves sorted from -y to +y
+
+ (dolist (pair leaf-pos)
+ (push (* 10.0 (the single-float (first pair))) x1-bank)
+ (push (* 10.0 (the single-float (second pair))) x2-bank))
+
+ (nconc x1-bank x2-bank)) ; no nreverse needed, we want to reverse order
+
+;;;-------------------------------------------------------------
+
+(defun gantry/coll/couch-data (orig-pbi)
+
+ `(((#x300A . #x011E) ,(gantry-angle orig-pbi))
+ ((#x300A . #x011F) "NONE")
+ ((#x300A . #x0120) ,(collimator-angle orig-pbi))
+ ((#x300A . #x0121) "NONE")
+ ((#x300A . #x0122) ,(couch-angle orig-pbi))
+ ((#x300A . #x0123) "NONE")
+ ((#x300A . #x0125) 0.0) ;table top eccentric angle
+ ((#x300A . #x0126) "NONE")
+ ((#x300A . #x0128)) ;Table linear motions all type 2C, leave empty
+ ((#x300A . #x0129))
+ ((#x300A . #x012A))))
+
+;;;=============================================================
+;;; Invoke Dicom SCU.
+
+(defun send-dicom (dicom-alist d-dmp-list)
+
+ "send-dicom dicom-alist d-dmp-list
+
+Send contents of DICOM-ALIST to a server using DICOM-RT. This code
+calls our client (SCU) to communicate with the server (SCP)."
+
+ (declare (type list dicom-alist d-dmp-list))
+
+ (log-dicom-data dicom-alist d-dmp-list)
+
+ (let* ((beam-sequence
+ (cdr (assoc '(#x300A . #x00B0) dicom-alist :test #'equal)))
+ (mach-id
+ (second (assoc '(#x300A . #x00B2) (car beam-sequence)
+ :test #'equal)))
+ (mach-name
+ (second (assoc '(#x0008 . #x1090) (car beam-sequence)
+ :test #'equal)))
+ (mach-ident
+ (ident (get-therapy-machine mach-name
+ *therapy-machine-database*
+ *machine-index-directory*))))
+ ;; Trace printout.
+ (format t "~&~%Send-Dicom: ~S ~S ~S" mach-name mach-id mach-ident)
+
+ ;; error checking - does ident field correctly identify Dicom server?
+ (cond ((and (consp mach-ident)
+ (= (length mach-ident) 5))
+ ;; no error - ident field does identify a Dicom server
+ (let ((iden (first mach-ident))
+ (server-ae-title (second mach-ident))
+ (server-ip (third mach-ident))
+ (server-port (fourth mach-ident)))
+
+ ;; Trace printout.
+ (format t "~%ID: ~A, Server: ~A, IP: ~A, Port: ~A."
+ iden server-ae-title server-ip server-port)
+
+ (multiple-value-bind (status msg)
+
+ (cond ((sl:confirm
+ '("Send plan to accelerator?"
+ ""
+ "PROCEED -> Yes, do transmission"
+ "CANCEL -> No, testing dump only"))
+ (dicom:run-client :C-Store-RTPlan-RQ
+ server-ip
+ server-port
+ server-ae-title
+ dicom-alist ;RTPlan data as AList
+ "9.9.9.9"))
+ (t (values -1 "Testing - no transfer attempted")))
+
+ (log-dicom-transfer dicom-alist status msg)
+ (values status msg))))
+
+ (t (let ((status -1)
+ (msg (format nil "No Dicom server for ~A." mach-name)))
+ (log-dicom-transfer dicom-alist status msg)
+ (values status msg))))))
+
+;;;-------------------------------------------------------------
+
+(defun log-dicom-data (dicom-alist d-dmp-list)
+
+ "log-dicom-data dicom-alist
+
+Pretty-prints contents of DICOM-ALIST (with self-identifying tags) to
+file specified by *PDR-DATA-FILE*."
+
+ (with-open-file (strm *pdr-data-file* :direction :output
+ :if-exists :supersede :if-does-not-exist :create)
+
+ ;; Log information about each dose-monitoring point ...
+ (format strm "~%Dose-Monitoring-Points:~%~%")
+ (dolist (d-dmp-obj d-dmp-list)
+ (format
+ strm
+ "~4,' D: ~S (~S), ~D cGy (prior), ~D cGy (accum), ~D cGy (total), ~A.~%"
+ (di-dmp-counter d-dmp-obj)
+ (di-dmp-name d-dmp-obj)
+ (name (di-dmp-point d-dmp-obj))
+ (di-dmp-prior-cGy d-dmp-obj)
+ (di-dmp-accum-cGy d-dmp-obj)
+ (di-dmp-total-cGy d-dmp-obj)
+ (cond ((eq (di-dmp-dose-type d-dmp-obj) :Computed)
+ "computed by Prism")
+ (t "typed by User"))))
+
+ ;; Log formatted dump of information sent by client to server ...
+ (dicom::dump-dicom-data dicom-alist strm)))
+
+;;;-------------------------------------------------------------
+
+(defun log-dicom-transfer (dicom-alist status msg)
+
+ "log-dicom-transfer dicom-alist status msg
+
+Write Dicom transfer log file with transfer attempt status and message,
+also date, time, Prism user, patient, Prism case, plan timestamp, field name"
+
+ (let ((fname (concatenate 'string
+ *dicom-log-dir* "dicom" (lex-timestamp) ".log")))
+
+ (with-open-file (fp fname :direction :output :if-exists :append
+ :if-does-not-exist :create) ; should not exist
+ (cond ((< status 0)
+ (format fp "~A CSTORE status (none) ~A~%" (timestamp) msg))
+ (t (format fp "~A CSTORE status #x~4,'0X ~A~%"
+ (timestamp)
+ status
+ (or (cdr (assoc status *status-alist* :test #'=))
+ "Unknown error"))))
+
+ ;; Get data for log entries from DICOM-ALIST using assoc and Dicom tags
+ ;; unhack the hack where we store several ID's in one Dicom string
+ (let* ((pat-case-ids
+ (second (assoc '(#x0010 . #x1000) dicom-alist :test #'equal)))
+ (case-id-string
+ (subseq pat-case-ids
+ (1+ (position #\Space pat-case-ids :test #'eq)))))
+ (format fp "~5,D ~30,A ~11,A case ~2,D, transfer by ~A~%"
+ (read-from-string pat-case-ids) ;Prism Patient ID
+ (second (assoc '(#x0010 . #x0010) ;Patient Name
+ dicom-alist :test #'equal))
+ (read-from-string ;Prism Hospital ID
+ (subseq case-id-string
+ (1+ (position #\Space case-id-string :test #'eq))))
+ (read-from-string case-id-string) ;Case ID number
+ (second (assoc '(#x0008 . #x1070) ;Prism User
+ dicom-alist :test #'equal)))
+ (format fp "Transferred as ~A~%"
+ (second (assoc '(#x0010 . #x0020) ;Dicom Patient ID
+ dicom-alist :test #'equal)))
+ (dolist (p-bm-seq (cdr (assoc '(#x300A . #x00B0) ;Beam Sequence
+ dicom-alist :test #'equal)))
+ (format fp "~2,D ~16,A ~6,A ~16,A ~20,A ~A~%"
+ (second (assoc '(#x300A . #x00C0) ;Beam Number
+ p-bm-seq :test #'equal))
+ (second (assoc '(#x300A . #x00C2) ;Beam Name
+ p-bm-seq :test #'equal))
+ (second (assoc '(#x300A . #x00B2) ;Machine ID
+ p-bm-seq :test #'equal))
+ (second (assoc '(#x300A . #x0002) ;Plan Name
+ dicom-alist :test #'equal))
+ (second (assoc '(#x300A . #x0006) ;Plan Date
+ dicom-alist :test #'equal))
+ (second (assoc '(#x300A . #x0007) ;Plan Time
+ dicom-alist :test #'equal))))))))
+
+;;;=============================================================
+
+(defun timestamp ()
+
+ "timestamp
+
+Return date and time in DD-MMM-YYYY HH:MM:SS format"
+
+ (multiple-value-bind (sec min hr day mo yr) (get-decoded-time)
+ (let ((month (nth (1- mo) '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))))
+ (format nil "~2,'0D-~A-~A ~2,'0D:~2,'0D:~2,'0D"
+ day month yr hr min sec))))
+
+;;;-------------------------------------------------------------
+
+(defun lex-timestamp ()
+
+ "lex-timestamp
+
+Return date and time in YYYY-MMDD-HHMMSS format so lex. order = chron. order"
+
+ (multiple-value-bind (sec min hr day mo yr) (get-decoded-time)
+ (format nil "~A-~2,'0D~2,'0D-~2,'0D~2,'0D~2,'0D" yr mo day hr min sec)))
+
+;;;-------------------------------------------------------------
+
+(defun dicom-date-time (prism-timestamp)
+
+ "dicom-date-time prism-timestamp
+
+Converts prism-timestamp, a string like '5-Mar-1995 15:47:34' or
+'24-Mar-1995 13:52:33', to Dicom format date and time.
+Returns two values: Dicom DA format date, like '19950305' or '19950324',
+and Dicom TM format time, like '154734'."
+
+
+ (let* ((hindex (position #\- prism-timestamp :test #'eq)) ; Find first hyphen
+ (daynum (subseq prism-timestamp 0 hindex)) ; Day, 1 or 2 chars
+ (mts (subseq prism-timestamp (1+ hindex) (length prism-timestamp)))
+ (sindex (position #\Space mts :test #'eq)) ; Find first space
+ (cindex (position #\: mts :test #'eq)) ; Find first colon
+ (hrnum (subseq mts (1+ sindex) cindex))
+ (mss (subseq mts (1+ cindex) (length mts))))
+
+ (values (concatenate ;Date
+ 'string
+ (subseq mts 4 8) ;Year
+ (format nil "~2,'0D" ;Month
+ (1+ (position (subseq mts 0 3)
+ '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+ :test #'string-equal)))
+ (if (= (length daynum) 2) ;Day - 2 chars
+ daynum
+ (concatenate 'string "0" daynum)))
+
+ (concatenate ;Time
+ 'string
+ (if (= (length hrnum) 2) ;Day - 2 chars
+ hrnum
+ (concatenate 'string "0" hrnum))
+ (subseq mss 0 2) ;Minutes
+ (subseq mss 3 5))))) ;Seconds
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/digitizer.cl b/prism/src/digitizer.cl
new file mode 100644
index 0000000..116d5f4
--- /dev/null
+++ b/prism/src/digitizer.cl
@@ -0,0 +1,279 @@
+;;;
+;;; digitizer
+;;;
+;;; The lisp interface for the GP-8 sonic digitizer.
+;;;
+;;; 15-Mar-1994 J. Unger created.
+;;; 01-May-1994 J. Unger add gp8-calibrate and gp8-digitize functions,
+;;; transliterated from UWPLAN source file GP8.PAS
+;;; 10-Jun-1994 I. Kalet reorganize and add a lot.
+;;; 27-Jun-1994 I. Kalet insure that *gp8-xorigin* is nil when the
+;;; digitizer is initialized.
+;;; 11-Jul-1994 J. Unger work on getting digitizer dialog boxes to display
+;;; (not finished).
+;;; 11-Aug-1994 J. Unger add os-wait call to gp8-close
+;;; 8-Jan-1995 I. Kalet parametrize and change names to digit-
+;;; instead of gp8- in variables and functions. Create digitizer
+;;; class and instance to keep global data.
+;;; 12-Mar-1995 I. Kalet add global variables to prism-globals and use
+;;; them here - this is easier to customize than initargs or other
+;;; schemes.
+;;; 13-Aug-1995 I. Kalet change stream to different name for
+;;; compliance with ANSI standard.
+;;; 24-Dec-1998 I. Kalet run-subprocess for stty does not need output
+;;; redirect. Since wait is now default, don't need os-wait on close.
+;;; 13-Aug-2000 I. Kalet move digitizer-specific globals to here, as
+;;; they are really digitizer internals.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defvar *digitizer* nil "The instance of digitizer in use in the
+current prism session")
+
+;; these values are for the Science Accessories GP9
+
+(defvar *digit-x-start* 0 "The position of the first digit of the raw
+x coordinate data in the digitizer input string.")
+
+(defvar *digit-x-size* 5 "The length of the substring containing the
+raw x coordinate data.")
+
+(defvar *digit-y-start* 5 "The position of the first digit of the raw
+y coordinate data in the digitizer input string.")
+
+(defvar *digit-y-size* 5 "The length of the substring containing the
+raw y coordinate data.")
+
+(defvar *digit-exp-x-origin* 0 "The expected raw value for the x
+coordinate of the lower left calibration point.") ;; units are mm.
+
+(defvar *digit-exp-y-origin* -2328 "The expected raw value for the y
+coordinate of the lower left calibration point.")
+
+(defvar *digit-exp-x-full* 2295 "The expected raw value for the x
+coordinate of the upper right calibration point.")
+
+(defvar *digit-exp-y-full* -38 "The expected raw value for the y
+coordinate of the upper right calibration point.")
+
+(defvar *digit-exp-x-size* 58.0 "The width in cm of the digitizing
+area on the plastic overlay pattern.")
+
+(defvar *digit-exp-y-size* 58.0 "The full height in cm of the
+digitizing area on the plastic overlay pattern.")
+
+(defvar *digit-calib-tol* 30 "The tolerance for calibration values.")
+
+(defvar *digit-boxdepth* -2131 "The raw y coordinate of the top of the
+menu boxes")
+
+(defvar *digit-boxwidth* 394 "The raw horizontal width of a single
+menu box.")
+
+;;;--------------------------------------
+
+(defclass digitizer ()
+
+ ((device :type string
+ :initarg :device
+ :accessor device
+ :documentation "The device file name of the digitizer")
+
+ (digit-stream :type stream
+ :initarg :digit-stream
+ :accessor digit-stream
+ :documentation "The stream that is opened to the
+digitizer")
+
+ (x-origin :accessor x-origin
+ :initform nil ;; to insure initial calibration
+ :documentation "The raw value for the x coordinate of the
+lower left calibration point.")
+
+ (y-origin :accessor y-origin
+ :documentation "The raw value for the y coordinate of the
+lower left calibration point.")
+
+ (x-scale :type single-float
+ :accessor x-scale
+ :documentation "The x scale factor in cm per count.")
+
+ (y-scale :type single-float
+ :accessor y-scale
+ :documentation "The y scale factor in cm per count.")
+
+ )
+
+ (:documentation "The digitizer object is a frame for storing data
+about the particular instance of digitizer in use at a Prism site.")
+
+ )
+
+;;;--------------------------------------
+
+(defun digit-initialize (digit-dev)
+
+ "DIGIT-INITIALIZE digit-dev
+
+Initializes the input stream for the digitizer, using device filename
+digit-dev."
+
+ (setf *digitizer* (make-instance 'digitizer
+ :device digit-dev
+ :digit-stream (open digit-dev)))
+ (run-subprocess (format nil "stty 9600 cooked < ~a" digit-dev)))
+
+;;;--------------------------------------
+
+(defun digitizer-present ()
+
+ (if *digitizer* t nil))
+
+;;;--------------------------------------
+
+(defun digit-close ()
+
+ "DIGIT-CLOSE
+
+Closes the stream to the digitizer which was set up in digit-initialize."
+
+ (close (digit-stream *digitizer*))
+ (setf *digitizer* nil))
+
+;;;--------------------------------------
+
+(defun digit-raw-point ()
+
+ "DIGIT-RAW-POINT
+
+Takes no parameters. Reads a point from the sonic digitizer stream
+Returns two values, the x and y coordinates of that point in digitizer
+coordinates. This function will not return until the digitizer pen is
+sparked."
+
+ (let* ((xs *digit-x-start*)
+ (xe (+ xs *digit-x-size*))
+ (ys *digit-y-start*)
+ (ye (+ ys *digit-y-size*))
+ (coords (read-line (digit-stream *digitizer*))))
+ (values
+ (read-from-string (subseq coords xs xe))
+ (read-from-string (subseq coords ys ye)))))
+
+;;;--------------------------------------
+
+(defun digit-calibrate (&optional force-recalibration)
+
+ "DIGIT-CALIBRATE &optional force-recalibration
+
+If the global calibration values are not yet set or if
+force-recalibration is t, prompts the user to spark the lower left and
+upper right corners of the digitizer, via a SLIK readout. Sets the
+four global quantities: *digit-xorigin*, *digit-yorigin* (the integer
+value returned by the digitizer when it is sparked at the marked
+origin point in the lower left corner of the tabled), and
+*digit-xscale*, *digit-yscale* (real calibration constants, expressed in
+digitizer units/cm.)"
+
+ (when (or force-recalibration (not (x-origin *digitizer*)))
+ (let ((xorg *digit-exp-x-origin*)
+ (yorg *digit-exp-y-origin*)
+ (xfull *digit-exp-x-full*)
+ (yfull *digit-exp-y-full*)
+ (tol *digit-calib-tol*)
+ (xcal *digit-exp-x-size*)
+ (ycal *digit-exp-x-size*)
+ xraw yraw
+ (rdt (sl:make-readout 400 40 :title "Digitizer calibration")))
+ (loop ;; promp until a reasonable origin point is digitized
+ (setf (sl:info rdt) "Enter the lower left calibration point")
+ (multiple-value-setq (xraw yraw) (digit-raw-point))
+ (when (and (<= (- xorg tol) xraw (+ xorg tol))
+ (<= (- yorg tol) yraw (+ yorg tol)))
+ (setf (x-origin *digitizer*) xraw)
+ (setf (y-origin *digitizer*) yraw)
+ (return)))
+ (loop ;; prompt until a reasonable full span point is digitized
+ (setf (sl:info rdt) "Enter the upper right calibration point")
+ (multiple-value-setq (xraw yraw) (digit-raw-point))
+ (when (and (<= (- xfull tol) xraw (+ xfull tol))
+ (<= (- yfull tol) yraw (+ yfull tol)))
+ (setf (x-scale *digitizer*)
+ (float (/ (- xraw (x-origin *digitizer*)) xcal)))
+ (setf (y-scale *digitizer*)
+ (float (/ (- yraw (y-origin *digitizer*)) ycal)))
+ (return)))
+ (sl:destroy rdt))))
+
+;;;--------------------------------------
+
+(defun digit-reset ()
+
+ "DIGIT-RESET
+
+insures that digit-calibrate will compute new calibration values."
+
+ (setf (x-origin *digitizer*) nil))
+
+;;;--------------------------------------
+
+(defun digitize-point ()
+
+ "DIGITIZE-POINT
+
+Obtains from the digitizer the (x,y) coordinates of a single point,
+offset by the origin values entered in digit-calibrate and scaled by
+the scale factors determined there. A 3-element values form is
+returned, consisting of the status, the x coordinate, and the y
+coordinate. The status is one of :point, :delete-last, :delete-all,
+:close-contour, or :done, indicating where on the digitizer the pen
+was sparked. The returned x and y coordinates are in centimeters."
+
+ (let (xraw yraw)
+ (multiple-value-setq (xraw yraw) (digit-raw-point))
+ (values
+ (if (> yraw *digit-boxdepth*) :point
+ (case (truncate (- xraw (x-origin *digitizer*))
+ *digit-boxwidth*)
+ (0 :delete-last)
+ (1 :delete-all)
+ (2 :close-contour)
+ (3 :done)))
+ (float (/ (- xraw (x-origin *digitizer*))
+ (x-scale *digitizer*)))
+ (float (/ (- yraw (y-origin *digitizer*))
+ (y-scale *digitizer*))))))
+
+;;;--------------------------------------
+
+(defun digitize-contour (verts update-fn mag x0 y0)
+
+ "DIGITIZE-CONTOUR verts update-fn mag x0 y0
+
+Edits the vertex list verts (a list of (x y) pairs) with points
+acquired from the digitizer. Update-fn is called after each time the
+digitizer pen is sparked (it may update the display with the new
+contour segment, for example). Mag is the digitizer film
+magnification factor, i.e., the amount the digitizer film is
+magnified. The origin parameters specify an application defined
+origin relative to the lower left calibration point, and the
+coordinates returned are relative to that application origin. returns
+the verts list when the 'Done' box is sparked on the digitizer."
+
+ (do ((xcm nil)
+ (ycm nil)
+ (status nil))
+ ((eq status :done) verts)
+ (multiple-value-setq (status xcm ycm) (digitize-point))
+ (case status
+ (:point (push (list (/ (- xcm x0) mag)
+ (/ (- ycm y0) mag))
+ verts))
+ (:delete-last (setf verts (rest verts)))
+ (:delete-all (setf verts nil)))
+ (funcall update-fn verts)))
+
+;;;--------------------------------------
diff --git a/prism/src/dmp-panel.cl b/prism/src/dmp-panel.cl
new file mode 100644
index 0000000..f00b766
--- /dev/null
+++ b/prism/src/dmp-panel.cl
@@ -0,0 +1,451 @@
+;;;
+;;; dmp-panel
+;;;
+;;; Dicom-Subsystem GUI - Sub-panel for Dose-Monitoring Points.
+;;; Contains functions used in Client only.
+;;;
+;;; Implements a panel that is created by means of a button on the Dicom panel.
+;;; It creates a panel that allows the user to create and modify the list of
+;;; dose monitoring points (DMPs) for transfer via Dicom-RT protocol.
+;;;
+;;; 20-Jan-2004 M Phillips Started work on the panel.
+;;; 27-Jan-2004 BobGian: Began integration of new DMP Panel by Mark Phillips
+;;; with rest of Dicom Panel and interface to Dicom SCU.
+;;; 19-Feb-2004 BobGian: Introduced uniform naming convention explained
+;;; in file "imrt-segments".
+;;; 26-Feb-2004 BobGian: Completed DMP integration.
+;;; 27-Feb-2004 BobGian: Made Dicom-Panel operate at pushed event level.
+;;; 03-Mar-2004 BobGian: Changed Dicom-Panel back to same event level as
+;;; invoking context so other Prism operations can be run concurrently.
+;;; 07-Mar-2004 BobGian: Modified DMP selection and beam addition/deletion
+;;; to handle extra DI-DMP slots [parallel beam/dose lists] consistently.
+;;; 10-Mar-2004 BobGian: DI-DMP-PRIOR-CGY and DI-DMP-TOTAL-CGY -> FIXNUM.
+;;; 17-Mar-2004 BobGian: Added consistency-checking and display for total-dose
+;;; at current DMP - anything which changes set of beams contributing to the
+;;; DMP results in DI-DMP-TOTAL-CGY reset to NIL and border-color of
+;;; Total-Dose textline and Calc-Dose button being set to RED. Result of
+;;; a dose calculation sets dose slot to current value and textline/button
+;;; border colors to their initial default values.
+;;; 04-Apr-2004 BobGian: Change DI-DMP-TOTAL-CGY to record either computed
+;;; dose or user-textline-typed dose [using DI-DMP-DOSE-TYPE to indicate
+;;; which via value :Computed or :User, respectively]. Latter must be set
+;;; appropriately whenever former is set or reset.
+;;; 17-May-2004 BobGian complete process of extending all instances of Original
+;;; and Current Prism beam instances to include Copied beam instance too,
+;;; to provide copy for comparison with Current beam without mutating
+;;; Original beam instance.
+;;; 05-Oct-2004 BobGian fixed a few lines to fit within 80 cols.
+;;; 12-Oct-2004 BobGian DI-DMP-TREATED-CGY -> DI-DMP-PRIOR-CGY slot name change
+;;; for better consistency with Dicom-RT standard and Elekta documentation.
+;;; DI-DMP-TOTAL-CGY -> DI-DMP-ACCUM-CGY and DI-DMP-TOTAL-CGY.
+;;; PREV-DOSE-TEXTLINE -> PRIOR-DOSE-TEXTLINE in DMP-PANEL class.
+;;; Modify computation of DMP dose to get Total-cGy = Prior-cGy + Accum-cGy
+;;; in "Calculate Total dose" button action.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defclass dmp-panel ( )
+
+ ((frame :accessor frame
+ :documentation "Slik frame for this panel.")
+
+ (parent-panel :accessor parent-panel
+ :initarg :parent-panel
+ :documentation "Dicom panel that is the parent of this one.")
+
+ ;; Beam instances here are DICOM beams containing a slot referencing the
+ ;; Prism beams composing them. The Prism beams are Original beam instances
+ ;; containing DOSE-RESULT objects.
+ (dicom-beam-list :accessor dicom-beam-list
+ :initarg :dicom-beam-list
+ :documentation "List of current Dicom beams.")
+
+ (dicom-dmp-list :accessor dicom-dmp-list
+ :initarg :dicom-dmp-list
+ :documentation "List of [Dicom] dose monitoring points.")
+
+ (dicom-dmp-cnt :type fixnum
+ :accessor dicom-dmp-cnt
+ :initarg :dicom-dmp-cnt
+ :documentation "Instance counter for created DMPs.")
+
+ (add-dicom-beam-button :accessor add-dicom-beam-button
+ :documentation
+ "Button for creating pop-up menu of Dicom beams.")
+
+ (add-dmp-button :accessor add-dmp-button
+ :documentation
+ "Button for creating pop-up menu of points.")
+
+ (dmp-scrollinglist :accessor dmp-scrollinglist
+ :documentation "Scrolling list of [Dicom] DMPs.")
+
+ (dicom-beam-scrollinglist :accessor dicom-beam-scrollinglist
+ :documentation
+ "Scrolling list of Dicom beams for selected DMP.")
+
+ (prior-dose-textline :accessor prior-dose-textline
+ :documentation
+ "Textline showing previously treated dose.")
+
+ (total-dose-textline :accessor total-dose-textline
+ :documentation "Textline showing total dose.")
+
+ (dose-calc-button :accessor dose-calc-button
+ :documentation "Button for calculating dose to a DMP.")
+
+ (del-panel-button :accessor del-panel-button
+ :documentation "Button for deleting the panel.")
+ ))
+
+;;;=============================================================
+;;; Defconstants for DMP Panel.
+
+(defconstant btn-height 25)
+(defconstant btn-width 150)
+(defconstant tl-width 200)
+
+;;;=============================================================
+
+(defmethod initialize-instance :after ((ptp dmp-panel) &rest initargs)
+
+ "Initializes the Dose Monitoring Points panel."
+
+ (let* ((dp (parent-panel ptp))
+ (cur-pat (current-patient dp))
+ (point-list (coll:elements (points cur-pat)))
+ (dp-tl-color 'sl:green) ; textline border color
+ (dp-bt-color 'sl:cyan) ; button border color
+ (frm (apply #'sl:make-frame 450 400
+ :title
+ (format nil "Dose Monitoring Points Panel -- ~A"
+ (name cur-pat))
+ initargs))
+ (frm-win (sl:window frm))
+ (add-dicom-beam-bn (apply #'sl:make-button btn-width btn-height
+ :parent frm-win
+ :ulc-x (+ 20 tl-width) :ulc-y 10
+ :label "Add Beams"
+ :border-color dp-bt-color
+ initargs))
+ (add-dmp-bn (apply #'sl:make-button btn-width btn-height
+ :parent frm-win
+ :ulc-x 10 :ulc-y 10
+ :label "Add DMPs"
+ :border-color dp-bt-color
+ initargs))
+ (d-dmp-sl (apply #'sl:make-radio-scrolling-list
+ tl-width (* 10 btn-height)
+ :parent frm-win
+ :ulc-x 10 :ulc-y 45
+ :border-color dp-bt-color
+ :enable-delete t
+ initargs))
+ (d-bm-sl (apply #'sl:make-scrolling-list tl-width (* 10 btn-height)
+ :parent frm-win
+ :ulc-x (+ 20 tl-width) :ulc-y 45
+ :border-color dp-bt-color
+ :enable-delete t
+ initargs))
+ (prior-dose-tl (apply #'sl:make-textline tl-width btn-height
+ :parent frm-win
+ :ulc-x 10 :ulc-y 325
+ :numeric t
+ :lower-limit 0
+ :upper-limit 100000
+ :label "Previous dose: "
+ :border-color dp-tl-color
+ initargs))
+ (total-dose-tl (apply #'sl:make-textline tl-width btn-height
+ :parent frm-win
+ :ulc-x 10 :ulc-y 355
+ :numeric t
+ :lower-limit 0
+ :upper-limit 100000
+ :label "Total dose: "
+ :border-color dp-tl-color
+ initargs))
+ (dose-calc-bn (apply #'sl:make-button btn-width btn-height
+ :parent frm-win
+ :ulc-x (+ 20 tl-width) :ulc-y 325
+ :label "Calc. DMP dose"
+ :border-color dp-bt-color
+ initargs))
+ (d-dmp-alist '()) ; assoc. list for Dicom DMP scrolling list
+ (d-bm-alist '()) ; assoc. list for Dicom Beams scroll. list
+ (cur-d-dmp nil) ; current active Dicom DMP
+
+ (no-dmp-msg "Please select a DMP first"))
+
+ (declare (type list d-dmp-alist d-bm-alist))
+
+ (setf (frame ptp) frm
+ (del-panel-button ptp) (apply #'sl:make-exit-button
+ btn-width btn-height
+ :parent frm-win
+ :ulc-x (+ 20 tl-width) :ulc-y 355
+ :label "Delete Panel"
+ :fg-color 'sl:black :bg-color 'sl:red
+ :border-color dp-bt-color
+ initargs)
+ (add-dmp-button ptp) add-dmp-bn
+ (add-dicom-beam-button ptp) add-dicom-beam-bn
+ (dmp-scrollinglist ptp) d-dmp-sl
+ (dicom-beam-scrollinglist ptp) d-bm-sl
+ (prior-dose-textline ptp) prior-dose-tl
+ (total-dose-textline ptp) total-dose-tl
+ (dose-calc-button ptp) dose-calc-bn)
+
+ ;; Make scrolling list of DMPs.
+ (let ((d-dmp-list (dicom-dmp-list ptp)))
+ (when (consp d-dmp-list)
+ (dolist (d-dmp-obj d-dmp-list)
+ (let ((btn (sl:make-list-button d-dmp-sl (di-dmp-name d-dmp-obj))))
+ (sl:insert-button btn d-dmp-sl)
+ (push (cons btn d-dmp-obj) d-dmp-alist)))))
+
+ ;; Select existing DMP.
+ (ev:add-notify ptp (sl:selected d-dmp-sl)
+ #'(lambda (ptp d-dmp-sl btn)
+ (declare (ignore ptp d-dmp-sl))
+ (setq d-bm-alist '())
+ (setq cur-d-dmp :Ignore) ;Fake out DELETED event handler for D-BM-SL.
+ (dolist (b-bn (sl:buttons d-bm-sl)) ;Clear Dicom beam list.
+ (sl:delete-button b-bn d-bm-sl))
+ (setq cur-d-dmp (cdr (assoc btn d-dmp-alist :test #'eq)))
+ (dolist (d-bm-obj (di-dmp-dbeams cur-d-dmp))
+ (let ((bn (sl:make-list-button d-bm-sl (di-beam-name d-bm-obj))))
+ (sl:insert-button bn d-bm-sl)
+ (push (cons bn d-bm-obj) d-bm-alist)))
+ ;; Prior-cGy, Accum-cGy, and Total-cGy are stored as FIXNUMs in
+ ;; centiGray. Elekta DMPs represent doses this way. They are
+ ;; conveyed via Dicom in Gray with 2-decimal-place precision.
+ (cond ((di-dmp-dose-type cur-d-dmp) ; Type :Computed or :User
+ (setf (sl:border-color dose-calc-bn) dp-bt-color)
+ (setf (sl:border-color total-dose-tl) dp-tl-color)
+ (setf (sl:info total-dose-tl)
+ (format nil "~D" (di-dmp-total-cGy cur-d-dmp))))
+ ;; DOSE-TYPE = NIL -> not yet computed/stored - mark borders.
+ (t (setf (sl:border-color dose-calc-bn) 'sl:red)
+ (setf (sl:border-color total-dose-tl) 'sl:red)
+ (setf (sl:info total-dose-tl) "")))
+ (setf (sl:info prior-dose-tl)
+ (format nil "~D" (di-dmp-prior-cGy cur-d-dmp)))))
+
+ ;; Add-DMP button actions
+ (ev:add-notify ptp (sl:button-on add-dmp-bn)
+ #'(lambda (ptp a)
+ (declare (ignore a))
+ (let ((sel-item nil)
+ (sel-pt nil)
+ (new-d-dmp nil))
+ ;; Prompt user for name of DMP and make scrolling list.
+ (when (setq sel-item (sl:popup-scroll-menu
+ (mapcar #'name point-list)
+ 150 250 :multiple nil))
+ (setq sel-pt (nth sel-item point-list))
+ ;; Construct new DMP and do what is necessary.
+ (setq new-d-dmp (make-di-dmp
+ :name (sl:popup-textline
+ (string-trim " " (name sel-pt))
+ 300
+ :label "Name for new DMP: ")
+ :point sel-pt
+ :counter
+ (incf (the fixnum (dicom-dmp-cnt ptp)))
+ :prior-cGy 0
+ :accum-cGy 0
+ :total-cGy 0
+ :dose-type nil
+ :dbeams nil
+ :pdoses nil))
+ (setf (dicom-dmp-list ptp)
+ (nconc (dicom-dmp-list ptp) (list new-d-dmp)))
+ ;; Insert selected point in DMP scrolling list.
+ (let ((btn (sl:make-list-button d-dmp-sl
+ (di-dmp-name new-d-dmp))))
+ (sl:insert-button btn d-dmp-sl)
+ (push (cons btn new-d-dmp) d-dmp-alist)
+ (sl:select-button btn d-dmp-sl))
+ (setq cur-d-dmp new-d-dmp)
+ (setf (sl:border-color dose-calc-bn) 'sl:red)
+ (setf (sl:border-color total-dose-tl) 'sl:red)
+ (setf (sl:info total-dose-tl) "")
+ (setf (sl:info prior-dose-tl) "0")))
+ (setf (sl:on add-dmp-bn) nil)))
+
+ ;; Delete existing DMP
+ (ev:add-notify ptp (sl:deleted d-dmp-sl)
+ #'(lambda (ptp d-dmp-sl btn)
+ (declare (ignore d-dmp-sl))
+ (setf (dicom-dmp-list ptp)
+ (delete (cdr (assoc btn d-dmp-alist :test #'eq))
+ (dicom-dmp-list ptp)
+ :test #'eq))))
+
+ ;; Add-Dicom-Beam button actions
+ (ev:add-notify ptp (sl:button-on add-dicom-beam-bn)
+ #'(lambda (ptp a)
+ (declare (ignore a))
+ (cond
+ (cur-d-dmp
+ ;; Selected Dicom beam indices (list)
+ (let ((sel-list (sl:popup-scroll-menu
+ (mapcar #'di-beam-name
+ (dicom-beam-list ptp))
+ 150 250
+ :multiple t)))
+ ;; Add new Dicom beam(s).
+ (when (consp sel-list)
+ (dolist (sel sel-list)
+ (let* ((new-d-bm (nth sel (dicom-beam-list ptp)))
+ (btn (sl:make-list-button
+ d-bm-sl (di-beam-name new-d-bm)))
+ (point-idx (position (di-dmp-point cur-d-dmp)
+ point-list :test #'eq)))
+ (declare (type fixnum point-idx))
+ (setf (di-dmp-dbeams cur-d-dmp)
+ (nconc (di-dmp-dbeams cur-d-dmp)
+ (list new-d-bm)))
+ ;; Doses here are cGy as SMALL-FLOAT values.
+ (setf (di-dmp-pdoses cur-d-dmp)
+ (nconc (di-dmp-pdoses cur-d-dmp)
+ (list (mapcar
+ #'(lambda (seg-doses)
+ (nth point-idx seg-doses))
+ (di-beam-opbi-doses new-d-bm)))))
+ (sl:insert-button btn d-bm-sl)
+ (push (cons btn new-d-bm) d-bm-alist)))
+ (setf (di-dmp-accum-cGy cur-d-dmp) 0)
+ (setf (di-dmp-total-cGy cur-d-dmp) 0)
+ (setf (di-dmp-dose-type cur-d-dmp) nil)
+ (setf (sl:border-color dose-calc-bn) 'sl:red)
+ (setf (sl:border-color total-dose-tl) 'sl:red)
+ (setf (sl:info total-dose-tl) ""))))
+ (t (sl:acknowledge no-dmp-msg)))
+ (setf (sl:on add-dicom-beam-bn) nil)))
+
+ ;; Delete Dicom beam from current Dicom DMP.
+ (ev:add-notify ptp (sl:deleted d-bm-sl)
+ #'(lambda (ptp d-bm-sl btn)
+ (declare (ignore ptp d-bm-sl))
+ (cond
+ ((eq cur-d-dmp :Ignore))
+ ((di-dmp-p cur-d-dmp)
+ ;; Doses here are cGy as SMALL-FLOAT values.
+ (do ((d-bmlist (di-dmp-dbeams cur-d-dmp) (cdr d-bmlist))
+ (doselist (di-dmp-pdoses cur-d-dmp) (cdr doselist))
+ (del-d-bm (cdr (assoc btn d-bm-alist :test #'eq)))
+ (filtered-bmlist '())
+ (filtered-doselist '()))
+ ((null d-bmlist)
+ (setf (di-dmp-dbeams cur-d-dmp)
+ (nreverse filtered-bmlist))
+ (setf (di-dmp-pdoses cur-d-dmp)
+ (nreverse filtered-doselist)))
+ (unless (eq (car d-bmlist) del-d-bm)
+ (push (car d-bmlist) filtered-bmlist)
+ (push (car doselist) filtered-doselist)))
+ (setf (di-dmp-accum-cGy cur-d-dmp) 0)
+ (setf (di-dmp-total-cGy cur-d-dmp) 0)
+ (setf (di-dmp-dose-type cur-d-dmp) nil)
+ (setf (sl:border-color dose-calc-bn) 'sl:red)
+ (setf (sl:border-color total-dose-tl) 'sl:red)
+ (setf (sl:info total-dose-tl) ""))
+ (t (sl:acknowledge no-dmp-msg)))))
+
+ ;; Calculate total dose.
+ (ev:add-notify ptp (sl:button-on dose-calc-bn)
+ #'(lambda (ptp a)
+ (declare (ignore ptp a))
+ (cond (cur-d-dmp
+ (let ((accum-dose 0.0))
+ (declare (type single-float accum-dose))
+ ;; For the current DMP, iterate over all the Dicom beams
+ ;; contributing to the DMP and all the segments making up
+ ;; each Dicom Beam which so contributes [Accum-cGy].
+ ;; Total-cGy is sum of Prior-cGy and Accum-cGy.
+ ;; Doses here are cGy as SMALL-FLOAT values.
+ (dolist (doselist (di-dmp-pdoses cur-d-dmp))
+ (do ((seg-doses doselist (cdr seg-doses)))
+ ((null seg-doses))
+ (incf accum-dose (the single-float (car seg-doses)))))
+ (setf (sl:info total-dose-tl)
+ (format nil "~D"
+ (setf (di-dmp-total-cGy cur-d-dmp)
+ (+ (the fixnum
+ (di-dmp-prior-cGy cur-d-dmp))
+ (setf (di-dmp-accum-cGy cur-d-dmp)
+ (round accum-dose)))))))
+ (setf (di-dmp-dose-type cur-d-dmp) :Computed)
+ (setf (sl:border-color total-dose-tl) dp-tl-color)
+ (setf (sl:border-color dose-calc-bn) dp-bt-color))
+ (t (sl:acknowledge no-dmp-msg)))
+ (setf (sl:on dose-calc-bn) nil)))
+
+ ;; Enter value for total DMP dose.
+ ;; Border color switched by :KEY-PRESS handler for textline.
+ ;; Recommended that users use this textline as Read/Only.
+ (ev:add-notify ptp (sl:new-info total-dose-tl)
+ #'(lambda (ptp new-value info)
+ (declare (ignore ptp new-value))
+ (cond (cur-d-dmp
+ (when info
+ (setf (di-dmp-total-cGy cur-d-dmp)
+ (round (read-from-string info)))
+ (setf (di-dmp-dose-type cur-d-dmp) :User)))
+ (t (sl:acknowledge no-dmp-msg)))))
+
+ ;; Enter value for previously treated dose.
+ ;; Border color switched by :KEY-PRESS handler for textline.
+ ;; Temporary policy - do not use this textline.
+ (ev:add-notify ptp (sl:new-info prior-dose-tl)
+ #'(lambda (ptp new-value info)
+ (declare (ignore ptp new-value))
+ (cond (cur-d-dmp
+ (when info
+ (setf (di-dmp-prior-cGy cur-d-dmp)
+ (round (read-from-string info)))))
+ (t (sl:acknowledge no-dmp-msg)))))))
+
+;;;=============================================================
+
+(defun run-dmp-panel (&rest initargs &aux ptp)
+
+ "run-dmp-panel &rest initargs
+
+Creates a DMP panel with the specified initargs
+and runs it in a pushed event level."
+
+ (sl:push-event-level)
+ (setq ptp (apply #'make-instance 'dmp-panel initargs))
+ (sl:process-events)
+
+ (let ((dp (parent-panel ptp)))
+ (setf (dicom-dmp-list dp) (dicom-dmp-list ptp))
+ (setf (dicom-dmp-cnt dp) (dicom-dmp-cnt ptp)))
+ (setf (dicom-dmp-list ptp) nil)
+ (setf (dicom-beam-list ptp) nil)
+ ;; Remove event notifications before destroying scrolling lists.
+ (dolist (sl (list (dmp-scrollinglist ptp)
+ (dicom-beam-scrollinglist ptp)))
+ (setf (sl:selected sl) nil)
+ (setf (sl:deselected sl) nil)
+ (setf (sl:inserted sl) nil)
+ (setf (sl:deleted sl) nil)
+ (sl:destroy sl))
+ (sl:destroy (del-panel-button ptp))
+ (sl:destroy (add-dmp-button ptp))
+ (sl:destroy (add-dicom-beam-button ptp))
+ (sl:destroy (prior-dose-textline ptp))
+ (sl:destroy (total-dose-textline ptp))
+ (sl:destroy (dose-calc-button ptp))
+ (sl:destroy (frame ptp))
+
+ (sl:pop-event-level))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/dose-grid-graphics.cl b/prism/src/dose-grid-graphics.cl
new file mode 100644
index 0000000..ed5ebb6
--- /dev/null
+++ b/prism/src/dose-grid-graphics.cl
@@ -0,0 +1,184 @@
+;;;
+;;; dose-grid-graphics
+;;;
+;;; Draw methods for grid-geometries into views.
+;;;
+;;; 18-Oct-1993 J. Unger create from earlier prototype.
+;;; 5-Nov-1993 J. Unger add draw methods for dose grid into views.
+;;; 8-Apr-1994 I. Kalet split off from dose-graphics
+;;; 18-Apr-1994 I. Kalet change refs to view origin
+;;; 16-Jun-1994 I. Kalet change color in grid geom. to display-color
+;;; 4-Sep-1995 I. Kalet change open coding to calls to pix-x, pix-y,
+;;; and add declarations
+;;; 19-Sep-1996 I. Kalet remove &rest from draw methods
+;;; 5-Dec-1996 I. Kalet don't generate primitives if color is invisible
+;;; 03-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx .
+;;; 21-Apr-1999 I. Kalet change sl:invisible to 'sl:invisible.
+;;; 25-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 25-Sep-2002 I. Kalet add (stub) support for room-view.
+;;; 25-May-2009 I. Kalet remove support for room view.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defmethod draw ((dg grid-geometry) (v view))
+
+ "draw (dg grid-geometry) (v view)
+
+This is a no-op for views that are not explicitly specified in
+draw methods elsewhere."
+
+ )
+
+;;;---------------------------------------------
+
+(defun compute-grid-geometry-graphics (y-up g-xorig g-yorig g-xsize g-ysize
+ g-xdim g-ydim v-xorig v-yorig v-ppcm)
+
+ "compute-grid-geometry-graphics y-up g-xorig g-yorig g-xsize g-ysize
+ g-xdim g-ydim v-xorig v-yorig v-ppcm
+
+Computes a sequence of {x1 y1 x2 y2}* terms, suitable for inclusion
+in a segments-prim, which represent the four corners of a grid-geometry
+as it appears in an orthogonal view. Parameters:
+
+ y-up t if yaxis points up in the view; nil otherwise
+ g-xorig g-yorig origin of grid geom as it appears in view
+ g-xsize g-ysize size of grid geom as it appears in view
+ g-xdim g-ydim dimensions of specified grid
+ v-xorig v-yorig origin of patient space axes in view (in pixels)
+ v-ppcm scale of view"
+
+ (let* ((g-dx (float (/ g-xsize (1- g-xdim))))
+ (g-dy (float (/ g-ysize (1- g-ydim))))
+ (g-xorig-t (pix-x g-xorig v-xorig v-ppcm))
+ (g-yorig-t (if y-up (pix-y g-yorig v-yorig v-ppcm)
+ (pix-x g-yorig v-yorig v-ppcm)))
+ (g-xsize-t (round (* g-xsize v-ppcm)))
+ (g-ysize-t (round (* g-ysize v-ppcm)))
+ (g-dx-t (round (* g-dx v-ppcm)))
+ (g-dy-t (round (* g-dy v-ppcm)))
+ (x-llc g-xorig-t)
+ (y-llc g-yorig-t)
+ (x-lrc (+ g-xorig-t g-xsize-t))
+ (y-lrc g-yorig-t)
+ (x-ulc g-xorig-t)
+ (y-ulc (- g-yorig-t g-ysize-t))
+ (x-urc (+ g-xorig-t g-xsize-t))
+ (y-urc (- g-yorig-t g-ysize-t)))
+ (declare (fixnum v-xorig v-yorig g-xorig-t g-yorig-t g-xsize-t
+ g-ysize-t g-dx-t g-dy-t x-llc y-llc x-lrc y-lrc
+ x-ulc y-ulc x-urc y-urc)
+ (single-float g-xorig g-yorig g-xsize g-ysize v-ppcm g-dx
+ g-dy))
+ (list x-llc y-llc x-llc (- y-llc g-dy-t)
+ x-llc y-llc (+ x-llc g-dx-t) y-llc
+ x-lrc y-lrc x-lrc (- y-lrc g-dy-t)
+ x-lrc y-lrc (- x-lrc g-dx-t) y-lrc
+ x-ulc y-ulc x-ulc (+ y-ulc g-dy-t)
+ x-ulc y-ulc (+ x-ulc g-dx-t) y-ulc
+ x-urc y-urc x-urc (+ y-urc g-dy-t)
+ x-urc y-urc (- x-urc g-dx-t) y-urc)))
+
+;;;---------------------------------------------
+
+(defmethod draw ((dg grid-geometry) (v transverse-view))
+
+ "draw (dg grid-geometry) (v transverse-view)
+
+This method draws the dose grid into a transverse view."
+
+ (if (eql (display-color dg) 'sl:invisible)
+ (setf (foreground v) (remove dg (foreground v) :key #'object))
+ (let ((prim (find dg (foreground v) :key #'object))
+ (color (sl:color-gc (display-color dg))))
+ (unless prim
+ (setq prim (make-segments-prim nil color :object dg))
+ (push prim (foreground v)))
+ (setf (color prim) color
+ (points prim) nil)
+ (when
+ (and (poly:nearly-increasing
+ (z-origin dg) (view-position v)
+ (+ (z-origin dg) (z-size dg)))
+ (plusp (x-size dg))
+ (plusp (y-size dg))
+ (plusp (z-size dg)))
+ (setf (points prim)
+ (compute-grid-geometry-graphics
+ t
+ (x-origin dg) (y-origin dg)
+ (x-size dg) (y-size dg)
+ (x-dim dg) (y-dim dg)
+ (x-origin v) (y-origin v)
+ (scale v)))))))
+
+;;;---------------------------------------------
+
+(defmethod draw ((dg grid-geometry) (v coronal-view))
+
+ "draw (dg grid-geometry) (v coronal-view)
+
+This method draws the dose grid into a coronal view."
+
+ (if (eql (display-color dg) 'sl:invisible)
+ (setf (foreground v) (remove dg (foreground v) :key #'object))
+ (let ((prim (find dg (foreground v) :key #'object))
+ (color (sl:color-gc (display-color dg))))
+ (unless prim
+ (setq prim (make-segments-prim nil color :object dg))
+ (push prim (foreground v)))
+ (setf (color prim) color
+ (points prim) nil)
+ (when
+ (and (poly:nearly-increasing
+ (y-origin dg) (view-position v)
+ (+ (y-origin dg) (y-size dg)))
+ (plusp (x-size dg))
+ (plusp (y-size dg))
+ (plusp (z-size dg)))
+ (setf (points prim)
+ (compute-grid-geometry-graphics
+ nil
+ (x-origin dg) (+ (z-origin dg) (z-size dg))
+ (x-size dg) (z-size dg)
+ (x-dim dg) (z-dim dg)
+ (x-origin v) (y-origin v)
+ (scale v)))))))
+
+;;;---------------------------------------------
+
+(defmethod draw ((dg grid-geometry) (v sagittal-view))
+
+ "draw (dg grid-geometry) (v sagittal-view)
+
+This method draws the dose grid into a sagittal view."
+
+ (if (eql (display-color dg) 'sl:invisible)
+ (setf (foreground v) (remove dg (foreground v) :key #'object))
+ (let ((prim (find dg (foreground v) :key #'object))
+ (color (sl:color-gc (display-color dg))))
+ (unless prim
+ (setq prim (make-segments-prim nil color :object dg))
+ (push prim (foreground v)))
+ (setf (color prim) color
+ (points prim) nil)
+ (when
+ (and (poly:nearly-increasing
+ (x-origin dg) (view-position v) (+ (x-origin dg) (x-size dg)))
+ (plusp (x-size dg))
+ (plusp (y-size dg))
+ (plusp (z-size dg)))
+ (setf (points prim)
+ (compute-grid-geometry-graphics
+ t
+ (z-origin dg) (y-origin dg)
+ (z-size dg) (y-size dg)
+ (z-dim dg) (y-dim dg)
+ (x-origin v) (y-origin v)
+ (scale v)))))))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/dose-grid-mediators.cl b/prism/src/dose-grid-mediators.cl
new file mode 100644
index 0000000..9e21d1b
--- /dev/null
+++ b/prism/src/dose-grid-mediators.cl
@@ -0,0 +1,344 @@
+;;;
+;;; dose-grid-mediators
+;;;
+;;; The class definitions and functions for mediators involved
+;;; with the management of grid geometry information.
+;;;
+;;; 15-Oct-1993 J. Unger created from design report and earlier prototypes.
+;;; 20-Oct-1993 J. Unger add dose-specification-manager.
+;;; 5-Nov-1993 J. Unger add grid-view-mediator.
+;;; 29-Nov-1993 J. Unger change occurrences new-dim to new-density, add
+;;; new-color add- & remove-notifies to grid-view-mediator code.
+;;; 3-Jan-1994 J. Unger change 'density' to 'voxel-size' in code.
+;;; 8-Apr-1994 I. Kalet split off from dose-mediators
+;;; 18-Apr-1994 I. Kalet add code for corner grab boxes, change ref to
+;;; view origin to new names
+;;; 25-Apr-1994 I. Kalet move pix-x and pix-y to contour-graphics,
+;;; change color to gcontext instead of symbol, don't display in bev.
+;;; 22-May-1994 I. Kalet ignore grab box motion unless button 1 down
+;;; 16-Jun-1994 I. Kalet change color in dose grid to display-color
+;;; 3-Sep-1995 I. Kalet use cm-x and cm-y where appropriate. Coerce
+;;; single-float in a few spots also.
+;;; 9-Oct-1996 I. Kalet make calls to draw conform to signature,
+;;; don't use apply and &rest parameters, in draw or in lambda for
+;;; update-view call.
+;;; 25-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 2-Oct-2002 I. Kalet add support for other view types - just ignore
+;;; for now
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass grid-view-mediator (object-view-mediator)
+
+ ((ulc :accessor ulc
+ :initform nil
+ :documentation "The grab box for the upper left corner.")
+
+ (llc :accessor llc
+ :documentation "The grab box for the lower left corner.")
+
+ (urc :accessor urc
+ :documentation "The grab box for the upper right corner.")
+
+ (lrc :accessor lrc
+ :documentation "The grab box for the lower right corner.")
+
+ )
+
+ (:documentation "This mediator connects a grid geometry with a view.
+It also maintains the grid corner grab boxes in the view")
+ )
+
+;;;--------------------------------------
+
+(defmethod grid-box-xy ((vw transverse-view) grid)
+
+ "returns four values, x-left, x-right, y-upper and y-lower pixel
+coordinates of the grid grab boxes in view vw."
+
+ (let* ((xl (x-origin grid))
+ (yl (y-origin grid))
+ (xr (+ xl (x-size grid)))
+ (yu (+ yl (y-size grid)))
+ (x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (ppcm (scale vw)))
+ (values (pix-x xl x0 ppcm)
+ (pix-x xr x0 ppcm)
+ (pix-y yu y0 ppcm)
+ (pix-y yl y0 ppcm))))
+
+;;;--------------------------------------
+
+(defmethod grid-box-xy ((vw coronal-view) grid)
+
+ "returns four values, x-left, x-right, y-upper and y-lower pixel
+coordinates of the grid grab boxes in view vw."
+
+ (let* ((xl (x-origin grid))
+ (yu (- (z-origin grid)))
+ (xr (+ xl (x-size grid)))
+ (yl (- yu (z-size grid)))
+ (x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (ppcm (scale vw)))
+ (values (pix-x xl x0 ppcm)
+ (pix-x xr x0 ppcm)
+ (pix-y yu y0 ppcm)
+ (pix-y yl y0 ppcm))))
+
+
+;;;--------------------------------------
+
+(defmethod grid-box-xy ((vw sagittal-view) grid)
+
+ "returns four values, x-left, x-right, y-upper and y-lower pixel
+coordinates of the grid grab boxes in view vw."
+
+ (let* ((xl (z-origin grid))
+ (yl (y-origin grid))
+ (xr (+ xl (z-size grid)))
+ (yu (+ yl (y-size grid)))
+ (x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (ppcm (scale vw)))
+ (values (pix-x xl x0 ppcm)
+ (pix-x xr x0 ppcm)
+ (pix-y yu y0 ppcm)
+ (pix-y yl y0 ppcm))))
+
+;;;--------------------------------------
+
+(defmethod update-grid ((vw transverse-view) gg xl xr yu yl)
+
+ (let ((x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (ppcm (scale vw)))
+ (setf (x-origin gg) (cm-x xl x0 ppcm)
+ (y-origin gg) (cm-y yl y0 ppcm)
+ (x-size gg) (coerce (/ (- xr xl) ppcm) 'single-float)
+ (y-size gg) (coerce (/ (- yl yu) ppcm) 'single-float))))
+
+;;;--------------------------------------
+
+(defmethod update-grid ((vw coronal-view) gg xl xr yu yl)
+
+ (let ((x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (ppcm (scale vw)))
+ (setf (x-origin gg) (cm-x xl x0 ppcm)
+ (z-origin gg) (cm-x yu y0 ppcm) ;; z is like x here
+ (x-size gg) (coerce (/ (- xr xl) ppcm) 'single-float)
+ (z-size gg) (coerce (/ (- yl yu) ppcm) 'single-float))))
+
+;;;--------------------------------------
+
+(defmethod update-grid ((vw sagittal-view) gg xl xr yu yl)
+
+ (let ((x0 (x-origin vw))
+ (y0 (y-origin vw))
+ (ppcm (scale vw)))
+ (setf (z-origin gg) (cm-x xl x0 ppcm) ;; z is like x here too
+ (y-origin gg) (cm-y yl y0 ppcm)
+ (z-size gg) (coerce (/ (- xr xl) ppcm) 'single-float)
+ (y-size gg) (coerce (/ (- yl yu) ppcm) 'single-float))))
+
+;;;--------------------------------------
+
+(defmethod view-intersects-grid ((vw transverse-view) gg)
+
+ (let ((z (view-position vw))
+ (z0 (z-origin gg)))
+ (and (>= z z0)
+ (<= z (+ z0 (z-size gg))))))
+
+;;;--------------------------------------
+
+(defmethod view-intersects-grid ((vw coronal-view) gg)
+
+ (let ((y (view-position vw))
+ (y0 (y-origin gg)))
+ (and (>= y y0)
+ (<= y (+ y0 (y-size gg))))))
+
+;;;--------------------------------------
+
+(defmethod view-intersects-grid ((vw sagittal-view) gg)
+
+ (let ((x (view-position vw))
+ (x0 (x-origin gg)))
+ (and (>= x x0)
+ (<= x (+ x0 (x-size gg))))))
+
+;;;--------------------------------------
+
+(defmethod view-intersects-grid ((vw view) gg)
+
+ "default for all other views - always return nil!"
+
+ (declare (ignore gg))
+ nil)
+
+;;;--------------------------------------
+
+(defun add-grid-boxes (gvm)
+
+ "adds four grab boxes in the view in gvm at the grid corners of the
+grid in gvm, if the view intersects the grid."
+
+ (let* ((vw (view gvm))
+ (gg (object gvm))
+ (col (sl:color-gc (display-color gg))))
+ (when (view-intersects-grid vw gg) ;; check for intersection...
+ (multiple-value-bind (xl xr yu yl) (grid-box-xy vw gg)
+ (setf (ulc gvm) (sl:make-square gg xl yu :color col)
+ (llc gvm) (sl:make-square gg xl yl :color col)
+ (urc gvm) (sl:make-square gg xr yu :color col)
+ (lrc gvm) (sl:make-square gg xr yl :color col)))
+ (sl:add-pickable-obj
+ (list (ulc gvm) (llc gvm) (urc gvm) (lrc gvm))
+ (picture vw))
+ ;; register with the grab boxes - just set origin and size of
+ ;; grid and the actions for those will update the rest
+ (ev:add-notify gvm (sl:motion (ulc gvm))
+ #'(lambda (med gb x y state)
+ (declare (ignore gb))
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (let* ((grid (object med))
+ (v (view med)))
+ (multiple-value-bind (xla xra yua yla)
+ (grid-box-xy v grid)
+ (declare (ignore xla yua))
+ (update-grid v grid x xra y yla))))))
+ (ev:add-notify gvm (sl:motion (llc gvm))
+ #'(lambda (med gb x y state)
+ (declare (ignore gb))
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (let* ((grid (object med))
+ (v (view med)))
+ (multiple-value-bind (xla xra yua yla)
+ (grid-box-xy v grid)
+ (declare (ignore xla yla))
+ (update-grid v grid x xra yua y))))))
+ (ev:add-notify gvm (sl:motion (urc gvm))
+ #'(lambda (med gb x y state)
+ (declare (ignore gb))
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (let* ((grid (object med))
+ (v (view med)))
+ (multiple-value-bind (xla xra yua yla)
+ (grid-box-xy v grid)
+ (declare (ignore xra yua))
+ (update-grid v grid xla x y yla))))))
+ (ev:add-notify gvm (sl:motion (lrc gvm))
+ #'(lambda (med gb x y state)
+ (declare (ignore gb))
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (let* ((grid (object med))
+ (v (view med)))
+ (multiple-value-bind (xla xra yua yla)
+ (grid-box-xy v grid)
+ (declare (ignore xra yla))
+ (update-grid v grid xla x yua y))))))
+ )))
+
+;;;--------------------------------------
+
+(defun update-grid-boxes (gvm)
+
+ "updates the grab boxes if present and still intersecting. Adds
+them if not present and intersecting. Deletes them if not
+intersecting and present."
+
+ (let ((gg (object gvm))
+ (vw (view gvm)))
+ (if (view-intersects-grid vw gg)
+ (if (ulc gvm) ;; already have them, so update them
+ (multiple-value-bind (xl xr yu yl)
+ (grid-box-xy vw gg)
+ (setf (sl:x-center (ulc gvm)) xl
+ (sl:y-center (ulc gvm)) yu
+ (sl:x-center (llc gvm)) xl
+ (sl:y-center (llc gvm)) yl
+ (sl:x-center (urc gvm)) xr
+ (sl:y-center (urc gvm)) yu
+ (sl:x-center (lrc gvm)) xr
+ (sl:y-center (lrc gvm)) yl))
+ (add-grid-boxes gvm)) ;; otherwise add them
+ (if (ulc gvm) ;; if present, remove them, otherwise nothing
+ (progn (sl:remove-pickable-objs gg (picture vw))
+ (setf (ulc gvm) nil)))))) ;; only need to set the first one
+
+;;;--------------------------------------
+
+(defmethod update-grid :after ((vw view) gg xl xr yu yl)
+
+ "insures only one graphic update."
+
+ (declare (ignore xl xr yu yl))
+ (ev:announce gg (new-coords gg)))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((gvm grid-view-mediator)
+ &rest initargs)
+ (declare (ignore initargs))
+ (let* ((gg (object gvm))
+ (vw (view gvm)))
+ (add-grid-boxes gvm) ;; create the grab boxes
+ (ev:add-notify gvm (new-coords gg)
+ #'(lambda (med grid &rest pars)
+ (declare (ignore pars))
+ (update-grid-boxes med)
+ (update-view med grid)))
+ (ev:add-notify gvm (new-voxel-size gg) #'update-view)
+ (ev:add-notify gvm (new-color gg)
+ #'(lambda (med grid &rest pars)
+ (declare (ignore pars))
+ (if (ulc med)
+ (let ((col (sl:color-gc
+ (display-color (object med)))))
+ (setf (sl:color (ulc med)) col
+ (sl:color (llc med)) col
+ (sl:color (urc med)) col
+ (sl:color (lrc med)) col)))
+ (update-view med grid)))
+
+ ;; this supercedes the generic object-view-mediator add-notify
+ ;; but the generic remove-notify is still ok.
+ (ev:add-notify gvm (refresh-fg vw)
+ #'(lambda (med v)
+ (update-grid-boxes med) ;; this is additional
+ (draw (object med) v)))))
+
+;;;--------------------------------------
+
+(defmethod destroy :after ((gvm grid-view-mediator))
+
+ (let ((obj (object gvm))
+ (vw (view gvm)))
+ (sl:remove-pickable-objs obj (picture vw))
+ (ev:remove-notify gvm (new-coords obj))
+ (ev:remove-notify gvm (new-voxel-size obj))
+ (ev:remove-notify gvm (new-color obj))))
+
+;;;--------------------------------------
+
+(defun make-grid-view-mediator (gg v)
+
+ "MAKE-GRID-VIEW-MEDIATOR gg v
+
+Creates and returns a grid-view-mediator between grid-geometry gg and
+view v."
+
+ (make-instance 'grid-view-mediator :object gg :view v))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/dose-grids.cl b/prism/src/dose-grids.cl
new file mode 100644
index 0000000..ad4c30c
--- /dev/null
+++ b/prism/src/dose-grids.cl
@@ -0,0 +1,202 @@
+;;;
+;;; dose-grids
+;;;
+;;; Definitions of grid geometry object for the specification of dose
+;;; information in Prism.
+;;;
+;;; 11-Oct-1993 J. Unger created from current implementation report.
+;;; 29-Nov-1993 J. Unger remove dim attributes of grid-geometry and add
+;;; functions to compute them; add density attribute to grid-geom + event.
+;;; 22-Dec-1993 J. Unger add new-color to grid-geometry not-saved method.
+;;; 3-Jan-1994 J. Unger change 'density' to 'voxel-size' in code.
+;;; 14-Feb-1994 J. Unger remove default-initargs for origin & size of
+;;; grid-geometry object, move constants defining fine, med, & coarse
+;;; grid granularities here from dose-panels module, set voxel-size
+;;; default initarg to coarse grid granularity.
+;;; 14-Feb-1994 J. Unger add setf methods for grid-geometry size
+;;; attrs to enforce a minimum size; add *minimum-grid-size* constant.
+;;; 18-Feb-1994 J. Unger change values of dose grid granularity.
+;;; 18-Feb-1994 D. Nguyen add copy-grid-geometry
+;;; 18-Apr-1994 I. Kalet split off from dose-objects, change name of
+;;; module above, change events to just one, don't announce it here.
+;;; 12-May-1994 I. Kalet move globals to prism-globals.
+;;; 13-Jun-1994 I. Kalet take out message from copy-dose-grid.
+;;; 16-Jun-1994 I. Kalet change color to display-color.
+;;; 23-Feb-1995 I. Kalet provide default initargs for origin and size.
+;;; 4-Jun-1996 I. Kalet change copy-grid-geometry to method for copy.
+;;; 16-Jul-1998 I. Kalet add a default name for grid-geometry object.
+;;; 21-Feb-2000 I. Kalet take out rest pars in copy method.
+;;; 11-Jun-2001 BobGian replace type-specific arithmetic macros with THE
+;;; declarations in X-DIM, Y-DIM, and Z-DIM.
+;;; 15-Mar-2003 BobGian add THE decls - allows TRUNCATE to inline.
+;;; 21-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defclass grid-geometry (generic-prism-object)
+
+ ((x-origin :type single-float
+ :accessor x-origin
+ :initarg :x-origin
+ :documentation "The x-coordinate of the grid's origin.")
+
+ (y-origin :type single-float
+ :accessor y-origin
+ :initarg :y-origin
+ :documentation "The y-coordinate of the grid's origin.")
+
+ (z-origin :type single-float
+ :accessor z-origin
+ :initarg :z-origin
+ :documentation "The z-coordinate of the grid's origin.")
+
+ (x-size :type single-float
+ :reader x-size
+ :initarg :x-size
+ :documentation "The size of the grid in the x direction.")
+
+ (y-size :type single-float
+ :reader y-size
+ :initarg :y-size
+ :documentation "The size of the grid in the y direction.")
+
+ (z-size :type single-float
+ :reader z-size
+ :initarg :z-size
+ :documentation "The size of the grid in the z direction.")
+
+ (voxel-size :type single-float
+ :accessor voxel-size
+ :initarg :voxel-size
+ :documentation "The linear measure (ie: length, width,
+and height) of a single voxel of the specified grid - voxels are always
+regular cubes for now.")
+
+ (display-color :type symbol
+ :accessor display-color
+ :initarg :display-color
+ :documentation "The color of the grid geometry as it
+appears in any views.")
+
+ (new-coords :type ev:event
+ :accessor new-coords
+ :initform (ev:make-event)
+ :documentation "Announced when the origin or size
+changes, but not by code here. It must be announced by code that sets
+these attributes. This is to be able to avoid inefficiency due to
+multiple updates.")
+
+ (new-voxel-size :type ev:event
+ :accessor new-voxel-size
+ :initform (ev:make-event)
+ :documentation "Announced when the voxel-size changes.")
+
+ (new-color :type ev:event
+ :accessor new-color
+ :initform (ev:make-event)
+ :documentation "Announced when the display-color changes.")
+
+ )
+
+ (:default-initargs :x-origin -10.0 :y-origin -10.0 :z-origin -10.0
+ :x-size 20.0 :y-size 20.0 :z-size 20.0
+ :voxel-size *coarse-grid-size*
+ :name "Dose grid"
+ :display-color 'sl:yellow)
+
+ (:documentation "A grid geometry specifies the origin, size, and dimensions
+of a three-dimensional grid of dose samples.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((g grid-geometry))
+
+ (append (call-next-method)
+ '(name new-coords new-voxel-size new-color)))
+
+;;;---------------------------------------------
+
+(defmethod (setf x-size) (val (g grid-geometry))
+
+ (setf (slot-value g 'x-size) (max val *minimum-grid-size*)))
+
+;;;---------------------------------------------
+
+(defmethod (setf y-size) (val (g grid-geometry))
+
+ (setf (slot-value g 'y-size) (max val *minimum-grid-size*)))
+
+;;;---------------------------------------------
+
+(defmethod (setf z-size) (val (g grid-geometry))
+
+ (setf (slot-value g 'z-size) (max val *minimum-grid-size*)))
+
+;;;---------------------------------------------
+
+(defmethod (setf voxel-size) :after (val (g grid-geometry))
+
+ (ev:announce g (new-voxel-size g) val))
+
+;;;---------------------------------------------
+
+(defmethod (setf display-color) :after (val (g grid-geometry))
+
+ (ev:announce g (new-color g) val))
+
+;;;-------------------------------------------------------------
+
+(defmethod x-dim ((g grid-geometry))
+
+ (the fixnum (1+ (the fixnum
+ (truncate (/ (the single-float (x-size g))
+ (the single-float (voxel-size g))))))))
+
+;;;-------------------------------------------------------------
+
+(defmethod y-dim ((g grid-geometry))
+
+ (the fixnum (1+ (the fixnum
+ (truncate (/ (the single-float (y-size g))
+ (the single-float (voxel-size g))))))))
+
+;;;-------------------------------------------------------------
+
+(defmethod z-dim ((g grid-geometry))
+
+ (the fixnum (1+ (the fixnum
+ (truncate (/ (the single-float (z-size g))
+ (the single-float (voxel-size g))))))))
+
+;;;---------------------------------------------
+
+(defun make-grid-geometry (&rest initargs)
+
+ "MAKE-GRID-GEOMETRY &rest initargs
+
+Returns a grid-geometry object with specified parameters."
+
+ (apply #'make-instance 'grid-geometry initargs))
+
+;;;---------------------------------------------
+
+(defmethod copy ((g grid-geometry))
+
+ "Copies and returns a grid-geometry object."
+
+ (declare (ignore pars))
+ (make-grid-geometry :x-origin (x-origin g)
+ :y-origin (y-origin g)
+ :z-origin (z-origin g)
+ :x-size (x-size g)
+ :y-size (y-size g)
+ :z-size (z-size g)
+ :voxel-size (voxel-size g)
+ :display-color (display-color g)))
+
+;;;---------------------------------------------
diff --git a/prism/src/dose-info.cl b/prism/src/dose-info.cl
new file mode 100644
index 0000000..3e4ce80
--- /dev/null
+++ b/prism/src/dose-info.cl
@@ -0,0 +1,592 @@
+;;;
+;;; dose-info
+;;;
+;;; contains class definitions for measured and specified dose data for
+;;; instances of therapy machines, e.g. tissue-phantom ratio data for
+;;; photons and neutrons.
+;;;
+;;; 4-Jan-1996 I. Kalet created
+;;; 29-Jan-1997 I. Kalet add details for wedge data, add table access
+;;; functions, put globals here.
+;;; 1-May-1997 I. Kalet correct error in setup-beamdata
+;;; 7-May-1997 BobGian inserted stub proclamations. Removed 29-Aug-1997.
+;;; 5-Jun-1997 I. Kalet machine returns object, not name
+;;; 28-Aug-1997 BobGian massaging into form compatible with new dose calc.
+;;; Moved setup-beamdata to beam-dose and inlined it streamline code
+;;; and clarify intent. Implementing accessors for new dose calc.
+;;; 03-Sep-1997 BobGian completed and began testing.
+;;; 15-Oct-1997 BobGian implement new wedge-info scheme.
+;;; 20-Oct-1997 BobGian remove cal-depth slot - value used as comment only.
+;;; 25-Oct-1997 BobGian remodel lookup fcns for wedge-info objects.
+;;; 10-Nov-1997 BobGian add "the" declarations for speedup.
+;;; 22-Jan-1998 BobGian update to major revision including direct-mapping
+;;; table lookups, inlining (via macro definition) of interpolation and
+;;; specialized multidimensional array access, and array declarations
+;;; to inline array accesses and avoid flonum boxing. Add new slots
+;;; for mapper-arrays to photon-dose-info class defn.
+;;; 09-Mar-1998 BobGian modest upgrade of dose-calc code.
+;;; 13-Mar-1998 BobGian fix bug (fencepost error) in interpolate-delta.
+;;; Move excess outputfactor-related code to new file: output-factors
+;;; and excess table-lookup code to new file: table-lookups. Move
+;;; wedege-info defclass and slot-type method here from therapy-machines.
+;;; Move function for building mapping tables here (from therapy-machines)
+;;; since it depends upon the slots it initializes.
+;;; 28-Apr-1998 BobGian move BUILD-MAPPER-TABLES from here to
+;;; therapy-machines to resolve dependency conflict.
+;;; 17-Dec-1998 I. Kalet revise electron-dose-info for new data
+;;;organization. Eliminate unnecessary base class.
+;;; 2-Feb-1999 I. Kalet add electron-dose-parameters per Paul Cho's specs.
+;;; 14-Jun-1999 I. Kalet further mods to electron-dose-info.
+;;; 7-Jul-1999 I. Kalet add some interpolation functions for electron data.
+;;; 03-Feb-2000 BobGian update type declarations in electron-dose-info defn
+;;; and add multidimensional interpolation functions for electron dosecalc.
+;;; 02-Mar-2000 BobGian fix doc string for dd-tables in electron-dose-info;
+;;; fix fencepost errors and optimize in interpolation functions for
+;;; electron dose computation (depth-dose-interp, rof-interp,
+;;; ssd/fs-interp, and recursive-assoc).
+;;; 25-Apr-2000 BobGian add slots to photon-dose-info for Irreg.
+;;; 26-Apr-2000 BobGian fix conditionalization on optional Irreg slots.
+;;; Remove hvl and calibration-depth slots for Irreg -- tpr0 always used.
+;;; 05-May-2000 BobGian add :initarg for all Irreg slots so none unbound.
+;;; 30-May-2001 BobGian:
+;;; Wrap generic arithmetic with the-declared types.
+;;; Change type declarations for e0, rp, theta-air, f1, f2, z1, and z2 from
+;;; (simple-array single-float 2) to (simple-array t 2) to reflect their
+;;; true type as created by get-object.
+;;; 13-Jun-2001 Ira Kalet add slots to wedge class that are used by
+;;; DICOM-RT facility, PDR.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 27-Jun-2004 BobGian - remove all irreg-related slots: SOURCE-DIAMETER,
+;;; COLLIMATOR-CONSTANT, COLLIMATOR-TRANSMISSION, SOURCE-TRAY-DISTANCE,
+;;; PSF-TABLE-VECTOR, PSF-RADIUS-MAPPER, PSF-RADII, PSF-TABLE,
+;;; OAF-TABLE-VECTOR, OAF-RADIUS-MAPPER, OAF-RADII, OAF-TABLE.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+;;; Photon External Beam Dose Calculation data and functions.
+
+(defclass photon-dose-info ()
+
+ ((cal-factor :type single-float
+ :initarg :cal-factor
+ :accessor cal-factor
+ :documentation "The absolute calibration in cGy per MU
+at the calibration depth, for a 10 cm square field, usually 1.0")
+
+ (portal-area-coeff :type single-float
+ :initarg :portal-area-coeff
+ :accessor portal-area-coeff
+ :documentation "Coefficient between 0.0 and 1.0
+which determines weight of MLC area component of Output-Factor.")
+
+ (of-min-diam :type single-float
+ :initarg :of-min-diam
+ :accessor of-min-diam
+ :documentation "Parameter giving diameter of circular
+field with Output-Factor which is minumum for MLC integrated component
+when portal area is at least that of this circle.")
+
+ (outputfactor-vector :type (simple-array single-float (3))
+ :accessor outputfactor-vector)
+
+ (outputfactor-fss-mapper :type (simple-array t 1)
+ :accessor outputfactor-fss-mapper)
+
+ (outputfactor-fieldsizes :type (simple-array single-float 1)
+ :accessor outputfactor-fieldsizes
+ :documentation
+ "outputfactor-table 1st-index array.")
+
+ (outputfactor-table :type (simple-array single-float 1)
+ :accessor outputfactor-table
+ :documentation "1-D array of relative Output-Factors.")
+
+ (ocr-table-vector :type (simple-array single-float (9))
+ :accessor ocr-table-vector)
+
+ (ocr-fss-mapper :type (simple-array t 1)
+ :accessor ocr-fss-mapper)
+
+ (ocr-fieldsizes :type (simple-array single-float 1)
+ :accessor ocr-fieldsizes
+ :documentation "OCR-TABLE 1st-index array.")
+
+ (ocr-depth-mapper :type (simple-array t 1)
+ :accessor ocr-depth-mapper)
+
+ (ocr-depths :type (simple-array single-float 1)
+ :accessor ocr-depths
+ :documentation "OCR-TABLE 2nd-index array.")
+
+ (ocr-fanline-mapper :type (simple-array t 1)
+ :accessor ocr-fanline-mapper)
+
+ (ocr-fanlines :type (simple-array single-float 1)
+ :accessor ocr-fanlines
+ :documentation "OCR-TABLE 3rd-index array.")
+
+ (ocr-table :type (simple-array t 1)
+ :accessor ocr-table
+ :documentation "3-D array of OCRs")
+
+ (tpr-table-vector :type (simple-array single-float (6))
+ :accessor tpr-table-vector)
+
+ (tpr-fss-mapper :type (simple-array t 1)
+ :accessor tpr-fss-mapper)
+
+ (tpr-fieldsizes :type (simple-array single-float 1)
+ :accessor tpr-fieldsizes
+ :documentation "TPR-TABLE 1st-index array.")
+
+ (tpr-depth-mapper :type (simple-array t 1)
+ :accessor tpr-depth-mapper)
+
+ (tpr-depths :type (simple-array single-float 1)
+ :accessor tpr-depths
+ :documentation "TPR-TABLE 2nd-index array.")
+
+ (tpr-table :type (simple-array t 1)
+ :accessor tpr-table
+ :documentation "2-D array of TPRs")
+
+ (tpr0-table-vector :type (simple-array single-float (3))
+ :accessor tpr0-table-vector)
+
+ (tpr0-depth-mapper :type (simple-array t 1)
+ :accessor tpr0-depth-mapper)
+
+ (tpr0-depths :type (simple-array single-float 1)
+ :accessor tpr0-depths
+ :documentation "TPR0-TABLE 1st-index array.")
+
+ (tpr0-table :type (simple-array single-float 1)
+ :accessor tpr0-table
+ :documentation "1-D array of zero-field-size TPRs")
+
+ (spr-table-vector :type (simple-array single-float (6))
+ :accessor spr-table-vector)
+
+ (spr-radius-mapper :type (simple-array t 1)
+ :accessor spr-radius-mapper)
+
+ (spr-radii :type (simple-array single-float 1)
+ :accessor spr-radii
+ :documentation "spr-table 1st-index array.")
+
+ (spr-depth-mapper :type (simple-array t 1)
+ :accessor spr-depth-mapper)
+
+ (spr-depths :type (simple-array single-float 1)
+ :accessor spr-depths
+ :documentation "SPR-TABLE 2nd-index array.")
+
+ (spr-table :type (simple-array t 1)
+ :accessor spr-table
+ :documentation "2-D array of SPRs")
+
+ )
+
+ (:documentation "The dose-info class for photon machines.")
+
+ )
+
+;;;=============================================================
+;;; These arrays are all general [type T] as created by GET-OBJECT.
+;;; They were declared "(simple-array single-float 2)" for later optimization,
+;;; but I changed the decls to the types that they really are.
+
+(defclass electron-dose-info ()
+
+ ((airgap :accessor airgap
+ :type single-float
+ :documentation "The air gap in cm for this electron machine,
+independent of energy or cone size.")
+
+ (vsad :type list
+ :accessor vsad
+ :documentation "Virtual SAD, depends only on energy.")
+
+ (applic-sizes :type list
+ :accessor applic-sizes
+ :documentation "The applicator sizes in cm at the
+cutout level, not the cone-sizes, which are the nominal sizes at
+isocenter. Depends only on cone-size.")
+
+ (rp :type (simple-array t 2)
+ :accessor rp
+ :documentation "The practical range in cm. Depends on energy
+and cone size.")
+
+ (e0 :type (simple-array t 2)
+ :accessor e0
+ :documentation "The initial energy of the electron beam in MeV
+in the cutout plane. Depends on energy and cone size.")
+
+ (theta-air :type (simple-array t 2)
+ :accessor theta-air
+ :documentation "The initial angular beam spread in air.
+Depends on energy and cone size.")
+
+ (f1 :type (simple-array t 2)
+ :accessor f1
+ :documentation "Correction factor for the lateral spatial spread
+parameter, FMCS, at depth Z1. Depends on energy and cone size.")
+
+ (f2 :type (simple-array t 2)
+ :accessor f2
+ :documentation "FMCS factor at depth Z2. Depends on energy and
+cone size.")
+
+ (z1 :type (simple-array t 2)
+ :accessor z1
+ :documentation "A shallow depth near the surface. Depends on
+energy and cone size.")
+
+ (z2 :type (simple-array t 2)
+ :accessor z2
+ :documentation "A large depth near the practical range.
+Depends on energy and cone size.")
+
+ (depths :type list
+ :accessor depths
+ :documentation "A list of the maximum depths at which the
+depth dose data are specified, a function only of energy.")
+
+ (ssd :type list
+ :accessor ssd
+ :documentation "List of SSD's at which depth dose is provided.")
+
+ (dd-tables :type list
+ :accessor dd-tables
+ :documentation "An array of depth doses by energy,
+applicator size, nominal SSD and field size. The typical SSD's are
+100.0, 110.0 and 120.0, and the field sizes, specified in cm at isocenter,
+range from some small value up to the applicator size. Starts at 0.1 cm
+depth and does NOT include the value 0.0 for depth zero.")
+
+ (rof-tables :type list
+ :accessor rof-tables
+ :documentation "An array of relative output factors by
+energy, applicator size, nominal SSD and field size.")
+
+ )
+
+ (:documentation "The dose-info class for electron machines.
+Provides detailed parameters and depth dose tables for electrons, as a
+function of energy and applicator size. The available nominal
+energies and cone sizes are specified in the electron-collimator-info
+object in the collimator-info slot of the containing therapy machine.")
+
+ )
+
+;;;=============================================================
+;;; Interpolation functions for Electron dose computation.
+
+(defun depth-dose-interp (pdd-data energy-value aperture-value ssd-value
+ eff-width eff-length)
+
+ "depth-dose-interp pdd-data energy-value aperture-value
+ ssd-value eff-width eff-length
+
+returns an array of dose vs depth (starting at depth 0.0) for the
+specified energy and cone size (as flonums), interpolated from PDD-DATA
+for the specified SSD, field width, and field length. PDD-DATA does NOT
+include the 0.0 stored into the returned array zero-th slot."
+
+ ;; For Percent-Depth-Dose, the value interpolated on SSD and fieldsize
+ ;; is a list of floating-point numbers, each representing PDD values for
+ ;; depths sampled at 0.1 centimeter intervals STARTING AT 0.1 CM.
+ ;; SSD/FS-INTER returns such a list (of variable length), once for
+ ;; each of EFF-WIDTH and EFF-LENGTH. We compute the geometric mean
+ ;; of the values pairwise in these lists and return a depth-dose array
+ ;; of the results. Size of returned array is ONE GREATER THAN length
+ ;; of the smaller of the lists interpolated pairwise, since the 0.0
+ ;; stuffed into slot 0 of the array is NOT stored in the data table.
+
+ (declare (type single-float energy-value aperture-value ssd-value
+ eff-width eff-length))
+
+ (do ((dd-values '())
+ (width-values (ssd/fs-interp pdd-data energy-value aperture-value
+ ssd-value eff-width)
+ (cdr width-values))
+ (length-values (ssd/fs-interp pdd-data energy-value aperture-value
+ ssd-value eff-length)
+ (cdr length-values)))
+ ;; Is it necessary to check both, or will both lists always
+ ;; have same length?
+ ((or (null width-values)
+ (null length-values))
+ ;; Returned array DOES include the explicit 0.0 in slot 0.
+ (make-array (the fixnum (1+ (length dd-values)))
+ :element-type 'single-float
+ :initial-contents (cons 0.0 (nreverse dd-values))))
+
+ (declare (type list dd-values width-values length-values))
+
+ (push (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *)
+ (* (the single-float (car width-values))
+ (the single-float (car length-values))))))
+ dd-values)))
+
+;;;-------------------------------------------------------------
+
+(defun rof-interp (rof-data energy-value aperture-value ssd-value
+ eff-width eff-length)
+
+ "rof-interp rof-data energy-value aperture-value
+ ssd-value eff-width eff-length
+
+returns an ROF for the specified energy and cone size (as flonums),
+interpolated for the specified SSD, field width, and field length."
+
+ ;; For Relative-Output-Factor, the value interpolated on SSD and fieldsize
+ ;; is a single floating-point number. SSD/FS-INTER returns a list of length
+ ;; one containing that value, one for each of EFF-WIDTH and EFF-LENGTH.
+ ;; We return the geometric mean of these two values.
+
+ (declare (type single-float energy-value aperture-value ssd-value
+ eff-width eff-length))
+
+ (cond ((= eff-width eff-length)
+ (car (ssd/fs-interp rof-data energy-value aperture-value
+ ssd-value eff-width)))
+ (t (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *)
+ (* (the single-float
+ (car (ssd/fs-interp rof-data energy-value
+ aperture-value ssd-value
+ eff-width)))
+ (the single-float
+ (car (ssd/fs-interp rof-data energy-value
+ aperture-value ssd-value
+ eff-length))))))))))
+
+;;;-------------------------------------------------------------
+;;; NB: ASSOCs use #'= as tag comparison operation, and values being
+;;; compared are SINGLE-FLOATs. Be sure values written in data files
+;;; are consistent so floating-point comparisons don't go astray.
+
+(defun ssd/fs-interp (nested-alist energy-value aperture-value ssd-value
+ fieldsize &aux sublist1 sublist2 (ssd-frac 0.0))
+
+ "ssd/fs-interp nested-alist energy-value aperture-value
+ ssd-value fieldsize
+
+returns a single-level list representing the values in the nested
+association list NESTED-ALIST extracted on discrete but flonum values
+ENERGY-VALUE and APERTURE-VALUE and interpolated on continuous (flonum)
+values SSD-VALUE and FIELDSIZE."
+
+
+ (declare (type cons nested-alist)
+ (type list sublist1 sublist2)
+ (type single-float energy-value aperture-value ssd-value
+ fieldsize ssd-frac))
+
+ ;; Program and data tables are designed to work for SSD between 100.0 and
+ ;; 120.0, although program accepts SSD down to Electron-SSD-Minlength
+ ;; (= 99.5), extrapolating flat, to allow for slight mis-placement
+ ;; of isocenter.
+ (cond ((<= ssd-value 100.0)
+ (setq sublist1 (cdr (assoc 100.0 nested-alist :test #'=))))
+ ((< ssd-value 110.0)
+ (setq sublist1 (cdr (assoc 100.0 nested-alist :test #'=))
+ sublist2 (cdr (assoc 110.0 nested-alist :test #'=))
+ ssd-frac (* 0.1 (- ssd-value 100.0))))
+ ((= ssd-value 110.0)
+ (setq sublist1 (cdr (assoc 110.0 nested-alist :test #'=))))
+ ((< ssd-value 120.0)
+ (setq sublist1 (cdr (assoc 110.0 nested-alist :test #'=))
+ sublist2 (cdr (assoc 120.0 nested-alist :test #'=))
+ ssd-frac (* 0.1 (- ssd-value 110.0))))
+ (t (setq sublist1 (cdr (assoc 120.0 nested-alist :test #'=)))))
+
+ (setq sublist1 (recursive-assoc energy-value aperture-value
+ fieldsize sublist1))
+
+ (cond ((consp sublist2)
+ (list-interpolate ssd-frac
+ sublist1
+ (recursive-assoc energy-value aperture-value
+ fieldsize sublist2)))
+ (t sublist1)))
+
+;;;-------------------------------------------------------------
+;;; NB: ASSOCs use #'= as tag comparison operation, and values being
+;;; compared are SINGLE-FLOATs. Be sure values written in data files
+;;; are consistent so floating-point comparisons don't go astray.
+
+(defun recursive-assoc (energy-value aperture-value fieldsize sublist)
+
+ "recursive-assoc energy-value aperture-value fieldsize sublist
+
+does a recursive ASSOC lookup in nested ALISTs SUBLIST based on
+discrete but flonum values ENERGY-VALUE and APERTURE-VALUE, then
+does an ASSOC-like continuous lookup on flonum-valued FIELDSIZE,
+interpolating between nearest values if exact match fails, and
+returning edge value if lookup falls off either side. Object
+returned is list of values in CDR of the innermost ALIST."
+
+ (declare (type cons sublist)
+ (type single-float energy-value aperture-value fieldsize))
+
+ (setq sublist (cdr (assoc aperture-value
+ (cdr (assoc energy-value sublist :test #'=))
+ :test #'=)))
+
+ (do ((fs-sublists sublist (cdr fs-sublists))
+ (old-fieldsize-tag 0.0 new-fieldsize-tag)
+ (new-fieldsize-tag 0.0)
+ (old-fs-sublist nil new-fs-sublist)
+ (new-fs-sublist))
+ ((null fs-sublists)
+ ;; Ran off end - FIELDSIZE is larger than largest stored tag -
+ ;; return sublist corresponding to largest stored tag.
+ (cdr old-fs-sublist))
+
+ (declare (type list fs-sublists old-fs-sublist new-fs-sublist)
+ (type single-float old-fieldsize-tag new-fieldsize-tag))
+
+ (setq new-fs-sublist (car fs-sublists)
+ new-fieldsize-tag (car new-fs-sublist))
+
+ (cond
+ ((< fieldsize new-fieldsize-tag)
+ (cond
+ ((eq fs-sublists sublist)
+ ;; FIELDSIZE smaller than smallest tag - return sublist
+ ;; for smallest stored fieldsize value.
+ (return (cdr new-fs-sublist)))
+ ;; FIELDSIZE is between two tags - interpolate.
+ (t (return
+ (list-interpolate (/ (- fieldsize old-fieldsize-tag)
+ (- new-fieldsize-tag old-fieldsize-tag))
+ (cdr old-fs-sublist)
+ (cdr new-fs-sublist))))))
+ ((= fieldsize new-fieldsize-tag)
+ ;; Exact match - return corresponding fieldsize sublist.
+ (return (cdr new-fs-sublist))))))
+
+;;;-------------------------------------------------------------
+
+(defun list-interpolate (fraction sublist1 sublist2)
+
+ "list-interpolate fraction sublist1 sublist2
+
+takes a fraction (between 0.0 and 1.0) and returns a list of values, each
+interpolated that fractional amount between the values which are corresponding
+elements of the lists SUBLIST1 and SUBLIST2. If list inputs differ in length,
+output list contains as many elements as does the shorter input list."
+
+ (declare (type cons sublist1 sublist2)
+ (type (single-float 0.0 1.0) fraction))
+
+ (mapcar #'(lambda (x-val y-val)
+ (declare (type single-float x-val y-val))
+ (+ (* fraction y-val)
+ (* (- 1.0 fraction) x-val)))
+ sublist1
+ sublist2))
+
+;;;=============================================================
+
+(defclass wedge-info ()
+
+ ((name :type string
+ :initarg :name
+ :accessor name
+ :documentation "A unique short string identifying which
+particular wedge this data set describes.")
+
+ (id :initarg :id
+ :accessor id
+ :documentation "A unique id, that is put in the id slot in the
+wedge object to identify which wedge is in use. Wedge id's are
+numbers in many data files, but the numeric value has no significance
+as a number, except that a wedge id of 0 in a beam means no wedge in
+the beam.")
+
+ (accessory-code :initarg :accessory-code
+ :accessor accessory-code
+ :documentation "This is for external wedges that are
+transmitted as elements in a DICOM-RT data transfer.")
+
+ (fitment-code :initarg :fitment-code
+ :accessor fitment-code
+ :documentation "This is for external wedges that are
+transmitted as elements in a DICOM-RT data transfer.")
+
+ (comments :type list
+ :initarg :comments
+ :accessor comments
+ :documentation "A list of strings of comments about the
+current data set. Could be used to note details about changes in the
+data.")
+
+ (rot-angles :type list
+ :initarg :rot-angles
+ :accessor rot-angles
+ :documentation "A list of angles, some subset of 0.0,
+90.0, 180.0, 270.0, each angle a single-float. The angles are valid
+wedge rotation angles for this machine in the prism coordinate
+system.")
+
+ (caf-depth-coef :type single-float
+ :accessor caf-depth-coef
+ :documentation "Coef of Depth term in Alina's formula")
+
+ (caf-fs-coef :type single-float
+ :accessor caf-fs-coef
+ :documentation "Coef of Field-Size term in Alina's formula")
+
+ (caf-constant :type single-float
+ :accessor caf-constant
+ :documentation "Constant term in Alina's formula")
+
+ (profile-table-vector :type (simple-array single-float (6))
+ :accessor profile-table-vector)
+
+ (profile-depth-mapper :type (simple-array t 1)
+ :accessor profile-depth-mapper)
+
+ (profile-depths :type (simple-array single-float 1)
+ :accessor profile-depths
+ :documentation "PROFILE-TABLE 1st-index array.")
+
+ (profile-position-mapper :type (simple-array t 1)
+ :accessor profile-position-mapper)
+
+ (profile-positions :type (simple-array single-float 1)
+ :accessor profile-positions
+ :documentation "PROFILE-TABLE 2nd-index array.")
+
+ (profile-table :type (simple-array t 1)
+ :accessor profile-table
+ :documentation "2-D array of Wedge Profiles as a
+function of Depth and Position but not Field-Size.")
+
+ )
+
+ (:default-initargs :comments nil :rot-angles '(0.0))
+
+ (:documentation "A wedge-info object describes a particular wedge.
+The slots of a wedge object should not be updated by Prism planning
+code but should be updated by a separate machine data management
+program.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defmethod slot-type ((obj wedge-info) slotname)
+
+ (declare (ignore slotname))
+ :simple)
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/dose-result-mediators.cl b/prism/src/dose-result-mediators.cl
new file mode 100644
index 0000000..548ae50
--- /dev/null
+++ b/prism/src/dose-result-mediators.cl
@@ -0,0 +1,342 @@
+;;;
+;;; dose-result-mediators
+;;;
+;;; These mediators maintain consistency between the individual dose
+;;; results of the plan sources, the source monitor units or strength,
+;;; and the plan's summed dose results, both point data and grid data.
+;;;
+;;; 15-Oct-1993 J. Unger created from design report and earlier prototypes.
+;;; 20-Oct-1993 J. Unger add dose-specification-manager.
+;;; 25-Oct-1993 I. Kalet change attrib. name dose-result to result
+;;; 18-Feb-1994 J. Unger add (call-next-method) to dose-view-mediator
+;;; destroy method to get the destroy method of the parent class fired.
+;;; 16-Mar-1994 J. Unger fix bug in update-dose-result when no sources
+;;; left.
+;;; 8-Apr-1994 I. Kalet split off from dose-mediators
+;;; 18-Apr-1994 I. Kalet replace new-origin and new-size with new-coords
+;;; 22-Apr-1994 J. Unger fixup code that handles dose points
+;;; 5-May-1994 J. Unger modify code to handle valid-grid & valid-points
+;;; 1-Jun-1994 J. Unger decouple some updating of grid & points.
+;;; 1-Jun-1994 J. Unger add code to dose-specification-manager to
+;;; handle invalidation of points when appropriate.
+;;; 13-Jun-1994 I. Kalet make destroy a primary method, not :before
+;;; 30-Jun-1994 I. Kalet eliminate brachy references for now.
+;;; 4-Sep-1994 J. Unger add some add-notifies to point invalidation
+;;; 15-Jan-1995 I. Kalet split off dose-view-mediators and
+;;; dose-spec-mediators into separate modules.
+;;; 11-Jun-1996 I. Kalet add brachy support, change summarize to sum.
+;;; 26-Jun-1997 I. Kalet don't check or make new dose array here -
+;;; handled elsewhere, but do make new point dose list each time.
+;;; 22-Jan-1998 BobGian add THE decls to SUM-DOSE-GRID.
+;;; 29-Jan-1998 BobGian rewrite SUMMED-DOSE-POINTS for speed (loop rather
+;;; than MAPCARing closure).
+;;; 9-Mar-1998 BobGian modest upgrade of dose-calc code.
+;;; 3-Feb-2000 BobGian cosmetic fixes (case regularization).
+;;; 7-Feb-2000 I. Kalet add missing initial registration of new weight
+;;; actions for brachy sources.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass dose-result-manager ()
+
+ ((beams ;; :type coll:collection
+ :accessor beams
+ :initarg :beams
+ :documentation "The collection of managed beams. Provided as an
+initialization argument.")
+
+ (line-sources ;; :type coll:collection
+ :accessor line-sources
+ :initarg :line-sources
+ :documentation "The collection of managed line sources.
+Provided as an initialization argument.")
+
+ (seeds ;; :type coll:collection
+ :accessor seeds
+ :initarg :seeds
+ :documentation "The collection of managed seeds. Provided as an
+initialization argument.")
+
+ (result :type dose-result
+ :accessor result
+ :initarg :result
+ :documentation "The plan's dose result object. Provided as
+an initialization argument.")
+
+ )
+
+ (:documentation "The dose result manager maintains the relationship
+between a plan's sources (and those sources' results) and the
+plan's result.")
+
+ )
+
+;;;--------------------------------------
+
+(defun weight (src)
+
+ "weight src
+
+returns the weight appropriate to the source type."
+
+ (if (typep src 'beam) (monitor-units src)
+ (* (activity src) (treat-time src)))) ;; otherwise brachy
+
+;;;--------------------------------------
+
+(defun sum-dose-grid (sources sum-grid)
+
+ "sum-dose-grid sources sum-grid
+
+computes the weighted sum of the grids of the dose results of SOURCES
+and assigns it to SUM-GRID, point by point."
+
+ (declare (type (simple-array single-float 3) sum-grid))
+ (let ((xdim (array-dimension sum-grid 0))
+ (ydim (array-dimension sum-grid 1))
+ (zdim (array-dimension sum-grid 2)))
+ (declare (fixnum xdim ydim zdim))
+ (dotimes (i xdim) ; set all entries of sum-grid to 0.0
+ (declare (fixnum i))
+ (dotimes (j ydim)
+ (declare (fixnum j))
+ (dotimes (k zdim)
+ (declare (fixnum k))
+ (setf (aref sum-grid i j k) 0.0))))
+ (dolist (source sources)
+ (let ((wght (weight source))
+ (src-grid (grid (result source))))
+ (declare (single-float wght)
+ (type (simple-array single-float 3) src-grid))
+ (dotimes (i xdim)
+ (declare (fixnum i))
+ (dotimes (j ydim)
+ (declare (fixnum j))
+ (dotimes (k zdim)
+ (declare (fixnum k))
+ (incf (aref sum-grid i j k)
+ (* wght (aref src-grid i j k))))))))))
+
+;;;--------------------------------------
+
+(defun summed-dose-points (sources)
+
+ "summed-dose-points sources
+
+returns a list of numbers, the weighted sums, point by point, of the
+doses to points, added up for each point from all the individual
+sources."
+
+ ;; add up the doses point by point
+ (apply #'mapcar #'+
+ ;; over a list of lists, one list for each beam
+ (mapcar #'(lambda (src)
+ ;; each list has the weighted doses from a source
+ (let ((wght (weight src)))
+ (declare (single-float wght))
+ (mapcar #'(lambda (dose)
+ (declare (single-float dose))
+ (* dose wght))
+ (points (result src)))))
+ sources)))
+
+;;;--------------------------------------
+
+(defun update-sum-grid (drm &rest ignored)
+
+ "update-sum-grid drm &rest ignored
+
+An action function which updates the dose grid of the dose result
+manager drm's result, in response to the validity of the grids in the
+dose results in drm's collections of sources."
+
+ (declare (ignore ignored))
+ (let* ((sources (append (coll:elements (beams drm))
+ (coll:elements (line-sources drm))
+ (coll:elements (seeds drm))))
+ (all-grids-valid (and sources
+ (every #'valid-grid
+ (mapcar #'result sources)))))
+ (when all-grids-valid
+ (sum-dose-grid sources (grid (result drm))))
+ (setf (valid-grid (result drm)) all-grids-valid)))
+
+;;;--------------------------------------
+
+(defun update-sum-points (drm &rest ignored)
+
+ "update-sum-points drm &rest ignored
+
+An action function which updates the dose points of the dose result
+manager drm's result, in response to the validity of the points in the
+dose results in drm's collections of sources."
+
+ (declare (ignore ignored))
+ (let* ((sources (append (coll:elements (beams drm))
+ (coll:elements (line-sources drm))
+ (coll:elements (seeds drm))))
+ (all-points-valid (and sources
+ (every #'valid-points
+ (mapcar #'result sources)))))
+ (when all-points-valid
+ (setf (points (result drm)) (summed-dose-points sources)))
+ (setf (valid-points (result drm)) all-points-valid)))
+
+;;;--------------------------------------
+
+(defun update-dose-result (drm &rest ignored)
+
+ "update-dose-result drm &rest ignored
+
+Updates drm's dose-result's grid and points."
+
+ (declare (ignore ignored))
+ (update-sum-grid drm)
+ (update-sum-points drm))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((drm dose-result-manager)
+ &rest initargs)
+ (declare (ignore initargs))
+ ;; 1. register with each existing source's dose result's
+ ;; grid-status-changed and update the plan's summary grid in
+ ;; response.
+ ;; 2. register with each existing source's dose result's
+ ;; points-status-changed and update the plan's summary points in
+ ;; response.
+ ;; 3. register with each beam's new-mu event, and line source or
+ ;; seed's new-activity and new-treat-time events to update plan's
+ ;; grid and points.
+ (dolist (b (coll:elements (beams drm)))
+ (ev:add-notify drm (grid-status-changed (result b))
+ #'update-sum-grid)
+ (ev:add-notify drm (points-status-changed (result b))
+ #'update-sum-points)
+ (ev:add-notify drm (new-mu b)
+ #'update-dose-result))
+ (dolist (ls (coll:elements (line-sources drm)))
+ (ev:add-notify drm (grid-status-changed (result ls))
+ #'update-sum-grid)
+ (ev:add-notify drm (points-status-changed (result ls))
+ #'update-sum-points)
+ (ev:add-notify drm (new-activity ls)
+ #'update-dose-result)
+ (ev:add-notify drm (new-treat-time ls)
+ #'update-dose-result))
+ (dolist (sd (coll:elements (seeds drm)))
+ (ev:add-notify drm (grid-status-changed (result sd))
+ #'update-sum-grid)
+ (ev:add-notify drm (points-status-changed (result sd))
+ #'update-sum-points)
+ (ev:add-notify drm (new-activity sd)
+ #'update-dose-result)
+ (ev:add-notify drm (new-treat-time sd)
+ #'update-dose-result))
+ ;; register each new beam with events, also update the plan's dose
+ ;; result's grid & points now, since they might have changed.
+ (ev:add-notify drm (coll:inserted (beams drm))
+ #'(lambda (drm a beam)
+ (ev:add-notify drm (grid-status-changed (result beam))
+ #'update-sum-grid)
+ (ev:add-notify drm (points-status-changed (result beam))
+ #'update-sum-points)
+ (ev:add-notify drm (new-mu beam)
+ #'update-dose-result)
+ (update-dose-result drm a beam)))
+ ;; for a deleted beam, unregister events, update dose grid/pts
+ (ev:add-notify drm (coll:deleted (beams drm))
+ #'(lambda (drm a beam)
+ (ev:remove-notify
+ drm (grid-status-changed (result beam)))
+ (ev:remove-notify
+ drm (points-status-changed (result beam)))
+ (ev:remove-notify drm (new-mu beam))
+ (update-dose-result drm a beam)))
+ ;; ditto for new line sources and seeds...
+ (ev:add-notify drm (coll:inserted (line-sources drm))
+ #'(lambda (drm a ls)
+ (ev:add-notify drm (grid-status-changed (result ls))
+ #'update-sum-grid)
+ (ev:add-notify drm (points-status-changed (result ls))
+ #'update-sum-points)
+ (ev:add-notify drm (new-activity ls)
+ #'update-dose-result)
+ (ev:add-notify drm (new-treat-time ls)
+ #'update-dose-result)
+ (update-dose-result drm a ls)))
+ (ev:add-notify drm (coll:inserted (seeds drm))
+ #'(lambda (drm a sd)
+ (ev:add-notify drm (grid-status-changed (result sd))
+ #'update-sum-grid)
+ (ev:add-notify drm (points-status-changed (result sd))
+ #'update-sum-points)
+ (ev:add-notify drm (new-activity sd)
+ #'update-dose-result)
+ (ev:add-notify drm (new-treat-time sd)
+ #'update-dose-result)
+ (update-dose-result drm a sd)))
+ ;; ditto for deleted line sources and seeds...
+ (ev:add-notify drm (coll:deleted (line-sources drm))
+ #'(lambda (drm a ls)
+ (ev:remove-notify drm (grid-status-changed
+ (result ls)))
+ (ev:remove-notify drm (points-status-changed
+ (result ls)))
+ (ev:remove-notify drm (new-activity ls))
+ (ev:remove-notify drm (new-treat-time ls))
+ (update-dose-result drm a ls)))
+ (ev:add-notify drm (coll:deleted (seeds drm))
+ #'(lambda (drm a sd)
+ (ev:remove-notify drm (grid-status-changed
+ (result sd)))
+ (ev:remove-notify drm (points-status-changed
+ (result sd)))
+ (ev:remove-notify drm (new-activity sd))
+ (ev:remove-notify drm (new-treat-time sd))
+ (update-dose-result drm a sd))))
+
+;;;--------------------------------------
+
+(defmethod destroy ((drm dose-result-manager))
+
+ ;; unregister the beams and beam set...
+ (dolist (beam (coll:elements (beams drm)))
+ (ev:remove-notify drm (grid-status-changed (result beam)))
+ (ev:remove-notify drm (points-status-changed (result beam)))
+ (ev:remove-notify drm (new-mu beam)))
+ (ev:remove-notify drm (coll:inserted (beams drm)))
+ (ev:remove-notify drm (coll:deleted (beams drm)))
+ ;; ditto for line sources...
+ (dolist (ls (coll:elements (line-sources drm)))
+ (ev:remove-notify drm (grid-status-changed (result ls)))
+ (ev:remove-notify drm (points-status-changed (result ls)))
+ (ev:remove-notify drm (new-activity ls))
+ (ev:remove-notify drm (new-treat-time ls)))
+ (ev:remove-notify drm (coll:inserted (line-sources drm)))
+ (ev:remove-notify drm (coll:deleted (line-sources drm)))
+ ;; and seeds
+ (dolist (sd (coll:elements (seeds drm)))
+ (ev:remove-notify drm (grid-status-changed (result sd)))
+ (ev:remove-notify drm (points-status-changed (result sd)))
+ (ev:remove-notify drm (new-activity sd))
+ (ev:remove-notify drm (new-treat-time sd)))
+ (ev:remove-notify drm (coll:inserted (seeds drm)))
+ (ev:remove-notify drm (coll:deleted (seeds drm))))
+
+;;;--------------------------------------
+
+(defun make-dose-result-manager (&rest initargs)
+
+ "make-dose-result-manager &rest initargs
+
+Creates and returns a dose result manager from the supplied
+keyword initialization arguments."
+
+ (apply #'make-instance 'dose-result-manager initargs))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/dose-results.cl b/prism/src/dose-results.cl
new file mode 100644
index 0000000..ce7bd91
--- /dev/null
+++ b/prism/src/dose-results.cl
@@ -0,0 +1,261 @@
+;;;
+;;; dose-results
+;;;
+;;; Definitions of dose results and dose surfaces, for storage and
+;;; display of dose information in Prism.
+;;;
+;;; 11-Oct-1993 J. Unger created from current implementation report.
+;;; 12-Oct-1993 J. Unger make dose surface name reflect theshold.
+;;; 22-Oct-1993 J. Unger modify setf valid after method in dose-result
+;;; object def to improve system efficiency.
+;;; 29-Oct-1993 J. Unger make dose-surface's dose-grid and result not-saved;
+;;; remove default initargs for those slots.
+;;; 18-Feb-1994 D. Nguyen add copy-dose-result.
+;;; 8-Apr-1994 I. Kalet split off from dose-objects
+;;; 5-May-1994 J. Unger split valid attrib into valid-points & valid-grid,
+;;; also split status-changed event into two separate events.
+;;; 15-May-1994 D. Nguyen update copy-dose-result to handle valid-grid and
+;;; valid-points.
+;;; 01-Jun-1994 J. Unger minor adjs to status-changed to bring it to
+;;; spec.
+;;; 13-Jun-1994 I. Kalet take message out of copy-dose-result
+;;; 16-Jun-1994 I. Kalet change color in dose surface to display-color
+;;; 28-Sep-1994 J. Unger add some more initialization args to
+;;; dose-surface
+;;; 31-May-1995 I. Kalet make name a required parameter to
+;;; make-dose-surface, consistent with other object constructors.
+;;; 10-Jun-1996 I. Kalet make copy-dose-result a method for generic
+;;; copy, other fixups also.
+;;; 29-Jan-1997 I. Kalet change name of tpr slot to ca-tpr, to avoid
+;;; name conflict with tpr function in dose-info.
+;;; 3-May-1997 I. Kalet the definition of make-dose-surface was in
+;;; conflict with the Implementation Report - make it conform to the
+;;; report, and fix the copy method. Name was formerly required for
+;;; a selector panel constructor - if it is needed use a lambda.
+;;; 26-Jun-1997 I. Kalet don't init grid slot: can't be right, will be
+;;; initialized in the compute dose action function when necessary.
+;;; 21-Feb-2000 I. Kalet remove rest pars from copy methods.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defclass dose-result (generic-prism-object)
+
+ ((grid :type (simple-array single-float 3)
+ :initarg :grid
+ :accessor grid
+ :documentation "The 3D array of dose values.")
+
+ (points :type list
+ :initarg :points
+ :accessor points
+ :documentation "The list of dose point values.")
+
+ (valid-grid :type (or t nil)
+ :initarg :valid-grid
+ :accessor valid-grid
+ :documentation "The validity of this object's dose
+grid values.")
+
+ (valid-points :type (or t nil)
+ :initarg :valid-points
+ :accessor valid-points
+ :documentation "The validity of this object's point
+dose values.")
+
+ (grid-status-changed :type ev:event
+ :accessor grid-status-changed
+ :initform (ev:make-event)
+ :documentation "Announced when the valid-grid
+attribute changes.")
+
+ (points-status-changed :type ev:event
+ :accessor points-status-changed
+ :initform (ev:make-event)
+ :documentation "Announced when the
+valid-points attribute changes.")
+
+ (ssd :type single-float
+ :initarg :ssd
+ :accessor ssd
+ :documentation "The source to surface distance - only
+applicable to dose results of beams.")
+
+ (tpr-at-iso :type single-float
+ :initarg :tpr-at-iso
+ :accessor tpr-at-iso
+ :documentation "The tissue phantom ratio at isocenter,
+only applicable to dose results of beams.")
+
+ (output-comp :type single-float
+ :initarg :output-comp
+ :accessor output-comp
+ :initform 0.0
+ :documentation "The computed output factor, only
+applicable to dose results of beams.")
+
+ (equiv-square :type single-float
+ :initarg :equiv-square
+ :accessor equiv-square
+ :documentation "The computed equivalent square, only
+applicable to dose results of beams.")
+
+ )
+
+ (:default-initargs :valid-grid nil :valid-points nil
+ :ssd 0.0 :tpr-at-iso 0.0 :output-comp 0.0
+ :equiv-square 0.0)
+
+ (:documentation "A dose result specifies the result of computing
+dose for a field, seed, line source, or for an entire plan's worth of
+sources.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((dr dose-result))
+
+ (append (call-next-method)
+ '(name grid-status-changed points-status-changed)))
+
+;;;---------------------------------------------
+
+(defmethod (setf valid-grid) :around (new-val (dr dose-result))
+
+ (let ((old-val (valid-grid dr)))
+ (call-next-method)
+ (when (or old-val new-val) ;; announce if changed or both t!
+ (ev:announce dr (grid-status-changed dr) new-val))))
+
+;;;---------------------------------------------
+
+(defmethod (setf valid-points) :around (new-val (dr dose-result))
+
+ (let ((old-val (valid-points dr)))
+ (call-next-method)
+ (when (or old-val new-val) ;; announce if changed or both t!
+ (ev:announce dr (points-status-changed dr) new-val))))
+
+;;;---------------------------------------------
+
+(defun make-dose-result (&rest initargs)
+
+ "MAKE-DOSE-RESULT &rest initargs
+
+Returns an empty dose-result object."
+
+ (apply #'make-instance 'dose-result initargs))
+
+;;;---------------------------------------------
+
+(defmethod copy ((dr dose-result))
+
+ "Copies and returns a dose-result object. The actual results are
+not copied, so the valid flags are not copied."
+
+ (declare (ignore pars))
+ (apply #'make-dose-result
+ (if (slot-boundp dr 'grid)
+ (list :grid (make-array (array-dimensions (grid dr))
+ :element-type 'single-float
+ :initial-element 0.0))
+ nil)))
+
+;;;---------------------------------------------
+;;; dose surfaces are the isodose level specs.
+;;;---------------------------------------------
+
+(defclass dose-surface (generic-prism-object)
+
+ ((threshold :type single-float
+ :initarg :threshold
+ :accessor threshold
+ :documentation "The threshold value for this surface.")
+
+ (new-threshold :type ev:event
+ :accessor new-threshold
+ :initform (ev:make-event)
+ :documentation "Announced when dose surface threshold
+changes.")
+
+ (display-color :type symbol
+ :accessor display-color
+ :initarg :display-color
+ :documentation "A symbol representing the color of
+this isodose surface.")
+
+ (new-color :type ev:event
+ :accessor new-color
+ :initform (ev:make-event)
+ :documentation "Announced when dose surface color changes.")
+
+ (dose-grid :type grid-geometry
+ :accessor dose-grid
+ :initarg :dose-grid
+ :documentation "A grid-geometry object from which the origin,
+size, and dimensions of the result's dose-array can be obtained.")
+
+ (result :type dose-result
+ :accessor result
+ :initarg :result
+ :documentation "The dose-result object in which this surface is
+embedded.")
+
+ )
+
+ (:default-initargs :threshold 100.0 :display-color 'sl:white)
+
+ (:documentation "Dose surfaces are embedded in 3D dose matrices and are
+drawn into views."))
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((object dose-surface))
+
+ (append (call-next-method)
+ '(name new-threshold new-color dose-grid result)))
+
+;;;---------------------------------------------
+
+(defmethod (setf threshold) :after (thresh (ds dose-surface))
+
+ (setf (name ds) (write-to-string thresh))
+ (ev:announce ds (new-threshold ds) thresh))
+
+;;;---------------------------------------------
+
+(defmethod (setf display-color) :after (col (ds dose-surface))
+
+ (ev:announce ds (new-color ds) col))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((ds dose-surface) &rest initargs)
+
+ (declare (ignore initargs))
+ (setf (name ds) (write-to-string (threshold ds))))
+
+;;;---------------------------------------------
+
+(defun make-dose-surface (&rest initargs)
+
+ "MAKE-DOSE-SURFACE &rest initargs
+
+Returns a dose surface object with specified parameters."
+
+ (apply #'make-instance 'dose-surface initargs))
+
+;;;---------------------------------------------
+
+(defmethod copy ((ds dose-surface))
+
+ "Copies and returns a dose-surface object."
+
+ (declare (ignore pars))
+ (make-dose-surface :threshold (threshold ds)
+ :display-color (display-color ds)))
+
+;;;---------------------------------------------
diff --git a/prism/src/dose-spec-mediators.cl b/prism/src/dose-spec-mediators.cl
new file mode 100644
index 0000000..28156e2
--- /dev/null
+++ b/prism/src/dose-spec-mediators.cl
@@ -0,0 +1,190 @@
+;;;
+;;; dose-spec-mediators
+;;;
+;;; maintain the relations between inputs to the dose computation
+;;; model and the validity of the dose results, invalidating the
+;;; latter when the former change.
+;;;
+;;; 15-Jan-1995 I. Kalet split off from dose-result-mediators.
+;;; 9-Jun-1996 I. Kalet add brachy support, clean up a little.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass dose-specification-manager ()
+
+ ((organs ;; :type coll:collection
+ :accessor organs
+ :initarg :organs
+ :documentation "A collection of organs, normally supplied
+from the patient at initialization.")
+
+ (grid :type grid-geometry
+ :accessor grid
+ :initarg :grid
+ :documentation "A dose grid, normally supplied from the
+plan at initialization.")
+
+ (beams ;; :type coll:collection
+ :accessor beams
+ :initarg :beams
+ :documentation "A collection of beams, normally supplied
+from the plan at initialization.")
+
+ (seeds ;; :type coll:collection
+ :accessor seeds
+ :initarg :seeds
+ :documentation "A collection of seeds, normally supplied
+from the plan at initialization.")
+
+ (line-sources ;; :type coll:collection
+ :accessor line-sources
+ :initarg :line-sources
+ :documentation "A collection of line sources, normally
+supplied from the plan at initialization.")
+
+ (points ;; :type coll:collection
+ :accessor points
+ :initarg :points
+ :documentation "A collection of points, normally from the
+plan's patient at initialization.")
+
+ )
+
+ (:documentation "This mediator ensures that the the dose results for
+radiation sources are invalidated when an event warranting invalidation,
+e.g. addition of a new organ contour, occurs.")
+
+ )
+
+;;;--------------------------------------
+
+(defun invalidate-dose-points (dsm &rest other-args)
+
+ "INVALIDATE-DOSE-POINTS dsm &rest other-args
+
+An action function which invalidates the points in the dose results of
+all the beams, seeds, and line sources contained in the
+dose-specification manager dsm."
+
+ (declare (ignore other-args))
+ (dolist (src (coll:elements (beams dsm)))
+ (setf (valid-points (result src)) nil))
+ (dolist (src (coll:elements (line-sources dsm)))
+ (setf (valid-points (result src)) nil))
+ (dolist (src (coll:elements (seeds dsm)))
+ (setf (valid-points (result src)) nil)))
+
+;;;--------------------------------------
+
+(defun invalidate-dose-grid (dsm &rest other-args)
+
+ "INVALIDATE-DOSE-GRID dsm &rest other-args
+
+An action function which invalidates the grid in the dose results of
+all the beams, seeds, and line sources contained in the dose-specification
+manager dsm."
+
+ (declare (ignore other-args))
+ (dolist (src (coll:elements (beams dsm)))
+ (setf (valid-grid (result src)) nil))
+ (dolist (src (coll:elements (line-sources dsm)))
+ (setf (valid-grid (result src)) nil))
+ (dolist (src (coll:elements (seeds dsm)))
+ (setf (valid-grid (result src)) nil)))
+
+;;;--------------------------------------
+
+(defun invalidate-dose (dsm &rest other-args)
+
+ "INVALIDATE-DOSE dsm &rest other-args
+
+An action function which invalidates the dose results of all the
+beams, seeds, and line sources contained in the dose-specification manager
+dsm."
+
+ (apply #'invalidate-dose-grid dsm other-args)
+ (apply #'invalidate-dose-points dsm other-args))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((dsm dose-specification-manager)
+ &rest initargs)
+
+ (declare (ignore initargs))
+
+ ;; changes in organ density, contours, insertion of new organs, and
+ ;; deletion of old ones all invalidate everything
+ (dolist (organ (coll:elements (organs dsm)))
+ (ev:add-notify dsm (new-density organ) #'invalidate-dose)
+ (ev:add-notify dsm (new-contours organ) #'invalidate-dose))
+ (ev:add-notify dsm (coll:inserted (organs dsm))
+ #'(lambda (dm a organ)
+ (ev:add-notify dm (new-density organ)
+ #'invalidate-dose)
+ (ev:add-notify dm (new-contours organ)
+ #'invalidate-dose)
+ (invalidate-dose dm a organ)))
+ (ev:add-notify dsm (coll:deleted (organs dsm))
+ #'(lambda (dm a organ)
+ (ev:remove-notify dm (new-density organ))
+ (ev:remove-notify dm (new-contours organ))
+ (invalidate-dose dm a organ)))
+
+ ;; changing the dose grid invalidates the grid data in the dose
+ ;; results of all sources
+ (ev:add-notify dsm (new-coords (grid dsm)) #'invalidate-dose-grid)
+ (ev:add-notify dsm (new-voxel-size (grid dsm)) #'invalidate-dose-grid)
+
+ ;; moving a point invalidates all the points in all the sources -
+ ;; similarly adding or deleting a point.
+ ;; not strictly necessary but simpler and not costly.
+ (dolist (pt (coll:elements (points dsm)))
+ (ev:add-notify dsm (new-loc pt) #'invalidate-dose-points))
+ (ev:add-notify dsm (coll:inserted (points dsm))
+ #'(lambda (dm a pt)
+ (ev:add-notify dm (new-loc pt)
+ #'invalidate-dose-points)
+ (invalidate-dose-points dm a pt)))
+ (ev:add-notify dsm (coll:deleted (points dsm))
+ #'(lambda (dm a pt)
+ (ev:remove-notify dm (new-loc pt))
+ (invalidate-dose-points dm a pt)))
+ )
+
+;;;--------------------------------------
+
+(defmethod destroy ((dsm dose-specification-manager))
+
+ (dolist (organ (coll:elements (organs dsm)))
+ (ev:remove-notify dsm (new-density organ))
+ (ev:remove-notify dsm (new-contours organ)))
+
+ (ev:remove-notify dsm (coll:inserted (organs dsm)))
+ (ev:remove-notify dsm (coll:deleted (organs dsm)))
+
+ (ev:remove-notify dsm (new-coords (grid dsm)))
+ (ev:remove-notify dsm (new-voxel-size (grid dsm)))
+
+ (dolist (pt (coll:elements (points dsm)))
+ (ev:remove-notify dsm (new-loc pt)))
+
+ (ev:remove-notify dsm (coll:inserted (points dsm)))
+ (ev:remove-notify dsm (coll:deleted (points dsm)))
+
+ )
+
+;;;--------------------------------------
+
+(defun make-dose-specification-manager (&rest initargs)
+
+ "MAKE-DOSE-SPECIFICATION-MANAGER &rest initargs
+
+Creates and returns an organ dose manager from the supplied keyword
+initialization arguments."
+
+ (apply #'make-instance 'dose-specification-manager initargs))
+
+;;;--------------------------------------
diff --git a/prism/src/dose-surface-graphics.cl b/prism/src/dose-surface-graphics.cl
new file mode 100644
index 0000000..eafa613
--- /dev/null
+++ b/prism/src/dose-surface-graphics.cl
@@ -0,0 +1,350 @@
+;;;
+;;; dose-surface-graphics
+;;;
+;;; Draw methods for dose-surfaces into views.
+;;;
+;;; 18-Oct-1993 J. Unger create from earlier prototype.
+;;; 22-Oct-1993 J. Unger fix bug in coronal view dose extraction view.
+;;; 03-Dec-1993 J. Unger fix bug in draw method for dose surfaces.
+;;; 9-Feb-1994 J. Unger modify parameter list of extract-dose-slice
+;;; and calls so it can be used elsewhere.
+;;; 8-Apr-1994 I. Kalet split off from dose-graphics
+;;; 18-Apr-1994 I. Kalet updated refs to view origin
+;;; 5-May-1994 J. Unger changed 'valid' to 'valid-grid'
+;;; 16-Jun-1994 I. Kalet changed color in dose surface to display-color
+;;; 14-Jul-1994 J. Unger change (or t nil) to (member t nil).
+;;; 28-Jul-1994 J. Unger fix bug(s) in update-dose-caches methods.
+;;; 31-Aug-1995 I. Kalet change defparameter to defvar for caches.
+;;; 19-Sep-1996 I. Kalet remove &rest from draw methods.
+;;; 6-Dec-1996 I. Kalet don't generate prims if color is invisible
+;;; 13-May-1998 I. Kalet move max-plane-dose here from plots, also
+;;; some minor cleanup.
+;;; 21-Apr-1999 I. Kalet change sl:invisible to 'sl:invisible.
+;;; 25-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 22-Oct-2002 I. Kalet add stubs for oblique view and room view.
+;;; 25-May-2009 I. Kalet remove stub for room view.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defvar *x-dose-unmarked-array*
+ (make-array '(10 10) :element-type '(member t nil))
+ "The unmarked array used for sagittal view isodose contour extraction.")
+
+(defvar *y-dose-unmarked-array*
+ (make-array '(10 10) :element-type '(member t nil))
+ "The unmarked array used for coronal view isodose contour extraction.")
+
+(defvar *z-dose-unmarked-array*
+ (make-array '(10 10) :element-type '(member t nil))
+ "The unmarked array used for transverse view isodose contour extraction.")
+
+(defvar *oblique-dose-unmarked-array*
+ (make-array '(10 10) :element-type '(member t nil))
+ "The unmarked array used for oblique view isodose contour extraction.")
+
+(defvar *x-dose-slice-array*
+ (make-array '(10 10) :element-type 'single-float)
+ "A 2D slice of the 3D dose grid in the sagittal direction.")
+
+(defvar *y-dose-slice-array*
+ (make-array '(10 10) :element-type 'single-float)
+ "A 2D slice of the 3D dose grid in the coronal direction.")
+
+(defvar *z-dose-slice-array*
+ (make-array '(10 10) :element-type 'single-float)
+ "A 2D slice of the 3D dose grid in the transverse direction.")
+
+(defvar *oblique-dose-slice-array*
+ (make-array '(10 10) :element-type 'single-float)
+ "A 2D slice of the 3D dose grid in an oblique direction.")
+
+;;;---------------------------------------------
+
+(defmethod extract-dose-slice (dg dr (v transverse-view) &key slice)
+
+ "Extracts slice, a 2D array of single-floats, from the dose array
+within dose result dr. The plane removed from dr's dose array
+corresponds to the intersection of the transverse-view v's plane with
+the supplied dose grid dg (a grid geometry) in patient space. Slice
+is a keyword and is optional - if supplied, then that array will be
+filled with the resulting slice information. Otherwise, a new array
+will be allocated. Multiple values are returned -- in order,
+
+ in-bounds slice x-orig y-orig x-size y-size
+
+ where in-bounds is t if the view intersected the grid and nil otherwise,
+ slice is the 2D array of float values extracted from a grid plane
+ x-orig is the x origin of the slice in patient space
+ y-orig is the y origin of the slice in patient space
+ x-size is the x size of the plane
+ y-size is the y size of the plane
+
+If in-bounds is nil, all other values retured are undefined.
+
+The slice array is obtained through linear interpolation between the two
+nearest grid planes."
+
+ (let* ((pos (view-position v))
+ (index (float (/ (* (- pos (z-origin dg))
+ (1- (z-dim dg)))
+ (z-size dg))))
+ (l-ind (floor index))
+ (h-ind (1+ l-ind))
+ (l-fac (- h-ind index))
+ (h-fac (- 1 l-fac))
+ (x-dim (x-dim dg))
+ (y-dim (y-dim dg))
+ (dm (grid dr)))
+ (unless slice
+ (setf slice (make-array (list x-dim y-dim)
+ :element-type 'single-float)))
+ (when (= index (1- (z-dim dg))
+ (decf h-ind)))
+ (when (<= 0.0 index (1- (z-dim dg)))
+ (dotimes (i x-dim)
+ (dotimes (j y-dim)
+ (setf (aref slice i j)
+ (+ (* l-fac (aref dm i j l-ind))
+ (* h-fac (aref dm i j h-ind))))))
+ (values
+ t slice (x-origin dg) (y-origin dg)
+ (x-size dg) (y-size dg)))))
+
+;;;---------------------------------------------
+
+(defmethod extract-dose-slice (dg dr (v coronal-view) &key slice)
+
+ "Extracts slice (a 2D dose array) from the matrix within dr,
+according to how the plane of the coronal view v intersects the
+supplied grid geometry dg in patient space."
+
+ (let* ((pos (view-position v))
+ (index (float (/ (* (- pos (y-origin dg))
+ (1- (y-dim dg)))
+ (y-size dg))))
+ (l-ind (floor index))
+ (h-ind (1+ l-ind))
+ (l-fac (- h-ind index))
+ (h-fac (- 1 l-fac))
+ (x-dim (x-dim dg))
+ (y-dim (z-dim dg))
+ (dm (grid dr)))
+ (unless slice
+ (setf slice (make-array (list x-dim y-dim)
+ :element-type 'single-float)))
+ (when (= index (1- (y-dim dg)) (decf h-ind)))
+ (when (<= 0.0 index (1- (y-dim dg)))
+ (dotimes (i x-dim)
+ (dotimes (j y-dim)
+ (setf (aref slice i (- y-dim j 1))
+ (+ (* l-fac (aref dm i l-ind j))
+ (* h-fac (aref dm i h-ind j))))))
+ (values
+ t slice (x-origin dg) (- (+ (z-origin dg) (z-size dg)))
+ (x-size dg) (z-size dg)))))
+
+;;;---------------------------------------------
+
+(defmethod extract-dose-slice (dg dr (v sagittal-view) &key slice)
+
+ "Extracts slice (a 2D dose array) from the matrix within dr,
+according to how the plane of the sagittal view v intersects the
+supplied grid geometry dg in patient space."
+
+ (let* ((pos (view-position v))
+ (index (float (/ (* (- pos (x-origin dg))
+ (1- (x-dim dg)))
+ (x-size dg))))
+ (l-ind (floor index))
+ (h-ind (1+ l-ind))
+ (l-fac (- h-ind index))
+ (h-fac (- 1 l-fac))
+ (x-dim (z-dim dg))
+ (y-dim (y-dim dg))
+ (dm (grid dr)))
+ (unless slice
+ (setf slice (make-array (list x-dim y-dim)
+ :element-type 'single-float)))
+ (when (= index (1- (x-dim dg)) (decf h-ind)))
+ (when (<= 0.0 index (1- (x-dim dg)))
+ (dotimes (i x-dim)
+ (dotimes (j y-dim)
+ (setf (aref slice i j)
+ (+ (* l-fac (aref dm l-ind j i))
+ (* h-fac (aref dm h-ind j i))))))
+ (values
+ t slice (z-origin dg) (y-origin dg)
+ (z-size dg) (y-size dg)))))
+
+;;;---------------------------------------------
+
+(defmethod extract-dose-slice (dg dr (v oblique-view) &key slice)
+
+ "Stub method for now."
+
+ (declare (ignore dg dr slice))
+ nil)
+
+;;;---------------------------------------------
+
+(defmethod extract-dose-slice (dg dr (v beams-eye-view) &key slice)
+
+ "Currently, dose planes are not extracted from beam's eye views, so
+this method simply returns nil."
+
+ (declare (ignore dg dr slice))
+ nil)
+
+;;;---------------------------------------------
+
+(defun max-plane-dose (v grid result)
+
+ "max-plane-dose v grid result
+
+Computes the maximum dose in the plane of view v of given dose result
+object and dose grid object. If the dose result is invalid, or if the
+plane of the view does not intersect the volume of space specified by
+the dose grid, or if the view is a beam's eye view, 0 is returned."
+
+ ;; Currently, the slice cache specified in the argument list to
+ ;; extract-dose-slice is not being preallocated or reused. If v is
+ ;; a beam's eye view, extract-dose-slice will return nil.
+ (let* ((in-bounds nil)
+ (slice nil)
+ (max 0))
+ (when (valid-grid result)
+ (multiple-value-setq
+ (in-bounds slice) (extract-dose-slice grid result v)))
+ (when in-bounds
+ (dotimes (i (array-dimension slice 0))
+ (dotimes (j (array-dimension slice 1))
+ (when (< max (aref slice i j))
+ (setq max (aref slice i j))))))
+ (round max)))
+
+;;;---------------------------------------------
+
+(defmethod update-dose-caches ((v transverse-view) arr)
+
+ "Checks the dimensions of the dose array arr and ensures that the
+appropriate *dose-slice-array* and *dose-unmarked-array* have the same
+dimensions; if not, new cache arrays are allocated."
+
+ (let ((x-dim (array-dimension arr 0))
+ (y-dim (array-dimension arr 1)))
+ (unless (and (= x-dim (array-dimension *z-dose-slice-array* 0))
+ (= y-dim (array-dimension *z-dose-slice-array* 1)))
+ (setq *z-dose-slice-array*
+ (make-array (list x-dim y-dim) :element-type 'single-float)))
+ (unless (and (= x-dim (array-dimension *z-dose-unmarked-array* 0))
+ (= y-dim (array-dimension *z-dose-unmarked-array* 1)))
+ (setq *z-dose-unmarked-array*
+ (make-array (list x-dim y-dim) :element-type '(member t nil))))
+ (values *z-dose-slice-array* *z-dose-unmarked-array*)))
+
+;;;---------------------------------------------
+
+(defmethod update-dose-caches ((v coronal-view) arr)
+
+ "Checks the dimensions of the dose array arr and ensures that the
+appropriate *dose-slice-array* and *dose-unmarked-array* have the same
+dimensions; if not, new cache arrays are allocated."
+
+ (let ((x-dim (array-dimension arr 0))
+ (z-dim (array-dimension arr 2)))
+ (unless (and (= x-dim (array-dimension *y-dose-slice-array* 0))
+ (= z-dim (array-dimension *y-dose-slice-array* 1)))
+ (setq *y-dose-slice-array*
+ (make-array (list x-dim z-dim) :element-type 'single-float)))
+ (unless (and (= x-dim (array-dimension *y-dose-unmarked-array* 0))
+ (= z-dim (array-dimension *y-dose-unmarked-array* 1)))
+ (setq *y-dose-unmarked-array*
+ (make-array (list x-dim z-dim) :element-type '(member t nil))))
+ (values *y-dose-slice-array* *y-dose-unmarked-array*)))
+
+;;;---------------------------------------------
+
+(defmethod update-dose-caches ((v sagittal-view) arr)
+
+ "Checks the dimensions of the dose array arr and ensures that the
+appropriate *dose-slice-array* and *dose-unmarked-array* have the same
+dimensions; if not, new cache arrays are allocated."
+
+ (let ((y-dim (array-dimension arr 1))
+ (z-dim (array-dimension arr 2)))
+ (unless (and (= z-dim (array-dimension *x-dose-slice-array* 0))
+ (= y-dim (array-dimension *x-dose-slice-array* 1)))
+ (setq *x-dose-slice-array*
+ (make-array (list z-dim y-dim) :element-type 'single-float)))
+ (unless (and (= z-dim (array-dimension *x-dose-unmarked-array* 0))
+ (= y-dim (array-dimension *x-dose-unmarked-array* 1)))
+ (setq *x-dose-unmarked-array*
+ (make-array (list z-dim y-dim) :element-type '(member t nil))))
+ (values *x-dose-slice-array* *x-dose-unmarked-array*)))
+
+;;;---------------------------------------------
+
+(defmethod update-dose-caches ((v oblique-view) arr)
+
+ "Stub method for now."
+
+ (declare (ignore arr))
+ nil)
+
+;;;---------------------------------------------
+
+(defmethod update-dose-caches ((v beams-eye-view) arr)
+
+ "Currently, no isodose curves are displayed in beam's eye views, so
+this method simply returns nil."
+
+ (declare (ignore arr))
+ nil)
+
+;;;---------------------------------------------
+
+(defmethod draw ((ds dose-surface) (v view))
+
+ "This method draws the isodose surface into a view."
+
+ (if (eql (display-color ds) 'sl:invisible)
+ (setf (foreground v) (remove ds (foreground v) :key #'object))
+ (let ((prim (find ds (foreground v) :key #'object))
+ (color (sl:color-gc (display-color ds))))
+ (unless prim
+ (setq prim (make-lines-prim nil color :object ds))
+ (push prim (foreground v)))
+ (setf (color prim) color
+ (points prim) nil)
+ (when (valid-grid (result ds))
+ (let ((slice-cache nil)
+ (unmarked-cache nil)
+ (in-bounds nil)
+ (slice nil)
+ (curves nil)
+ (x-orig 0.0)
+ (y-orig 0.0)
+ (x-size 0.0)
+ (y-size 0.0))
+ (multiple-value-setq
+ (slice-cache unmarked-cache)
+ (update-dose-caches v (grid (result ds))))
+ (multiple-value-setq
+ (in-bounds slice x-orig y-orig x-size y-size)
+ (extract-dose-slice
+ (dose-grid ds) (result ds) v :slice slice-cache))
+ (when in-bounds
+ (setq curves
+ (get-isodose-curves
+ slice x-size y-size x-orig y-orig (threshold ds)
+ :unmarked unmarked-cache :complete t)))
+ (dolist (curve curves)
+ (push
+ (pixel-contour curve (scale v) (x-origin v) (y-origin v))
+ (points prim))))))))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/dose-surface-panels.cl b/prism/src/dose-surface-panels.cl
new file mode 100644
index 0000000..5202df0
--- /dev/null
+++ b/prism/src/dose-surface-panels.cl
@@ -0,0 +1,127 @@
+;;;
+;;; dose-surface-panels
+;;;
+;;; Implements the dose-surface-panel with the dose surface controls
+;;;
+;;; 9-Jun-1997 I. Kalet recreated for revised plan panel.
+;;; 18-Jun-2000 I. Kalet make sliderbox initial upper limit adapt to
+;;; max dose in dose array.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defclass dose-surface-panel (generic-panel)
+
+ ((fr :type sl:frame
+ :accessor fr
+ :documentation "The SLIK frame that contains the dose surface
+panel.")
+
+ (dose-surface :type dose-surface
+ :accessor dose-surface
+ :initarg :dose-surface
+ :documentation "The dose surface for this panel.")
+
+ (del-pnl-btn :accessor del-pnl-btn
+ :documentation "The delete panel button for this panel.")
+
+ (thresh-sbox :accessor thresh-sbox
+ :documentation "The sliderbox for modifying the dose
+surface's threshold value.")
+
+ (color-btn :accessor color-btn
+ :documentation "The button for selecting the dose
+surface color.")
+
+ )
+
+ (:documentation "The dose surface panel controls a single dose
+surface, and in this incarnation it has a sliderbox as well as a color
+button.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((dsp dose-surface-panel)
+ &rest initargs)
+
+ "Initializes the user interface for the dose surface panel."
+
+ (let* ((frm (apply #'sl:make-frame 300 130
+ :title "Prism DOSE SURFACE Panel" initargs))
+ (frm-win (sl:window frm))
+ (max (if (valid-grid (result (dose-surface dsp)))
+ (let ((max-dose -1.0)
+ (dose-arr (grid (result (dose-surface dsp)))))
+ (dotimes (i (array-dimension dose-arr 0))
+ (dotimes (j (array-dimension dose-arr 1))
+ (dotimes (k (array-dimension dose-arr 2))
+ (when (< max-dose (aref dose-arr i j k))
+ (setq max-dose (aref dose-arr i j k))))))
+ (coerce (round (+ max-dose 100.0)) 'single-float))))
+ (del-pnl-b (apply #'sl:make-button 130 30
+ :parent frm-win
+ :ulc-x 10 :ulc-y 10
+ :label "Del Panel"
+ :button-type :momentary
+ initargs))
+ (color-b (apply #'sl:make-button 130 30
+ :parent frm-win
+ :ulc-x 160 :ulc-y 10
+ :label "Surface color"
+ :button-type :momentary
+ initargs))
+ (thresh-sb (apply #'sl:make-adjustable-sliderbox
+ 270 30 0.0 (or max 9999.9) 99999.9
+ :parent frm-win
+ :setting (threshold (dose-surface dsp))
+ :ulc-x 10 :ulc-y 50
+ initargs)))
+ (setf (fr dsp) frm
+ (del-pnl-btn dsp) del-pnl-b
+ (thresh-sbox dsp) thresh-sb
+ (color-btn dsp) color-b)
+ (setf (sl:fg-color color-b) (display-color (dose-surface dsp)))
+ (ev:add-notify dsp (sl:button-on del-pnl-b)
+ #'(lambda (dsp a)
+ (declare (ignore a))
+ (destroy dsp)))
+ (ev:add-notify dsp (sl:value-changed thresh-sb)
+ #'(lambda (dsp bx new-val)
+ (declare (ignore bx))
+ (setf (threshold (dose-surface dsp)) new-val)))
+ (ev:add-notify dsp (sl:button-on color-b)
+ #'(lambda (dsp bt)
+ (let ((new-col (sl:popup-color-menu)))
+ (when new-col
+ (setf (display-color (dose-surface dsp)) new-col)
+ (setf (sl:fg-color bt) new-col)))
+ (setf (sl:on bt) nil)))))
+
+;;;---------------------------------------------
+
+(defun make-dose-surface-panel (ds &rest initargs)
+
+ "make-dose-surface-panel ds &rest initargs
+
+Creates and returns a dose-surface panel for dose surface ds."
+
+ (apply #'make-instance 'dose-surface-panel
+ :dose-surface ds initargs))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((dsp dose-surface-panel))
+
+ "Releases X resources used by this panel and its children."
+
+ (sl:destroy (del-pnl-btn dsp))
+ (sl:destroy (color-btn dsp))
+ (sl:destroy (thresh-sbox dsp))
+ (sl:destroy (fr dsp)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/dose-view-mediators.cl b/prism/src/dose-view-mediators.cl
new file mode 100644
index 0000000..490b8e7
--- /dev/null
+++ b/prism/src/dose-view-mediators.cl
@@ -0,0 +1,52 @@
+;;;
+;;; dose-view-mediators
+;;;
+;;; maintain the relations between dose surfaces and views.
+;;;
+;;; 15-Jan-1995 I. Kalet split off from dose-result-mediators
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass dose-view-mediator (object-view-mediator)
+
+ ()
+
+ (:documentation "This mediator connects a dose-surface with a view.")
+ )
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((dvm dose-view-mediator)
+ &rest initargs)
+ (declare (ignore initargs))
+
+ (let ((ds (object dvm)))
+ (ev:add-notify dvm (new-threshold ds) #'update-view)
+ (ev:add-notify dvm (new-color ds) #'update-view)
+ (ev:add-notify dvm (grid-status-changed (result ds)) #'update-view)
+ ))
+
+;;;--------------------------------------
+
+(defmethod destroy ((dvm dose-view-mediator))
+
+ (ev:remove-notify dvm (new-threshold (object dvm)))
+ (ev:remove-notify dvm (new-color (object dvm)))
+ (ev:remove-notify dvm (grid-status-changed (result (object dvm))))
+ (call-next-method))
+
+;;;--------------------------------------
+
+(defun make-dose-view-mediator (ds v)
+
+ "MAKE-DOSE-VIEW-MEDIATOR ds v
+
+Creates and returns a dose-view-mediator between dose-surface ds and
+view v."
+
+ (make-instance 'dose-view-mediator :object ds :view v))
+
+;;;--------------------------------------
diff --git a/prism/src/dosecomp-decls.cl b/prism/src/dosecomp-decls.cl
new file mode 100644
index 0000000..ed6c05a
--- /dev/null
+++ b/prism/src/dosecomp-decls.cl
@@ -0,0 +1,362 @@
+;;;
+;;; dosecomp-decls
+;;;
+;;; Contains declarations for constants and macros used in dose
+;;; computation whose usages are spread across multiple files.
+;;;
+;;; 22-May-1998 BobGian created.
+;;; 03-Feb-2000 BobGian add ERF-TABLE-SIZE (for electron dosecalc); rename
+;;; vars in MYSIN and MYATAN to be distinct from names used elsewhere;
+;;; cosmetics (case regularization).
+;;; 08-Feb-2000 BobGian correct comment in MYATAN, more cosmetic cleanup.
+;;; 02-Mar-2000, 11-May-2000 BobGian add declarations to MYSIN, MYATAN.
+;;; 02-Nov-2000 BobGian MYSIN -> FAST-SIN, MYATAN -> FAST-ATAN.
+;;; 30-May-2001 BobGian move most DEFCONSTANTs, DEFSTRUCTs, and DEFMACROs
+;;; from dose calculation files to this file.
+;;; 11-Jun-2001 BobGian replace type-specific arithmetic macros
+;;; with THE declarations.
+;;; 15-Mar-2002 BobGian add parameterized constants for PATHLENGTH
+;;; and electron dosecalc.
+;;; 03-Jan-2003 BobGian:
+;;; Modify constants naming slots in Arg-Vector:
+;;; Argv-Return -> Argv-Return-0 and Argv-Return-1 so PATHLENGTH-INTEGRATE
+;;; can return two values.
+;;; Argv-Raylen added to pass target ray distance to PATHLENGTH-INTEGRATE.
+;;; Argv-Pl-Dx and Argv-Pl-Dy no longer used.
+;;; Change structures used in electron code [PBEAM, QNODE, and TILE]
+;;; to arrays with inlined accessors and new declarations.
+;;; Flush macros FAST-SIN and FAST-ATAN - not accurate enough.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 03-Nov-2003 BobGian - more specific/meaningful names for some constants:
+;;; Exp-Width -> Cutout-Expand-Width
+;;; Step-Size -> Electron-Step-Size
+;;;
+
+(in-package :Prism)
+
+;;;=============================================================
+;;; DEFCONSTANTs for array sizes.
+
+(defconstant ERF-Table-Size 3001)
+
+;;;=============================================================
+;;; DEFCONSTANTs for parameters in Pathlength and Electron Dosecalc.
+
+(defconstant Pathlength-Ray-Maxlength 400.0)
+(defconstant Electron-SSD-Minlength 99.5)
+(defconstant Electron-SSD-Maxlength 120.0)
+(defconstant Cutout-Min-Size 2.0)
+(defconstant Tissue-Maximum-Density 2.0)
+
+;;;=============================================================
+;;; DEFCONSTANTs for named slots in Arg-Vec.
+
+;;; ARG-VEC holds an array with Argv-Size slots for passing
+;;; SINGLE-FLOAT args to functions and for returning results. Doing so
+;;; [rather than passing args the normal way] greatly decreases flonum boxing
+;;; and GC overhead. These contants define the slot-number [zero-indexed] vs
+;;; usage pattern. "Static" slots hold a value which does not change for the
+;;; entire dose-calc, after being initialized at start. Values in "Dynamic"
+;;; slots change as the calculation proceeds [ie, a different value is passed
+;;; on each function call]. "Mixed" slots hold data that does change but not
+;;; too often - ie, it is fixed for some major iteration and therefore need
+;;; only be updated at loop entry, not at every argument-passing point.
+
+(defconstant Argv-Return-0 0) ;Return first flonum value - dynamic.
+(defconstant Argv-Return-1 1) ;Return second flonum value - dynamic.
+
+(defconstant Argv-Src-X 2) ;Source-X in Pt coords - static.
+(defconstant Argv-Src-Y 3) ;Source-Y in Pt coords - static.
+(defconstant Argv-Src-Z 4) ;Source-Z in Pt coords - static.
+
+(defconstant Argv-Dp-X 5) ;DosePoint-X in Pt coords - mixed.
+(defconstant Argv-Dp-Y 6) ;DosePoint-Y in Pt coords - mixed.
+(defconstant Argv-Dp-Z 7) ;DosePoint-Z in Pt coords - mixed.
+
+(defconstant Argv-Xcd 8) ;DosePoint-X in Coll coords - mixed.
+(defconstant Argv-Ycd 9) ;DosePoint-Y in Coll coords - mixed.
+(defconstant Argv-Zcd 10) ;DosePoint-Z in Coll coords - mixed.
+
+(defconstant Argv-Raylen 11) ;RayLength passed to BEAM-DOSE - dynamic.
+
+(defconstant Argv-Xci 12) ;DP-X, Coll coords, at iso - dynamic.
+(defconstant Argv-Yci 13) ;DP-Y, Coll coords, at iso - dynamic.
+
+(defconstant Argv-Depth 14) ;Surface-DosePoint distance - dynamic.
+(defconstant Argv-Div 15) ;DIVERGENCE - dynamic.
+
+(defconstant Argv-Xci- 16) ;Portal X-Min coll coord - static.
+(defconstant Argv-Xci+ 17) ;Portal X-Max coll coord - static.
+(defconstant Argv-Yci- 18) ;Portal Y-Min coll coord - static.
+(defconstant Argv-Yci+ 19) ;Portal Y-Max coll coord - static.
+
+(defconstant Argv-Enc-X 20) ;ENCLOSES? X arg.
+(defconstant Argv-Enc-Y 21) ;ENCLOSES? Y arg.
+
+(defconstant Argv-Size 22) ;Size of Argument Vector.
+
+;;;=============================================================
+;;; DEFCONSTANTs related to Polygon-Clipping code.
+
+;;; ARG-VEC is bound to an array with Argv-Size slots for passing
+;;; SINGLE-FLOAT args to functions and for returning results. This file
+;;; contains DEFCONSTANTs for defining slot names in ARG-VEC, since
+;;; multiple files use ARG-VEC.
+
+;;; Note that XCI-, XCI+, YCI-, and YCI+ are always passed in slots named
+;;; Argv-Xci-, Argv-Xci+ Argv-Yci-, and Argv-Yci+ - once loaded, before call
+;;; to CLIP-BLOCKS, they never need to be reloaded during entire clipping
+;;; routine - or for the rest of the dose calculation, for that matter.
+
+;;; Slot usage in the clipping routines is independent of usage in the rest
+;;; of the dose computation, other than steering clear of the four slots just
+;;; mentioned. Actually, they are NOT currently used outside the clipping
+;;; routines, but they might be at some future time.
+
+;;; CLIP-BLOCKS:
+;;;
+;;; Inputs: VLIST Passed as arg
+;;; XCI- Slot Argv-Xci-
+;;; XCI+ Slot Argv-Xci+
+;;; YCI- Slot Argv-Yci-
+;;; YCI+ Slot Argv-Yci+
+;;;
+;;; Returns: LIST - Clipped block outlines in Counter-Clockwise traversal.
+
+;;; GRAZER?:
+;;;
+;;; Inputs:
+(defconstant Argv-Bx 0)
+(defconstant Argv-By 1)
+(defconstant Argv-Cx 2)
+(defconstant Argv-Cy 3)
+(defconstant Argv-Nx 4)
+(defconstant Argv-Ny 5)
+;;; XCI- Slot Argv-Xci-
+;;; XCI+ Slot Argv-Xci+
+;;; YCI- Slot Argv-Yci-
+;;; YCI+ Slot Argv-Yci+
+;;;
+;;; Returns: BOOLEAN
+
+;;; PUSHNODE:
+;;;
+;;; Inputs:
+(defconstant Argv-Vx 0)
+(defconstant Argv-Vy 1)
+;;; XCI- Slot Argv-Xci-
+;;; XCI+ Slot Argv-Xci+
+;;; YCI- Slot Argv-Yci-
+;;; YCI+ Slot Argv-Yci+
+;;;
+;;; Returns: Pointer to Node
+
+;;; SINGLE-CROSS:
+;;;
+;;; Inputs:
+(defconstant Argv-Ix 0)
+(defconstant Argv-Iy 1)
+(defconstant Argv-Ox 2)
+(defconstant Argv-Oy 3)
+;;; XCI- Slot Argv-Xci-
+;;; XCI+ Slot Argv-Xci+
+;;; YCI- Slot Argv-Yci-
+;;; YCI+ Slot Argv-Yci+
+;;;
+;;; Returns:
+(defconstant Argv-X 0)
+(defconstant Argv-Y 1)
+
+;;; DUAL-CROSS:
+;;;
+;;; Inputs:
+;(defconstant Argv-Ix 0)
+;(defconstant Argv-Iy 1)
+;(defconstant Argv-Ox 2)
+;(defconstant Argv-Oy 3)
+;;; XCI- Slot Argv-Xci-
+;;; XCI+ Slot Argv-Xci+
+;;; YCI- Slot Argv-Yci-
+;;; YCI+ Slot Argv-Yci+
+;;;
+;;; Returns:
+(defconstant Argv-Xe 0)
+(defconstant Argv-Ye 1)
+(defconstant Argv-Xl 2)
+(defconstant Argv-Yl 3)
+
+;;;=============================================================
+;;; Structure used by Polygon Clipping code.
+;;;
+;;; "Real" structure simulated by ordinary array referencing, in order to
+;;; get inlined array access.
+
+(defconstant Cnode-Xci 0) ;XCI coordinate of node.
+(defconstant Cnode-Yci 1) ;YCI coordinate of node.
+(defconstant Cnode-Next 2) ;Ptr to next node on original contour.
+
+;;; Type: INSIDE, ENTER, or LEAVE.
+;;; Nodes on border are considered OUTSIDE, and no OUTSIDE nodes
+;;; [strict or border] are saved - only vertices which interact
+;;; with the interior of the portal are used.
+(defconstant Cnode-Type 3)
+
+;;; CODE is a fixnum indicating location of a vertex on the portal border:
+;;; NIL for vertices INSIDE the portal.
+;;; ODD values indicate sides not including the corner points.
+;;; EVEN values indicate corner points.
+;;; Values start with ZERO at the SouthWest [ie, the (XCI-, YCI-) ] corner
+;;; and increment around the portal. The value is meaningful MOD 8.
+(defconstant Cnode-Code 4)
+
+(defconstant Cnode-Size 5)
+
+;;;=============================================================
+;;; Constants for Electron dosecalc.
+
+(defconstant Cutout-Expand-Width 0.8) ; 0.4 cm field margin times two
+(defconstant Pen-Bm-Width 0.1) ; always 0.1 cm
+(defconstant Electron-Step-Size 0.1)
+
+;;;=============================================================
+;;; Structure definition for Pencil Beams.
+;;; Only the three collimator coefficients are settable at creation time.
+;;; The three patient coefficients are set later via SETF.
+;;; The weight coefficient is set at creation time
+;;; and applies to both coordinate systems.
+
+(defmacro make-pbeam (weight xc yc zc)
+ `(let (($obj (make-array 7 :element-type 'single-float)))
+ (declare (type (simple-array single-float (7)) $obj))
+ (setf (aref $obj 0) (the single-float ,weight))
+ (setf (aref $obj 1) (the single-float ,xc))
+ (setf (aref $obj 2) (the single-float ,yc))
+ (setf (aref $obj 3) (the single-float ,zc))
+ $obj))
+
+(defmacro pbeam-wt ($obj) ;Initial beam weight.
+ `(aref (the (simple-array single-float (7)) ,$obj) 0))
+
+(defmacro pbeam-xc ($obj) ;Collimator X-coordinate in cm.
+ `(aref (the (simple-array single-float (7)) ,$obj) 1))
+
+(defmacro pbeam-yc ($obj) ;Collimator Y-coordinate in cm.
+ `(aref (the (simple-array single-float (7)) ,$obj) 2))
+
+(defmacro pbeam-zc ($obj) ;Collimator Z-coordinate in cm.
+ `(aref (the (simple-array single-float (7)) ,$obj) 3))
+
+(defmacro pbeam-xp ($obj) ;Patient X-coordinate in cm.
+ `(aref (the (simple-array single-float (7)) ,$obj) 4))
+
+(defmacro pbeam-yp ($obj) ;Patient Y-coordinate in cm.
+ `(aref (the (simple-array single-float (7)) ,$obj) 5))
+
+(defmacro pbeam-zp ($obj) ;Patient Z-coordinate in cm.
+ `(aref (the (simple-array single-float (7)) ,$obj) 6))
+
+;;;=============================================================
+;;; Structure definitions for Quadtree objects.
+
+(defmacro make-qnode (x-pos y-pos dimension)
+ `(let (($obj (make-array 8 :element-type t :initial-element nil)))
+ (declare (type (simple-array t (8)) $obj))
+ (setf (aref $obj 0) (the single-float ,x-pos))
+ (setf (aref $obj 1) (the single-float ,y-pos))
+ (setf (aref $obj 2) (the single-float ,dimension))
+ $obj))
+
+(defmacro qnode-xpos ($obj) ; Central X qnode coordinate in cm
+ `(aref (the (simple-array t (8)) ,$obj) 0))
+
+(defmacro qnode-ypos ($obj) ; Central Y qnode coordinate in cm
+ `(aref (the (simple-array t (8)) ,$obj) 1))
+
+(defmacro qnode-dimension ($obj) ; Size of square qnode side in cm
+ `(aref (the (simple-array t (8)) ,$obj) 2))
+
+(defmacro qnode-child1 ($obj) ; Subnode
+ `(aref (the (simple-array t (8)) ,$obj) 3))
+
+(defmacro qnode-child2 ($obj) ; Subnode
+ `(aref (the (simple-array t (8)) ,$obj) 4))
+
+(defmacro qnode-child3 ($obj) ; Subnode
+ `(aref (the (simple-array t (8)) ,$obj) 5))
+
+(defmacro qnode-child4 ($obj) ; Subnode
+ `(aref (the (simple-array t (8)) ,$obj) 6))
+
+(defmacro qnode-status ($obj) ; One of :Inside, :Outside, :Cantmerge, or NIL
+ `(aref (the (simple-array t (8)) ,$obj) 7))
+
+;;;=============================================================
+
+(defmacro make-tile (x-pos y-pos dimension)
+ `(let (($obj (make-array 3 :element-type 'single-float)))
+ (declare (type (simple-array single-float (3)) $obj))
+ (setf (aref $obj 0) (the single-float ,x-pos))
+ (setf (aref $obj 1) (the single-float ,y-pos))
+ (setf (aref $obj 2) (the single-float ,dimension))
+ $obj))
+
+(defmacro tile-xpos ($obj) ; X coordinate of merged qnode in cm
+ `(aref (the (simple-array single-float (3)) ,$obj) 0))
+
+(defmacro tile-ypos ($obj) ; Y coordinate of merged qnode in cm
+ `(aref (the (simple-array single-float (3)) ,$obj) 1))
+
+(defmacro tile-dimension ($obj) ; Half-width of square tile in cm
+ `(aref (the (simple-array single-float (3)) ,$obj) 2))
+
+;;;=============================================================
+;;; Macro used in COMPUTE-BEAM-DOSE. This clamps dose when BLOCK-FACTOR
+;;; is included to >= 0.0, in case amount subtracted over-estimated.
+
+(defmacro monus (x y)
+ (let ((val (gensym)))
+ `(let ((,val (- (the single-float ,x) (the single-float ,y))))
+ (the single-float
+ (if (< (the single-float ,val) 0.0) 0.0 (the single-float ,val))))))
+
+;;;=============================================================
+
+(defmacro sqr-float (arg)
+ ;; Bind a local var to argument to avoid repeated evaluation of arg.
+ `(let ((sqr.arg (the single-float ,arg)))
+ (the single-float
+ (* (the single-float sqr.arg)
+ (the single-float sqr.arg)))))
+
+(defmacro sqr-fix (arg)
+ ;; Bind a local var to argument to avoid repeated evaluation of arg.
+ `(let ((sqr.arg (the fixnum ,arg)))
+ (the fixnum
+ (* (the fixnum sqr.arg)
+ (the fixnum sqr.arg)))))
+
+;;;-------------------------------------------------------------
+;;; 3D-DISTANCE: computes distance between two points in 3D space
+;;; Inline expansion of DISTANCE-3D function used in other versions.
+;;;-------------------------------------------------------------
+
+(defmacro 3d-distance (xc1 yc1 zc1 xc2 yc2 zc2)
+
+ "3d-distance xc1 yc1 zc1 xc2 yc2 zc2
+
+returns the distance between two points in 3D space"
+
+ `(let ((xdiff (- (the single-float ,xc2) (the single-float ,xc1)))
+ (ydiff (- (the single-float ,yc2) (the single-float ,yc1)))
+ (zdiff (- (the single-float ,zc2) (the single-float ,zc1))))
+
+ (declare (type single-float xdiff ydiff zdiff))
+
+ (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *)
+ (+ (* xdiff xdiff)
+ (* ydiff ydiff)
+ (* zdiff zdiff)))))))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/dosecomp.cl b/prism/src/dosecomp.cl
new file mode 100644
index 0000000..374ac28
--- /dev/null
+++ b/prism/src/dosecomp.cl
@@ -0,0 +1,146 @@
+;;;
+;;; dosecomp
+;;;
+;;; Functions which implement Prism dose computation methods. The
+;;; actual details for each type of source are in separate files.
+;;;
+;;; 2-Jan-1996 I. Kalet from original dosecomp.cl, split off stream
+;;; i/o to separate file in anticipation of rewrite of beam dose
+;;; calc. in lisp. This code calls the source-specific code which is
+;;; in other files.
+;;; 16-Jan-1996 I. Kalet modify calls to source-specific code, to use
+;;; new Lisp implementation, and not the old Pascal program.
+;;; 21-Mar-1997 I. Kalet new calls to general compute-xxx-dose instead
+;;; of separate functions for pts and grid.
+;;; 26-Jun-1997 I. Kalet add check for grid size and make new array if
+;;; necessary before calling compute-xxx-dose. Check plan result
+;;; array size too.
+;;; 30-Oct-1997 BobGian compute-xxx-dose fcns return t on success.
+;;; Return value of nil indicates failure - compute-dose-xxx then
+;;; does not set valid-xxx slot.
+;;; 09-Mar-1998 BobGian modest upgrade of dose-calc code.
+;;; 17-Jul-1998 BobGian factor beam-independent component of
+;;; pathlength computation out of compute-beam-dose and into
+;;; build-patient-structures. Change arguments to compute-beam-dose.
+;;; 22-Dec-1998 I. Kalet add call to compute-electron-dose
+;;; 21-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defun insure-grid-size (result grid-dims)
+
+ "insure-grid-size src grid-dims
+
+checks if the grid of the dose-result RESULT has dimensions GRID-DIMS
+and replaces it if not. The grid slot may be unbound or NIL, so that
+is checked first."
+
+ (when (or (not (slot-boundp result 'GRID))
+ (null (grid result))
+ (notevery #'= grid-dims (array-dimensions (grid result))))
+ (setf (grid result)
+ (make-array grid-dims :element-type 'SINGLE-FLOAT))
+ nil))
+
+;;;--------------------------------------------------
+
+(defun compute-dose-grid (plan pat)
+
+ "compute-dose-grid plan pat
+
+Given collections of organs and marks, a table position, a dose-grid
+specification, and collections of beams, seeds, and line sources, all
+contained within PLAN and PAT, this function computes the volumetric dose
+for each radiation source and stores it in the grid attribute of the
+source's DOSE-RESULT. The function computes dose for each radiation
+source whose dose result's grid is invalid, and sets VALID-GRID to T if
+that computation completes successfully by returning T."
+
+ (let* ((gg (dose-grid plan))
+ (dims (list (x-dim gg) (y-dim gg) (z-dim gg))))
+ (insure-grid-size (sum-dose plan) dims)
+ ;;
+ (let ((sources (coll:elements (beams plan))))
+ ;; Build structures representing patient anatomy - invariant over
+ ;; entire dose calculation for all beams.
+ (multiple-value-bind
+ (organ-vertices-list organ-z-extents organ-density-array)
+ (build-patient-structures (anatomy pat))
+ ;;
+ (dolist (src sources)
+ (let ((result (result src)))
+ (unless (valid-grid result)
+ (insure-grid-size result dims)
+ (setf (valid-grid result)
+ (if (typep (collimator src) 'electron-coll)
+ (compute-electron-dose
+ src sources nil gg organ-vertices-list
+ organ-z-extents organ-density-array)
+ (compute-beam-dose
+ src sources nil gg organ-vertices-list
+ organ-z-extents organ-density-array))))))))
+ ;;
+ (dolist (src (coll:elements (line-sources plan)))
+ (let ((result (result src)))
+ (unless (valid-grid result)
+ (insure-grid-size result dims)
+ (setf (valid-grid result)
+ (compute-line-dose src nil gg))))) ; no points!
+ ;;
+ (dolist (src (coll:elements (seeds plan)))
+ (let ((result (result src)))
+ (unless (valid-grid result)
+ (insure-grid-size result dims)
+ (setf (valid-grid result)
+ (compute-seed-dose src nil gg))))))) ; no points!
+
+;;;--------------------------------------
+
+(defun compute-dose-points (plan pat)
+
+ "compute-dose-points plan pat
+
+Given collections of organs and marks, a table position, a collection of
+points, and collections of beams, seeds, and line sources, all contained
+within PLAN and PAT, this function computes the dose to each point for
+each radiation source and stores the doses in the points attribute of the
+source's DOSE-RESULT. The function only computes dose for each radiation
+source whose dose result's points is invalid, and sets VALID-GRID to T if
+that computation completes successfully by returning T."
+
+ (let ((pointlist (coll:elements (points pat))))
+ ;; Build structures representing patient anatomy -
+ ;; invariant over dose calculation for all beams.
+ (multiple-value-bind
+ (organ-vertices-list organ-z-extents organ-density-array)
+ (build-patient-structures (anatomy pat))
+ (let ((sources (coll:elements (beams plan))))
+ (dolist (src sources)
+ (let ((result (result src)))
+ (unless (valid-points result)
+ (setf (valid-points result)
+ (if (typep (collimator src) 'electron-coll)
+ (compute-electron-dose
+ src sources pointlist nil organ-vertices-list
+ organ-z-extents organ-density-array)
+ (compute-beam-dose
+ src sources pointlist nil organ-vertices-list
+ organ-z-extents organ-density-array))))))))
+ ;;
+ (dolist (src (coll:elements (line-sources plan)))
+ (let ((result (result src)))
+ (unless (valid-points result)
+ (setf (valid-points result)
+ (compute-line-dose src pointlist nil))))) ; no grid
+ ;;
+ (dolist (src (coll:elements (seeds plan)))
+ (let ((result (result src)))
+ (unless (valid-points result)
+ (setf (valid-points result)
+ (compute-seed-dose src pointlist nil))))))) ; no grid
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/drr.cl b/prism/src/drr.cl
new file mode 100644
index 0000000..38e36d9
--- /dev/null
+++ b/prism/src/drr.cl
@@ -0,0 +1,533 @@
+;;;
+;;; drr
+;;;
+;;; code for computing digitally reconstructed radiographs
+;;;
+;;; xx-Jul-1998 C. Wilcox wrote, based on Jon Unger's code from 1992.
+;;; 12-Aug-1998 I. Kalet make image quality setting a global instead
+;;; of prompting, also reformat some code for readability.
+;;; 03-Apr-1999 C. Wilcox created progressive version of DRR's with
+;;; support for pausing, restarting, and canceling.
+;;; 11-Jul-2000 I. Kalet map-image-to-clx now split into two functions.
+;;; 10-Sep-2000 I. Kalet image display now handled by OpenGL, not here,
+;;; also eliminate multiresolution scheme, not useful after all.
+;;; 13-Dec-2000 I. Kalet handle incremental display update by cached
+;;; function in view, not by indirect kludge.
+;;; 26-Jun-2005 I. Kalet change single-float calls to coerce
+;;; 25-Jun-2008 I. Kalet take out erroneous declarations
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------
+
+(defconstant **epsilon** (* 5 least-positive-single-float)) ;; single-float
+
+(defvar *drr-rows-per-time-slice* 10
+ "determines how long the drr runs before processing accumulated X events")
+
+;;;----------------------------------------------
+
+(defun vec-cross (v1 v2 &optional v3)
+ (declare (type (simple-array single-float (3)) v1 v2 v3)
+ ;; (:explain :calls :types :variables :boxing)
+ )
+ (if (not v3) (setf v3 (make-array 3 :element-type 'single-float)))
+ (setf (aref v3 0)
+ (- (* (aref v1 1) (aref v2 2)) (* (aref v1 2) (aref v2 1))))
+ (setf (aref v3 1)
+ (- (* (aref v1 2) (aref v2 0)) (* (aref v1 0) (aref v2 2))))
+ (setf (aref v3 2)
+ (- (* (aref v1 0) (aref v2 1)) (* (aref v1 1) (aref v2 0))))
+ v3)
+
+;;;----------------------------------------------
+
+(defun vec-scale (s v &optional v3)
+
+ (declare (type (simple-array single-float (3)) v v3)
+ (type single-float s))
+ (if (not v3) (setf v3 (make-array 3 :element-type 'single-float)))
+ (setf (aref v3 0) (* s (aref v 0)))
+ (setf (aref v3 1) (* s (aref v 1)))
+ (setf (aref v3 2) (* s (aref v 2)))
+ v3)
+
+;;;----------------------------------------------
+
+(defun vec-diff (v1 v2 &optional v3)
+
+ (declare (type (simple-array single-float (3)) v1 v2 v3))
+ (if (not v3) (setf v3 (make-array 3 :element-type 'single-float)))
+ (setf (aref v3 0) (- (aref v1 0) (aref v2 0)))
+ (setf (aref v3 1) (- (aref v1 1) (aref v2 1)))
+ (setf (aref v3 2) (- (aref v1 2) (aref v2 2)))
+ v3)
+
+;;;----------------------------------------------
+
+(defun vec-sum (v1 v2 &optional v3)
+
+ (declare (type (simple-array single-float (3)) v1 v2 v3))
+ (if (not v3) (setf v3 (make-array 3 :element-type 'single-float)))
+ (setf (aref v3 0) (+ (aref v1 0) (aref v2 0)))
+ (setf (aref v3 1) (+ (aref v1 1) (aref v2 1)))
+ (setf (aref v3 2) (+ (aref v1 2) (aref v2 2)))
+ v3)
+
+;;;----------------------------------------------
+
+(defun vec-mag (v)
+
+ (declare (type (simple-array single-float (3)) v))
+ (sqrt (+ (* (aref v 0) (aref v 0))
+ (+ (* (aref v 1) (aref v 1))
+ (* (aref v 2) (aref v 2))))))
+
+;;;----------------------------------------------
+
+(defun vec-normalize (v &optional v3)
+
+ (declare (type (simple-array single-float (3)) v v3))
+ (if (not v3) (setf v3 (make-array 3 :element-type 'single-float)))
+ (let* ((mag (vec-mag v)))
+ (declare (type single-float mag))
+ (cond ((> **epsilon** mag)
+ (error "Can not normalize a zero length array"))
+ (t (vec-scale (/ mag) v v3)))))
+
+;;;--------------------
+;; Return the index for the largest array element that is
+;; less than or equal to value
+
+(defun array-search (arr value)
+
+ (declare (type single-float value)
+ ;; one-dimension and unknown length
+ (type (simple-array single-float 1) arr))
+ (let* ((low 0)
+ (high (array-dimension arr 0))
+ (mid 0))
+ (declare (integer low high mid))
+ (loop
+ (when (>= low high)
+ (return (if (>= 0 high) 0 (- high 1))))
+ (setf mid (truncate (+ low high) 2))
+ (cond
+ ((<= (aref arr mid) value) (setf low (+ 1 mid)))
+ (t (setf high mid))))))
+
+;;;--------------------
+
+(defun find-voxel (point voxel-width zarray return-array)
+
+ ;; ASSUMPTION: voxel-width is non-zero!
+ ;; ASSUMPTION: min-corner is <0,0,0>
+
+ (declare (type (simple-array single-float (3)) point voxel-width)
+ (type (simple-array single-float) zarray)
+ (type (simple-array (unsigned-byte 16) (3)) return-array))
+ (setf (aref return-array 0)
+ (max 0 (floor (aref point 0) (aref voxel-width 0))))
+ (setf (aref return-array 1)
+ (max 0 (floor (aref point 1) (aref voxel-width 1))))
+ (setf (aref return-array 2)
+ (max 0 (array-search zarray (aref point 2)))))
+
+;;;--------------------
+
+(defun ray-box-intersect (ray-start ray-direction box-width)
+
+ "This function takes three parameters:
+ ray-start: a point in space where a ray starts
+ ray-direction: a vector pointing in the direction of
+ the ray
+ box-width: three coords representing the size of the box
+ This function returns a two element list:
+ first: the length along the ray to to first intersection point
+ second: the length along the ray to the second intersection
+ point
+ If there is no intersection, then we will return nil."
+
+ (declare (type (simple-array single-float (3))
+ ray-start ray-direction box-width))
+ (let* ((tnear most-negative-single-float)
+ (tfar most-positive-single-float)
+ (t1 0.0)
+ (t2 0.0)
+ (temp 0.0))
+ (declare (type single-float tnear tfar t1 t2 temp))
+ (dotimes (i 3)
+ (cond
+ ((< (abs (aref ray-direction i)) **epsilon**)
+ (when (or (< (aref ray-start i) 0.0)
+ (> (aref ray-start i) (aref box-width i)))
+ (return-from ray-box-intersect nil)))
+ (t
+ ;; distance to first slab
+ (setf t1 (/ (- 0.0 (aref ray-start i)) (aref ray-direction i)))
+ ;; distance to second slab
+ (setf t2 (/ (- (aref box-width i) (aref ray-start i))
+ (aref ray-direction i)))
+ ;; ensure that t1 < t2
+ (when (> t1 t2)
+ (setf temp t1)
+ (setf t1 t2)
+ (setf t2 temp))
+ ;; update near and far
+ (when (> t1 tnear)
+ (setf tnear t1))
+ (when (< t2 tfar)
+ (setf tfar t2))
+ ;; if we miss or the box is behind the eye
+ ;; then bail out and return nil
+ (when (or (> tnear tfar) (< tfar 0.0))
+ (return-from ray-box-intersect nil)))))
+ (list tnear tfar)))
+
+;;;--------------------
+
+(defun density-sum (eye pixPt voxels coord-dist voxel-widths zarray)
+
+ "This is where the drr raytrace is calculated for each pixel in the image."
+
+ ;; assume that min < max for all 3 coordinates
+ ;; assume that min corner of voxel array is <0,0,0>
+ ;; calculate a normalized vector from eye to pixPt
+
+ (declare (type (simple-array single-float (3))
+ eye pixPt coord-dist voxel-widths)
+ (type (simple-array single-float 1) zarray)
+ ;; an array of 2d arrays of unsigned-byte 16's
+ (type (simple-array (simple-array (unsigned-byte 16) 2) 1)
+ voxels))
+ (let* ((ray (vec-normalize (vec-diff pixPt eye)))
+ (bounds (ray-box-intersect eye ray coord-dist))
+ (voxdim (make-array 3 :element-type '(unsigned-byte 16)
+ :initial-contents
+ (list (- (array-dimension (aref voxels 0) 0) 1)
+ (- (array-dimension (aref voxels 0) 1) 1)
+ (- (array-dimension voxels 0) 1))))
+ (tmin 0.0)
+ (tmax 0.0)
+ (next-t 0.0)
+ (current-t 0.0)
+ (next-axis 0) ;; fixnum
+ (current-voxel (make-array 3 :element-type '(unsigned-byte 16)))
+ (ray-sign (make-array 3 :element-type 'fixnum))
+ (next-index-val (make-array 3 :element-type 'fixnum))
+ (next-ts (make-array 3 :element-type 'single-float))
+ (next-plane-val (make-array 3 :element-type 'single-float))
+ (delta-t (make-array 3 :element-type 'single-float))
+ (delta-zt (make-array (- (array-dimension zarray 0) 1)
+ :element-type 'single-float))
+ (total-density 0.0))
+ (declare (type single-float tmin tmax next-t current-t total-density)
+ (fixnum next-axis)
+ (type (simple-array (unsigned-byte 16) (3))
+ voxdim current-voxel)
+ (type (simple-array fixnum (3))
+ ray-sign next-index-val)
+ (type (simple-array single-float (3))
+ ray next-ts next-plane-val delta-t)
+ (type (simple-array single-float 1) delta-zt))
+ ;; if the ray does not intersect the voxel array, return 0
+ (when (not bounds)
+ (return-from density-sum 0.0))
+ ;; set some values now that bounds != nil
+ (setf tmin (first bounds))
+ (setf tmax (second bounds))
+ (setf current-t tmin)
+ ;; create the delta-z array
+ (dotimes (i (array-dimension delta-zt 0))
+ (setf (aref delta-zt i)
+ (abs (/ (- (aref zarray (+ i 1)) (aref zarray i)) (aref ray 2)))))
+ (find-voxel (vec-sum (vec-scale (+ tmin **epsilon**) ray) eye)
+ voxel-widths zarray current-voxel)
+ ;; do a max bounds check on the current-voxel
+ (dotimes (i 3)
+ (when (> (aref current-voxel i) (aref voxdim i))
+ (setf (aref current-voxel i) (aref voxdim i))))
+ (dotimes (i 3)
+ ;; set whether the ray is moving positive, negative, or neither
+ (setf (aref ray-sign i)
+ (cond
+ ((> (aref ray i) 0.0) 1)
+ ((< (aref ray i) 0.0) -1)
+ (t 0)))
+ ;; set next index value that is going to be crossed in each direction
+ (setf (aref next-index-val i)
+ (if (= (aref ray-sign i) -1)
+ (aref current-voxel i)
+ (+ 1 (aref current-voxel i))))
+ ;; only used for finding the first set of next-ts
+ ;; this is the world coordinates value for the next plane that
+ ;; will be crossed
+ (setf (aref next-plane-val i)
+ (if (= i 2)
+ (aref zarray (aref next-index-val 2))
+ (* (aref next-index-val i) (aref voxel-widths i))))
+ (setf (aref delta-t i)
+ (if (= (aref ray-sign i) 0)
+ 100000.0
+ (abs (/ (aref voxel-widths i) (aref ray i)))))
+ (setf (aref next-ts i)
+ (if (= (aref ray-sign i) 0)
+ 100000.0
+ (/ (- (aref next-plane-val i) (aref eye i)) (aref ray i)))))
+ ;; select the next axis that the ray will cross
+ (setf next-axis 0)
+ ;; choose the next axis to cross in the voxel array
+ (when (< (aref next-ts 1) (aref next-ts next-axis))
+ (setf next-axis 1))
+ (when (< (aref next-ts 2) (aref next-ts next-axis))
+ (setf next-axis 2))
+ ;; update the next value of t for crossing a voxel
+ (setf next-t (aref next-ts next-axis))
+ ;; increment the next t for the axis that was chosen
+ (incf (aref next-ts next-axis)
+ (if (= next-axis 2)
+ ;; do something smart for z-axis @@
+ (aref delta-zt
+ (floor
+ (min (- (array-dimension delta-zt 0) 1)
+ (max 0
+ (+ (aref current-voxel 2) (aref ray-sign 2))))))
+ ;; if it is the x or y axis then add a delta
+ (aref delta-t next-axis)))
+ ;; take care of precision issue
+ (decf tmax **epsilon**)
+
+ ;; ***** This is where the action is *****
+ (do nil ( (or (> next-t tmax) (< next-t 0.0)) . nil)
+ ;; increment the density value
+ (incf total-density
+ (* (aref (aref voxels (aref current-voxel 2))
+ ;; flip the 'sign' for y since y points
+ ;; down in image coordinates (in slice data)
+ (- (aref voxdim 1) (aref current-voxel 1))
+ (aref current-voxel 0))
+ (- next-t current-t)))
+ ;; update current-t
+ (setf current-t next-t)
+ ;; update current-voxel with bounds check
+ (setf (aref current-voxel next-axis)
+ (max 0 (min (aref voxdim next-axis)
+ (+ (aref current-voxel next-axis)
+ (aref ray-sign next-axis)))))
+ ;; choose the next axis to cross
+ (setf next-axis 0)
+ (when (< (aref next-ts 1) (aref next-ts 0))
+ (setf next-axis 1))
+ (when (< (aref next-ts 2) (aref next-ts next-axis))
+ (setf next-axis 2))
+ ;; assign the next value for t based on the chosen axis
+ (setf next-t (aref next-ts next-axis))
+ ;; increment the next t for the axis that was chosen
+ (incf (aref next-ts next-axis)
+ (if (= next-axis 2)
+ ;; do something smart for z-axis @@
+ (aref delta-zt
+ (floor
+ (min (- (array-dimension delta-zt 0) 1)
+ (max 0
+ (+ (aref current-voxel 2)
+ (aref ray-sign 2))))))
+ ;; if it is the x or y axis then add a delta
+ (aref delta-t next-axis)))
+ ) ;; *** end of do loop ***
+ ;; final increment of the density value (use tmax instead of next-t)
+ (incf total-density
+ (* (aref (aref voxels (aref current-voxel 2))
+ (- (aref voxdim 1) (aref current-voxel 1))
+ (aref current-voxel 0))
+ (- tmax current-t)))
+ ;; return the total density
+ total-density))
+
+;;;--------------------
+
+(defun drr (corner1 corner2 zarray eyePt centerPt topPt
+ x-pixels y-pixels voxels bev)
+
+ "Calculates the drr:
+ corner1 = patient coordinates of one corner of the voxel grid
+ corner2 = patient coord's of opposing corner of the voxel grid
+ zarray = patient space z coord's for each 'slice' of the voxel array
+ eyePt = patient coord's for the origin of projection
+ centerPt = patient coord's for the center of the
+ projection plane
+ topPt = patient coord's for the top middle coord of
+ the projection plane
+ x-pixels = number of horizontal pixels in the final image
+ y-pixels = number of vertical pixels in the final image
+ voxels = the array of 2d arrays of voxel data
+ bev = the beams-eye-view that we are generating a drr for
+
+ returns a 2d array of (unsigned-byte 16) whose
+ dimensionality corresponds to x-pixels & y-pixels"
+
+ ;; Declare the types for the input parameters
+ (declare (type (simple-array single-float (3)) eyePt centerPt topPt)
+ (type (unsigned-byte 16) x-pixels y-pixels)
+ ;; an array of 2d arrays of unsigned-byte 16's
+ (type (simple-array (simple-array (unsigned-byte 16) 2) 1)
+ voxels))
+ ;; Setup local variables
+ (let* ((voxdim (make-array 3 :element-type 'fixnum
+ :initial-contents
+ (list (array-dimension (aref voxels 0) 0)
+ (array-dimension (aref voxels 0) 1)
+ (array-dimension voxels 0))))
+ (voxmin (make-array 3 :element-type 'single-float
+ :initial-contents
+ (list
+ (coerce (min (first corner1)
+ (first corner2)) 'single-float)
+ (coerce (min (second corner1)
+ (second corner2)) 'single-float)
+ (coerce (aref zarray 0) 'single-float))))
+ (voxmax (make-array 3 :element-type 'single-float
+ :initial-contents
+ (list
+ (coerce (max (first corner1)
+ (first corner2)) 'single-float)
+ (coerce (max (second corner1)
+ (second corner2)) 'single-float)
+ ;; last element of the zarray
+ (coerce (aref zarray
+ (- (array-dimension zarray 0)
+ 1)) 'single-float))))
+ (up-v (vec-diff topPt centerPt))
+ (normal-v (vec-diff eyePt centerPt))
+ (screen-height (* 2.0 (vec-mag up-v)))
+ ;; use pixel ratio to find screen-width
+ (screen-width (* screen-height (/ x-pixels y-pixels)))
+ (right-v (vec-cross up-v normal-v))
+ (top-left-pt (make-array 3 :element-type 'single-float))
+ (density-map (make-array (list x-pixels y-pixels)
+ :element-type 'single-float
+ :initial-element 0.0))
+ (return-map (make-array (list x-pixels y-pixels)
+ :element-type '(unsigned-byte 16)
+ :initial-element 0))
+ (voxel-array-widths (vec-diff voxmax voxmin))
+ (voxel-widths (vec-diff voxmax voxmin)))
+ (declare (type (simple-array single-float (3))
+ voxmin voxmax up-v normal-v right-v
+ top-left-pt voxel-widths)
+ (type (simple-array fixnum (3)) voxdim)
+ (type single-float screen-height screen-width)
+ (type (simple-array single-float 2) density-map)
+ (type (simple-array (unsigned-byte 16) 2) return-map))
+ ;; calculate the widths for each voxel
+ (dotimes (i 3)
+ (setf (aref voxel-widths i)
+ (/ (aref voxel-widths i)
+ (coerce (aref voxdim i) 'single-float))))
+ ;; guarantee that the image plane is perpendicular
+ ;; to the viewing direction
+ (setf up-v (vec-normalize (vec-cross normal-v right-v)))
+ (setf right-v (vec-normalize right-v))
+ (setf top-left-pt
+ (vec-sum
+ (vec-sum centerPt (vec-scale (* screen-width -0.5) right-v))
+ (vec-scale (* screen-width 0.5) up-v)))
+ ;; pre-scale the right and up vectors to make the pixel to
+ ;; patient coordinate transformation faster
+ (setf right-v (vec-scale (/ screen-width (- x-pixels 1)) right-v))
+ (setf up-v (vec-scale (/ screen-height (- y-pixels 1)) up-v))
+ ;; for speed optimization translate so that the min corner of
+ ;; the voxel array is <0,0,0> in world coords
+ (setf eyePt (vec-diff eyePt voxmin))
+ (setf top-left-pt (vec-diff top-left-pt voxmin))
+ (dotimes (i (array-dimension zarray 0))
+ (decf (aref zarray i) (aref voxmin 2)))
+ (let ((valfunc
+ #'(lambda (x y)
+ (density-sum eyePt
+ (vec-sum (vec-sum top-left-pt
+ (vec-scale (* -1.0 y) up-v))
+ (vec-scale (* 1.0 x) right-v))
+ voxels
+ voxel-array-widths
+ voxel-widths
+ zarray))))
+ (setf (drr-args bev)
+ ;; pixels, drr floats, density function, initial row, initial maxval
+ (vector return-map density-map valfunc 0 0.0))
+ (setf (drr-state bev) 'running)
+ (setf (sl:fg-color (image-button bev)) 'sl:green)
+ (drr-bg bev))
+ return-map))
+
+;;;-----------------------------------------------
+;; this wrapper is needed to identify the drr
+;; background function so that we can remove
+;; it from the background queue when necessary
+
+(defun drr-bg (bev)
+
+ (when (eq 'running (drr-state bev))
+ (progressive-fill (drr-args bev))
+ (let* ((drr-args (drr-args bev))
+ (pixels (aref drr-args 0))
+ (vals (aref drr-args 1))
+ (next-row (aref drr-args 3))
+ (maxp (aref drr-args 4)))
+ (update-pixels vals pixels next-row (if (> maxp 0.0)
+ (/ 2000.0 maxp)
+ 1.0))
+ (format t "DRR completed up to row ~A~%" next-row)
+ (funcall (display-func bev) bev)
+ (cond ((< next-row (array-dimension vals 1)) ;; continue
+ (sl:enqueue-bg-event (list 'drr-bg bev)))
+ (t ;; cleanup, do not requeue, cache result
+ (setf (sl:fg-color (image-button bev)) 'sl:red)
+ (setf (drr-state bev) 'stopped)
+ (format t "DRR done!~%"))))))
+
+;;;-----------------------------------------------
+
+(defun update-pixels (vals pixels next-row scale)
+
+ "Copy current progressive state of the floating point vals
+to the image-pixels."
+
+ (declare (type (simple-array single-float 2) vals)
+ (type (simple-array (unsigned-byte 16) 2) pixels)
+ (type single-float scale))
+ ;; assume that dimension of pixels is = dim of vals
+ (dotimes (y next-row)
+ (declare (type (unsigned-byte 16) y))
+ (dotimes (x (array-dimension vals 0))
+ (declare (type (unsigned-byte 16) x))
+ (setf (aref pixels y x)
+ (max 0 (min 4000 (floor (* scale (aref vals y x))))))))
+ nil)
+
+;;;-----------------------------------------------
+
+(defun progressive-fill (drr-args)
+
+ "computes a bunch of rows of DRR data according to the standard
+increment or how many rows are left, if fewer."
+
+ (let ((vals (aref drr-args 1))
+ (valfunc (aref drr-args 2))
+ (next-row (aref drr-args 3))
+ (maxval (aref drr-args 4))
+ (tempf 0.0))
+ (dotimes (delta-y (min *drr-rows-per-time-slice*
+ (- (array-dimension vals 1) next-row)))
+ (dotimes (x (array-dimension vals 0))
+ (setq tempf (funcall valfunc x next-row))
+ (if (> tempf maxval) (setq maxval tempf))
+ (setf (aref vals next-row x) tempf))
+ (incf next-row))
+ (setf (aref drr-args 3) next-row)
+ (setf (aref drr-args 4) maxval)
+ drr-args))
+
+;;;-----------------------------------------------
+;;; End.
diff --git a/prism/src/dvh-panel.cl b/prism/src/dvh-panel.cl
new file mode 100644
index 0000000..bc118e6
--- /dev/null
+++ b/prism/src/dvh-panel.cl
@@ -0,0 +1,635 @@
+;;;
+;;; dvh-panel
+;;;
+;;; ??-Aug-1998 C. Wilcox created
+;;; 14-Apr-1999 I. Kalet modify some labels, also some code formatting
+;;; 21-Jun-1999 J. Zeman implement print
+;;; 22-Nov-1999 I. Kalet cleanup, fix some missing updates, list only
+;;; plans that have valid dose distributions.
+;;; 26-Nov-2000 I. Kalet cosmetic changes in dialog box.
+;;;
+
+(in-package :prism)
+
+;;;-----------------------------------------
+
+(defclass dvh-panel (generic-panel)
+
+ ((frame :accessor frame
+ :documentation "The frame for the panel.")
+
+ (the-plot :accessor the-plot
+ :documentation "The 2d-plot widget.")
+
+ (the-patient :accessor the-patient
+ :initarg :the-patient
+ :documentation "The patient record.")
+
+ (plan-coll :accessor plan-coll
+ :initarg :plan-coll
+ :documentation "The collection of plans for the current
+patient.")
+
+ (plan-menu :accessor plan-menu
+ :documentation "A scrolling list of plans for the
+current patient.")
+
+ (plan-buttons :accessor plan-buttons
+ :initform nil
+ :documentation "A list of pairs of plans and
+their corresponding buttons in the scrolling list.")
+
+ (object :accessor object
+ :initarg :object
+ :documentation "The object for which DVH's are calculated.")
+
+ (max-dose-ro :accessor max-dose-ro
+ :documentation "The readout for the maximum dose.")
+
+ (cumulative :accessor cumulative
+ :initform t
+ :documentation "A flag that says whether the display
+is cumulative (true) or differential (false).")
+
+ (bin-size :accessor bin-size
+ :initarg :bin-size
+ :initform 2
+ :documentation "The bin size in [cGy] for the DVH calc's.")
+
+ (del-pan-b :accessor del-pan-b
+ :documentation "The button which destroys the panel when
+pressed.")
+
+ (widgets :accessor widgets
+ :documentation "The other ui widgets for the panel.")
+
+ )
+
+ (:documentation "The DVH panel displays dose-volume histogram plots
+for a single object and multiple plans.")
+
+ )
+
+;;;--------------------------------------
+
+(defun update-plot (dvhp)
+
+ (let* ((plot (the-plot dvhp))
+ (obj (object dvhp))
+ (bin-size (bin-size dvhp)))
+ (setf (sl:info (max-dose-ro dvhp)) "0")
+ ;; assuming that length of plan-list and series-list are equal
+ (dolist (pb-pair (plan-buttons dvhp))
+ (let ((plan (first pb-pair))
+ (button (second pb-pair)))
+ (if (sl:on button)
+ (sl::update-series plot plan (display-color (dose-grid plan))
+ (calc-series dvhp plan obj bin-size
+ (cumulative dvhp)))
+ (sl::remove-series plot plan))))
+ (sl::draw-plot-lines plot)))
+
+;;;--------------------------------------
+
+(defun calc-series (dvhp plan obj bin-size cumulative)
+
+ "Assume plan has a valid grid, return a series."
+
+ (multiple-value-bind (nul-val dvh-vals)
+ (scan obj (dose-grid plan) (grid (sum-dose plan))
+ :dvh-bin-size bin-size)
+ (declare (ignore nul-val))
+ (let ((tempx bin-size)
+ (plot-vals nil)
+ (pct 100)
+ (prev-max-dose (read-from-string (sl:info (max-dose-ro dvhp))))
+ (cur-max-dose (* bin-size (length dvh-vals))))
+ (when cumulative (push '(0 100) plot-vals))
+ (dotimes (i (length dvh-vals))
+ (if cumulative
+ (progn
+ (setf pct (- pct (* 100 (aref dvh-vals i))))
+ (push (list tempx pct) plot-vals))
+ (progn ;; differential
+ (push (list (- tempx bin-size) (* 100 (aref dvh-vals i)))
+ plot-vals)
+ (push (list tempx (* 100 (aref dvh-vals i)))
+ plot-vals)))
+ (setf tempx (+ tempx bin-size)))
+ (when (< prev-max-dose cur-max-dose)
+ (setf (sl:info (max-dose-ro dvhp)) cur-max-dose))
+ plot-vals)))
+
+;;;--------------------------------------
+
+(defun add-plan (pln dvhp)
+
+ (let* ((ob (object dvhp))
+ (plan-sl (plan-menu dvhp))
+ (btn (sl:make-list-button plan-sl (name pln)))
+ (plot (the-plot dvhp)))
+ ;; set its foreground color
+ (setf (sl:fg-color btn)
+ (display-color (dose-grid pln)))
+ ;; add it to the scrolling list
+ (sl:insert-button btn plan-sl)
+ ;; add notifies to keep state synchronized with the plans
+ (ev:add-notify dvhp (new-name pln)
+ #'(lambda (pan pln newname)
+ (declare (ignore pan pln))
+ (setf (sl:label btn) newname)))
+ (ev:add-notify dvhp (sl:button-on btn)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (sl::update-series plot pln
+ (display-color (dose-grid pln))
+ (calc-series pan pln ob
+ (bin-size pan)
+ (cumulative pan)))
+ (sl::draw-plot-lines plot)))
+ (ev:add-notify dvhp (sl:button-off btn)
+ #'(lambda (pan btn)
+ (declare (ignore pan btn))
+ (sl::remove-series plot pln)
+ (sl::draw-plot-lines plot)))
+ (ev:add-notify dvhp (new-color (dose-grid pln))
+ #'(lambda (pan grid newc)
+ (declare (ignore pan grid))
+ (let ((plotline (find-if #'(lambda (x)
+ (equal pln (first x)))
+ (coll:elements
+ (sl::series-coll plot)))))
+ (when plotline
+ (setf (second plotline) newc)
+ (sl::draw-plot-lines plot))
+ (setf (sl:fg-color btn) newc))))
+ (push (list pln btn) (plan-buttons dvhp))))
+
+;;;--------------------------------------
+
+(defun remove-plan (pln dvhp)
+
+ (let* ((planlst (plan-buttons dvhp))
+ (pln-btn-pair (find pln planlst :key #'first))
+ (btn (second pln-btn-pair)))
+ (when btn
+ (ev:remove-notify dvhp (new-name pln))
+ (ev:remove-notify dvhp (sl:button-on btn))
+ (ev:remove-notify dvhp (sl:button-off btn))
+ (ev:remove-notify dvhp (new-color (dose-grid pln)))
+ ;; this removes the button AND destroys it
+ (sl:delete-button btn (plan-menu dvhp))
+ (setf (plan-buttons dvhp) (remove pln-btn-pair planlst))
+ (sl::remove-series (the-plot dvhp) pln)
+ (sl::draw-plot-lines (the-plot dvhp)))))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((dvhp dvh-panel)
+ &rest initargs)
+
+ (let* ((ob (object dvhp))
+ (obname (name ob))
+ (fr-width 700) ; frame width
+ (fr-height 600) ; frame height
+ (l-plot 160) ; left-coords for plot
+ (gutter 5) ; room between widgets
+ (b-height 25) ; height of each button
+ (b-rows 2) ; rows of buttons at bottom
+ (b-cols 3) ; columns of buttons at bottom
+ ;; bottom-coords for plot
+ (b-plot (- fr-height (* (+ 1 b-rows) gutter) (* b-rows b-height)))
+ (b-list (- b-plot (* 5 gutter) (* 4 b-height) 50))
+ (col-width (floor fr-width b-cols))
+ (frm (sl:make-frame fr-width fr-height
+ :title (format nil "DVH PANEL: ~s" obname)))
+ (win (sl:window frm))
+ (del-b (sl:make-button (- l-plot gutter gutter) b-height
+ :parent (sl:window frm)
+ :button-type :momentary
+ :label "Del Pan"
+ :ulc-x gutter :ulc-y gutter))
+ (plot (sl:make-2d-plot (- fr-width l-plot gutter)
+ (- b-plot gutter gutter)
+ :parent win
+ :ulc-x l-plot :ulc-y gutter
+ :bottom-label "DOSE - cGy"
+ :left-label "VOLUME - %"
+ :right-label "VOLUME - cc"
+ :y-scale-factor (/ (physical-volume ob)
+ 100.0)
+ :delta 0.01))
+ (plan-sl (sl:make-scrolling-list (- l-plot gutter gutter)
+ (- b-list (* 3 gutter) b-height)
+ :label "Plan List" :parent win
+ :ulc-x gutter
+ :ulc-y (+ b-height gutter gutter)))
+ (slider-title-ro
+ (sl:make-readout (- l-plot gutter gutter) b-height
+ :parent win
+ :ulc-x gutter :ulc-y (+ gutter b-list)
+ :bg-color 'sl:blue
+ :label "" :info "Slider Bar Vals"))
+ (percent-tl (sl:make-textline (- l-plot gutter gutter) b-height
+ :ulc-x gutter
+ :ulc-y (+ b-list (* 2 gutter)
+ (* 1 b-height))
+ :lower-limit 0 :upper-limit 500
+ :parent win
+ :numeric t :label "Vol[%]: "))
+ (cc-tl (sl:make-textline (- l-plot gutter gutter) b-height
+ :parent win
+ :ulc-x gutter
+ :ulc-y (+ b-list (* 3 gutter)
+ (* 2 b-height))
+ :lower-limit 0 :upper-limit 1000000
+ :numeric t :label "Vol[cc]: "))
+ (gy-tl (sl:make-textline (- l-plot gutter gutter) b-height
+ :parent win
+ :ulc-x gutter
+ :ulc-y (+ b-list (* 4 gutter)
+ (* 3 b-height))
+ :lower-limit 0 :upper-limit 50000
+ :label "Dose[cGy]: "
+ :numeric t))
+ (bin-tl (sl:make-textline (- col-width (* 4 gutter)) b-height
+ :parent win
+ :ulc-x (+ (* 0 col-width) gutter)
+ :ulc-y (+ b-plot (* 1 gutter)
+ (* 0 b-height))
+ :lower-limit 0.0001 :upper-limit 10000
+ :label "Bin Size[cGy]: "
+ :numeric t))
+ (dose-ro (sl:make-readout (- col-width (* 4 gutter)) b-height
+ :parent win
+ :ulc-x (+ (* 0 col-width) gutter)
+ :ulc-y (+ b-plot (* 2 gutter)
+ (* 1 b-height))
+ :label "Max Dose[cGy]: "))
+ (display-b (sl:make-button (- col-width gutter gutter) b-height
+ :label "Cumulative" :parent win
+ :ulc-x (+ (* 1 col-width) gutter)
+ :ulc-y (+ b-plot (* 1 gutter)
+ (* 0 b-height))))
+ (stat-b (sl:make-button (- col-width gutter gutter) b-height
+ :label "Statistics" :parent win
+ :ulc-x (+ (* 1 col-width) gutter)
+ :ulc-y (+ b-plot (* 2 gutter)
+ (* 1 b-height))))
+ (print-b (sl:make-button (- col-width gutter gutter) b-height
+ :label "Print" :parent win
+ :ulc-x (+ (* 2 col-width) gutter)
+ :ulc-y (+ b-plot (* 1 gutter)
+ (* 0 b-height))))
+ (write-b (sl:make-button (- col-width gutter gutter) b-height
+ :label "Write Hist" :parent win
+ :ulc-x (+ (* 2 col-width) gutter)
+ :ulc-y (+ b-plot (* 2 gutter)
+ (* 1 b-height)))))
+ ;; assign values to slots
+ (setf (del-pan-b dvhp) del-b
+ (frame dvhp) frm
+ (the-plot dvhp) plot
+ (plan-menu dvhp) plan-sl
+ ;; list of widgets to destroy when panel is destroyed
+ (widgets dvhp) (list percent-tl cc-tl gy-tl bin-tl
+ display-b stat-b print-b write-b
+ slider-title-ro)
+ (max-dose-ro dvhp) dose-ro)
+ (dolist (pl (coll:elements (plan-coll dvhp)))
+ (let ((tmp pl)) ;; need this in order to retain for later ref.
+ (ev:add-notify dvhp (grid-status-changed (sum-dose tmp))
+ #'(lambda (pan dose-res newstat)
+ (declare (ignore dose-res))
+ (if newstat
+ (if (find tmp (plan-buttons pan)
+ :key #'first)
+ (update-plot pan)
+ (add-plan tmp pan))
+ (remove-plan tmp pan))))
+ (when (valid-grid (sum-dose tmp))
+ (add-plan tmp dvhp))))
+ ;; assign info values for widgets
+ (setf (sl:info percent-tl) "0"
+ (sl:info cc-tl) "0"
+ (sl:info gy-tl) "0"
+ (sl:info bin-tl) "2"
+ (sl:info dose-ro) "0")
+ ;; create notifies
+ (ev:add-notify dvhp (sl:button-on stat-b)
+ #'(lambda (pan bt)
+ (declare (ignore pan))
+ (sl:acknowledge "Stats are not yet implemented...")
+ (setf (sl:on bt) nil)))
+ (ev:add-notify dvhp (sl:button-on print-b)
+ #'(lambda (pan bt)
+ (print-dvh-panel pan)
+ (setf (sl:on bt) nil)))
+ (ev:add-notify dvhp (sl:button-on write-b)
+ ;; write all selected plans to disk
+ #'(lambda (pan bt)
+ (let ((fname
+ (sl:popup-textline "dvh-results" 300
+ :title "Select a filename"
+ :label "Filename: ")))
+ (when fname (write-dvh-data pan fname))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify dvhp (new-name (object dvhp))
+ #'(lambda (pan pstruct newname)
+ (declare (ignore pan pstruct))
+ (setf (sl:title frm)
+ (format nil "DVH PANEL: ~s" newname))))
+ (ev:add-notify dvhp (new-contours (object dvhp))
+ #'(lambda (dvhp pstruct)
+ (declare (ignore pstruct))
+ (update-plot dvhp)))
+ (ev:add-notify dvhp (coll:inserted (plan-coll dvhp))
+ #'(lambda (pan coll plan)
+ (declare (ignore coll))
+ (ev:add-notify dvhp (grid-status-changed
+ (sum-dose plan))
+ #'(lambda (pan dose-res newstat)
+ (declare (ignore dose-res))
+ (if newstat
+ (if (find plan
+ (plan-buttons dvhp)
+ :key #'first)
+ (update-plot pan)
+ (add-plan plan pan))
+ (remove-plan plan pan))))
+ (when (valid-grid (sum-dose plan))
+ (add-plan plan pan))))
+ (ev:add-notify dvhp (coll:deleted (plan-coll dvhp))
+ #'(lambda (pan coll plan)
+ (declare (ignore coll))
+ (ev:remove-notify dvhp (grid-status-changed
+ (sum-dose plan)))
+ (remove-plan plan pan)))
+ (ev:add-notify dvhp (sl:button-on del-b)
+ #'(lambda (dvhp bt)
+ (declare (ignore bt))
+ (destroy dvhp)))
+ (ev:add-notify dvhp (sl:button-on display-b)
+ #'(lambda (pan bt)
+ (if (equal (sl:label bt) "Cumulative")
+ (setf (sl:label bt) "Differential"
+ (cumulative pan) nil)
+ (setf (sl:label bt) "Cumulative"
+ (cumulative pan) t))
+ (update-plot pan)
+ (setf (sl:on bt) nil)))
+ (ev:add-notify dvhp (sl::new-slider-val plot)
+ #'(lambda (pan plot xval yval)
+ (declare (ignore plot))
+ (setf (sl:info percent-tl)
+ (format nil "~4F" yval))
+ (setf (sl:info cc-tl)
+ (format nil "~4F"
+ (* yval
+ (physical-volume (object pan))
+ 0.01)))
+ (setf (sl:info gy-tl)
+ (format nil "~4F" xval))))
+ (ev:add-notify dvhp (sl:new-info percent-tl)
+ #'(lambda (pan bx inf)
+ (declare (ignore bx))
+ (let* ((vol (physical-volume (object pan)))
+ (new-val (read-from-string inf))
+ (cc-val (* new-val vol 0.01)))
+ (setf (sl:info cc-tl) (format nil "~4F" cc-val)
+ (sl::y-slider-val plot) new-val)
+ (sl::draw-plot-lines plot))))
+ (ev:add-notify dvhp (sl:new-info cc-tl)
+ #'(lambda (pan bx inf)
+ (declare (ignore bx))
+ (let* ((vol (physical-volume (object pan)))
+ (new-val (read-from-string inf))
+ (pct-val (/ (* 100.0 new-val) vol)))
+ (setf (sl:info percent-tl)
+ (format nil "~4F" pct-val))
+ (setf (sl::y-slider-val plot)
+ pct-val)
+ (sl::draw-plot-lines plot))))
+ (ev:add-notify dvhp (sl:new-info gy-tl)
+ #'(lambda (pan bx inf)
+ (declare (ignore bx pan))
+ (let ((new-val (read-from-string inf)))
+ (setf (sl::x-slider-val plot) new-val)
+ (sl::draw-plot-lines plot))))
+ (ev:add-notify dvhp (sl:new-info bin-tl)
+ #'(lambda (pan bx inf)
+ (declare (ignore bx))
+ (let ((new-val (read-from-string inf)))
+ (setf (bin-size pan) new-val)
+ (update-plot pan))))))
+
+;;;--------------------------------------
+
+(defmethod destroy :before ((dvhp dvh-panel))
+
+ (dolist (p (mapcar #'first (plan-buttons dvhp)))
+ (remove-plan p dvhp))
+ (dolist (pl (coll:elements (plan-coll dvhp)))
+ (ev:remove-notify dvhp (grid-status-changed (sum-dose pl))))
+ (ev:remove-notify dvhp (coll:inserted (plan-coll dvhp)))
+ (ev:remove-notify dvhp (coll:deleted (plan-coll dvhp)))
+ (ev:remove-notify dvhp (new-contours (object dvhp)))
+ (ev:remove-notify dvhp (new-name (object dvhp)))
+ (sl:destroy (the-plot dvhp))
+ (sl:destroy (plan-menu dvhp))
+ (sl:destroy (max-dose-ro dvhp))
+ (dolist (w (widgets dvhp)) (sl:destroy w))
+ (sl:destroy (del-pan-b dvhp))
+ (sl:destroy (frame dvhp)))
+
+;;;--------------------------------------
+
+(defun print-dvh (dvhp printer num-copies)
+
+ (let ((ob (object dvhp))
+ (patient (the-patient dvhp)))
+ (with-open-file (strm "dvh-print"
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (ps:initialize strm 0.5 0.5 7.5 10.0)
+ (format strm "stroke~%")
+ (ps:set-position strm 0.0 8.0)
+ (sl:print-2dplot strm (the-plot dvhp) 7.5 7.5 t)
+ ;; erase slider vales, so a different format can be used
+ (format strm "gsave 358 182 moveto 550 182 lineto~%")
+ (format strm "550 234 lineto 358 234 lineto~%")
+ (format strm "closepath 1 setgray fill grestore~%")
+ (ps:prism-logo strm 5.5 10.5 *prism-version-string*)
+ ;; heading at top of page
+ (ps:set-position strm 0.0 0.25)
+ (ps:put-text strm (format nil "Patient: ~A"
+ (name patient)))
+ (ps:put-text strm ( format nil "Case Date: ~A"
+ (date-entered patient)))
+ (ps:put-text strm (format nil "Pat ID: ~A"
+ (patient-id patient)))
+ (ps:put-text strm (format nil "Hosp ID: ~A"
+ (hospital-id patient)))
+ ;;print 'tumor' or 'organ' as appropriate
+ (cond ((string-equal (name ob) "Target")
+ (ps:put-text strm "Target"))
+ (t (ps:put-text strm (format nil "Organ: ~A" (name ob)))))
+ (ps:put-text strm (format nil "Bin Size: ~,2F cGy"
+ (bin-size dvhp)))
+ ;; extra labels to 2d-plot
+ (ps:set-position strm 0 8)
+ (ps:put-text strm "Plans:")
+ (let ((listcount 0))
+ (dolist (plan (plan-buttons dvhp))
+ (let ((pln (first plan))
+ (button (second plan))
+ (colr nil))
+ (when (sl:on button)
+ (incf listcount)
+ (when (equal listcount 5)
+ (ps:indent strm 3)
+ (ps:set-position strm 3 8)
+ (ps:put-text strm ""))
+ ;; get color
+ (cond ((eq (display-color (dose-grid pln))
+ 'sl:red) (setf colr '(1 0 0)))
+ ((eq (display-color (dose-grid pln))
+ 'sl:blue) (setf colr '(0 0 1)))
+ ((eq (display-color (dose-grid pln))
+ 'sl:green) (setf colr '(0 1 0)))
+ ((eq (display-color (dose-grid pln))
+ 'sl:magenta) (setf colr '(.7 0 1)))
+ ((eq (display-color (dose-grid pln))
+ 'sl:cyan) (setf colr '(0 1 1)))
+ ((eq (display-color (dose-grid pln))
+ 'sl:gray) (setf colr '(.5 .5 .5)))
+ (t (setf colr '(0 0 0))))
+ (ps:set-graphics strm :color colr)
+ (ps:put-text strm "")
+ (ps:put-text strm (name pln))
+ (ps:set-graphics strm :color '(0 0 0))
+ (ps:put-text strm (format nil" ~A" (time-stamp pln)))))))
+ (ps:indent strm 0)
+ (format strm "360 184 moveto~%")
+ (ps:put-text strm (format nil "Y (in cc): ~,2F"
+ (float (* (sl:y-slider-val (the-plot dvhp))
+ (/(physical-volume ob)
+ 100)))))
+ (format strm "360 198 moveto~%")
+ (ps:put-text strm (format nil "Y (in %):~,2F"
+ (float (sl:y-slider-val (the-plot dvhp)))))
+ (format strm "360 212 moveto~%")
+ (ps:put-text strm (format nil "X (in cGy):~,2F"
+ (float (sl:x-slider-val (the-plot dvhp)))))
+ ;;box around slider vals
+ (format strm "1 4 div setlinewidth~%")
+ (format strm "358 182 moveto 358 226 lineto 498 226 lineto~%")
+ (format strm "498 182 lineto 358 182 lineto stroke~%")
+ (ps:finish-page strm)) ;;end with-open-file
+ (unless (string-equal "File only" printer)
+ (dotimes (i num-copies)
+ (run-subprocess (format nil "~a~a ~a"
+ *spooler-command* printer "dvh-print"))))))
+
+;;;--------------------------------------
+
+(defun print-dvh-panel (dvhp)
+
+ (sl:push-event-level)
+ (let* ((num-copies 1)
+ (printer (first *postscript-printers*))
+ (printer-menu (sl:make-radio-menu
+ *postscript-printers* :mapped nil))
+ (delta-y (+ 10 (max (sl:height printer-menu) 100)
+ 10))
+ (cbox (sl:make-frame (+ 10 (sl:width printer-menu)
+ 10 150 10)
+ (+ delta-y 30 10 30 10)
+ :title "Print DVH"))
+ (win (sl:window cbox))
+ (cpy-tln (sl:make-textline 150 30 :parent win
+ :label "Copies: "
+ :info (write-to-string num-copies)
+ :numeric t
+ :lower-limit 1
+ :upper-limit 9
+ :ulc-x (+ 10 (sl:width printer-menu)
+ 10)
+ :ulc-y delta-y))
+ (accept-x (round (/ (- (sl:width cbox) 170) 2)))
+ (accept-btn (sl:make-exit-button 80 30 :label "Accept"
+ :parent win
+ :ulc-x accept-x
+ :ulc-y (+ delta-y 40)
+ :bg-color 'sl:green))
+ (cancel-btn (sl:make-exit-button 80 30 :label "Cancel"
+ :parent win
+ :ulc-x (+ accept-x 90)
+ :ulc-y (+ delta-y 40))))
+ (clx:reparent-window (sl:window printer-menu) win 10 10)
+ (clx:map-window (sl:window printer-menu))
+ (clx:map-subwindows (sl:window printer-menu))
+ (sl:select-button 0 printer-menu)
+ (ev:add-notify cbox (sl:new-info cpy-tln)
+ #'(lambda (cbox tl info)
+ (declare (ignore cbox tl))
+ (setq num-copies (round (read-from-string info)))))
+ (ev:add-notify cbox (sl:selected printer-menu)
+ #'(lambda (cbox m item)
+ (declare (ignore cbox m))
+ (setq printer (nth item *postscript-printers*))))
+ (ev:add-notify dvhp (sl:button-on accept-btn)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (print-dvh pan printer num-copies)))
+ (sl:process-events)
+ (sl:destroy printer-menu)
+ (sl:destroy cpy-tln)
+ (sl:destroy accept-btn)
+ (sl:destroy cancel-btn)
+ (sl:destroy cbox)
+ (sl:pop-event-level)))
+
+;;;--------------------------------------
+
+(defun write-dvh-data (dvhp fname)
+
+ (let ((patient (the-patient dvhp))
+ (ob (object dvhp)))
+ (with-open-file (strm fname
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (format strm "Time Stamp = ~s~%" (date-time-string))
+ (format strm "Patient Name = ~s~%" (name patient))
+ (format strm "Patient ID = ~s~%" (patient-id patient))
+ (format strm "Case ID = ~s~%" (case-id patient))
+ (format strm "Anastruct = ~s~%" (name ob))
+ (format strm "Bin Size = ~s~%" (bin-size dvhp))
+ (dolist (p (plan-buttons dvhp))
+ (when (and (sl:on (second p))
+ (valid-grid (sum-dose (first p))))
+ (format strm "~%Plan = ~s~%" (name (first p)))
+ (multiple-value-bind (nul-val dvh-vals)
+ (scan ob (dose-grid (first p))
+ (grid (sum-dose (first p)))
+ :dvh-bin-size (bin-size dvhp))
+ (declare (ignore nul-val))
+ (format strm "Number of Bins = ~s~%" (length dvh-vals))
+ (dotimes (i (length dvh-vals))
+ (format strm " ~f~%" (aref dvh-vals i)))))))))
+
+;;;---------------------------------------
+;;; End.
+
+
+
+
+
+
+
+
+
+
+
diff --git a/prism/src/electron-dose.cl b/prism/src/electron-dose.cl
new file mode 100644
index 0000000..852e31b
--- /dev/null
+++ b/prism/src/electron-dose.cl
@@ -0,0 +1,1520 @@
+;;;
+;;; electron-dose
+;;;
+;;; The electron dose computation functions
+;;;
+;;; 13-Jun-1998 P. Cho started
+;;; 17-Nov-1998 P. Cho complete standalone version
+;;; 10-Dec-1998 P. Cho precompute sigmaRMS for homogeneous case
+;;; 17-Dec-1998 P. Cho implement precomputation of error functions
+;;; 18-Dec-1998 P. Cho working on Prism interface
+;;; 28-Mar-1999 I. Kalet cleanup, modularize
+;;; 11-Jul-1999 I. Kalet continuing cleanup
+;;; 04-Feb-2000 BobGian integrate nested interpolation for DD-TABLES
+;;; and ROF-TABLES. Change a few vars from global to local. Begin
+;;; preliminary optimization. AREA-OF-POLYGON -> POLYGONS package.
+;;; Make COMPUTE-ELECTRON-DOSE return T on success, NIL on failure (early
+;;; return on detection of nominal SSD or cutout dimensions out of range).
+;;; 10-Feb-2000 BobGian first working version - fix bugs in quadtree code
+;;; plus various fencepost errors and array-bounds calculations. Add
+;;; check for cutout extending beyond applicator.
+;;; 02-Mar-2000 BobGian intermediate version - corrects fencepost errors
+;;; and iteration overruns; contains some optimizations. This version
+;;; produces same results as Paul Cho's original version. It also
+;;; generates considerable testing output (but even more commented out).
+;;; 02-Nov-2000 BobGian inline common functions (square, distance), inline
+;;; functions used only once, add declaration, factor out redundant calls
+;;; to PATHLENGTH, replace PATHLENGTH where density is constant by use
+;;; of geometric distance, other optimizations. Includes debugging
+;;; printout for testing optimization.
+;;; 30-May-2001 BobGian - major restructuring of pathlength computation:
+;;; Replace organ density lookup via differential pathlength call with
+;;; direct lookup using structure returned by PATHLENGTH-RAYTRACE.
+;;; Replace FLU2DOSE normalization loop use of phantom (using pathlength
+;;; computation) with geometric distance calculation in semi-infinite
+;;; virtual phantom (extending over half-space with boundary at patient
+;;; surface). Better handling of end-of-loop termination criteria.
+;;; Repair several potential divide-by-zero conditions in the process.
+;;; Separate raytracing from line integration so that redundant computation
+;;; can be factored out (PATHLENGTH-RAYTRACE called once to build structure
+;;; that can be queried by PATHLENGTH-INTEGRATE multiple times).
+;;; Change all calling points in Electron and Photon dose calc.
+;;; Wrap generic arithmetic with THE-declared types.
+;;; Move all DECONSTANTs, DEFSTRUCTs, and DEFMACROs to "dosecomp-decls".
+;;; Wrap array references [E0, RP, THETA-AIR, F1, F2, Z1, Z2 slot objects]
+;;; in (SIMPLE-ARRAY T 2) declarations to allow inlining.
+;;; 03-Jun-2001 BobGian fix bug giving non-zero dose for point outside body.
+;;; 24-Aug-2001 Paul Cho and BobGian - add two contours to QUANTIZE-EXPFIELD;
+;;; add missing PBeam weighing factor in rFluence.
+;;; 27-Aug-2001 Paul Cho, BobGian - fix bug in PBEAM copy (forgot WEIGHT slot).
+;;; 07-Dec-2001 Paul Cho, BobGian - fix bug in FIND-EQUIV-RECT.
+;;; 11-Dec-2001 BobGian add storage of ROF and SSD in DOSE-RESULT.
+;;; 15-Mar-2002 BobGian parameterize constants used for Pathlength
+;;; and electron dosecalc.
+;;; 15-Mar-2002 BobGian change "erroneous but OK" conditions to call
+;;; sl:ACKNOWLEDGE rather than ERROR. Some conditions are continuable;
+;;; others abort dosecalc by immediately returning NIL.
+;;; 15-Mar-2002 BobGian PATHLENGTH-RAYTRACE used for "ray out-of-body"
+;;; detection. Former errors on this condition now return gracefully.
+;;; 15-Mar-2002 BobGian Organ-densities > 2.0 are now OK - computation
+;;; proceeds using parameters from highest density break-point
+;;; [ie, linear extrapolation].
+;;; 29-Apr-2002 BobGian PATHLENGTH-RAYTRACE cannot be used alone for
+;;; "ray out-of-body" detection, since it traces full length of normalizing
+;;; distance. Must also integrate to dosepoint for correct test.
+;;; 03-Jan-2003 BobGian:
+;;; Pathlength raytraces along pencil beams are now cached in alternating
+;;; slots of PBEAM-ARRAY [the array holding the pencil-beam array objects].
+;;; This allows this operation to be factored out of the per-dose-point
+;;; computation and done only once per pencil beam.
+;;; QUANTIZE-EXPFIELD allocates double-sized PBEAM-ARRAY to hold cached
+;;; raytrace lists [to be computed later].
+;;; PATHLENGTH-INTEGRATE does both density-weighted and homogeneous calcs
+;;; in single call [when necessary].
+;;; PBEAM array objects hold both collimator and patient coordinates rather
+;;; than using separate collections of PBEAM objects.
+;;; PBEAM, QNODE, and TILE object representation changed from strucures to
+;;; arrays, with inlined accessor.
+;;; Argument-passing and value-returning conventions altered for
+;;; PATHLENGTH-RAYTRACE and PATHLENGTH-INTEGRATE.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 26-Mar-2003 BobGian - fix bug in PBeam Col->Pat coordinate transformation.
+;;; 29-Aug-2003 BobGian - remove obsolete version number in change log header.
+;;; Instrument code with printouts for tracing dose calculation accuracy.
+;;; 03-Nov-2003 BobGian - more specific/meaningful names for some constants:
+;;; Exp-Width -> Cutout-Expand-Width
+;;; Step-Size -> Electron-Step-Size
+;;; 09-Nov-2003 BobGian - mark debugging code for deletion in production
+;;; version; reformat some comments and indentation.
+;;; 23-Mar-2004 BobGian - delete debugging code.
+;;; 12-Feb-2005 AMSimms - update SINGLE-FLOAT calls (an Allegro specific
+;;; coercion function) to use coerce esplicitly
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+;;; COMPUTE-ELECTRON-DOSE: Main electron dose calculation program
+;;;=============================================================
+
+(defun compute-electron-dose (bm bms pts gg organ-vertices-list
+ organ-z-extents organ-density-array)
+
+ "compute-electron-dose bm bms pts gg
+ organ-vertices-list organ-z-extents
+ organ-density-array
+
+computes the dose to each point in PTS, a list of points, and all
+points in the grid specified by GG, a GRID-GEOMETRY, for electron beam
+BM, stores the doses in the points and/or GRID attribute of the beam's
+DOSE-RESULT. One of PTS or GG should be NIL, the other non-NIL.
+Rest of args describe patient's anatomy (beam-independent).
+Returns T on success and NIL if unable to complete."
+
+ (declare (type (simple-array single-float 1) organ-density-array)
+ (type list bms pts organ-vertices-list organ-z-extents))
+
+ ;; The arrays below are all general [type T] as created by GET-OBJECT. They
+ ;; could be converted to (SIMPLE-ARRAY SINGLE-FLOAT 2) as later optimization,
+ ;; by a preprocessing step.
+
+ (let* ((mach (machine bm))
+ (dosedata (dose-data mach))
+ (num-beams (length bms))
+ (rslt (result bm)) ;Object holding result
+ (beam-name (name bm))
+ (beam-num (the fixnum (1+ (position bm bms :test #'eq))))
+ (g-sad (cal-distance mach)) ; geometric source-to-isocenter distance
+ (coll (collimator bm))
+ (cutout-list (vertices coll)) ; cutout vertices list
+ (energy-value (energy coll))
+ (e-index
+ (position energy-value (energies (collimator-info mach)) :test #'=))
+ ;; Virtual Source-to-Axis distance.
+ (v-sad (nth e-index (the list (vsad dosedata))))
+ (aperture-value (cone-size coll))
+ (app-index (position aperture-value
+ (cone-sizes (collimator-info mach))
+ :test #'=))
+ (appl-size (nth app-index (the list (applic-sizes dosedata))))
+ (init-energy (aref (the (simple-array t 2) (e0 dosedata))
+ e-index app-index)) ; initial energy
+ (rp-val (aref (the (simple-array t 2) (rp dosedata))
+ e-index app-index)) ; practical range
+ (theta-air-val
+ (* #.(sqrt 2.0) ; initial in-air spatial spread
+ (the single-float
+ (aref (the (simple-array t 2) (theta-air dosedata))
+ e-index app-index))))
+ (airgap-val (airgap dosedata)) ; air-gap between cutout and isocenter
+ (v-scd (- v-sad airgap-val)) ;virtual source to applicator distance
+ (tab (couch-angle bm)) ; couch table angle
+ (gan (gantry-angle bm)) ; gantry angle
+ (col (collimator-angle bm)) ; collimator angle
+
+ (r00 0.0) ;Terms of Collimator-to-Patient and
+ (r01 0.0) ;Patient-to-Collimator transform,
+ (r02 0.0) ;which are transposes of each other.
+ (r10 0.0) ;Terms indicated here are terms of Coll-to-Pat
+ (r11 0.0) ;transform. Terms of Pat-to-Coll transform
+ (r12 0.0) ;are identical but with subscripts after the
+ (r20 0.0) ;'R' reversed.
+ (r21 0.0)
+ (r22 0.0)
+
+ ;; FMCS parameters directly looked up and used immediately.
+ (fmcs (get-fmcs (aref (the (simple-array t 2) (f1 dosedata))
+ e-index app-index)
+ (aref (the (simple-array t 2) (f2 dosedata))
+ e-index app-index)
+ (aref (the (simple-array t 2) (z1 dosedata))
+ e-index app-index)
+ (aref (the (simple-array t 2) (z2 dosedata))
+ e-index app-index)
+ rp-val))
+ ;; In the patient coordinate system, the origin of the anatomy
+ ;; vertices coincides with the isocenter when the couch is in
+ ;; home position, therefore the isocenter is given by the following:
+ (iso-xp (- (the single-float (couch-lateral bm))))
+ (iso-yp (- (the single-float (couch-height bm))))
+ (iso-zp (- (the single-float (couch-longitudinal bm))))
+ (src-xp 0.0) (src-yp 0.0) (src-zp 0.0) ;geometric source coord in PC
+ ;; Pre-compute SPATIAL-SPREAD for water for given energy and Rp-Val.
+ (spatial-spread-vector (get-spatial-spread-vector init-energy rp-val))
+ ;; Local variables initialized and used below.
+ (rect-width 0.0)
+ (rect-height 0.0)
+ (g-ssd 0.0) ; geometric source-to-skin distance
+ (v-ssd 0.0) ; virtual source-to-skin distance
+ (v-spx 0.0) ; virtual source in PC
+ (v-spy 0.0)
+ (v-spz 0.0)
+ (pen-num 0)
+ (pbeam-array) ;Array of Pencil beams
+ (quadtiles) ;Array of quadtree tiles
+ (eflist '())
+ (flu2dose fmcs) ;Binding for declaration only
+ (rof 0.0) ;Relative Output Factor
+ (nquad 0) ;number of merged quad tiles
+ (erf-table *erf-table*) ;Lookup table
+ (arg-vec (make-array #.Argv-Size :element-type 'single-float)))
+
+ (declare (type single-float v-spx v-spy v-spz iso-xp iso-yp iso-zp
+ appl-size init-energy src-xp src-yp src-zp tab gan col
+ rect-width rect-height rof airgap-val theta-air-val
+ v-scd v-sad g-ssd v-ssd g-sad rp-val energy-value
+ aperture-value r00 r01 r02 r10 r11 r12 r20 r21 r22)
+ (type simple-base-string beam-name)
+ (type (simple-array single-float 1) fmcs flu2dose
+ spatial-spread-vector)
+ (type (simple-array single-float (#.Erf-Table-Size)) erf-table)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type list cutout-list eflist)
+ (type fixnum num-beams beam-num e-index app-index nquad pen-num))
+
+ (format t "~&~%Computing ~A dose for beam ~S (~D of ~D).~%"
+ (if pts "points" "grid") beam-name beam-num num-beams)
+
+ ;; Compute terms of the Collimator-to-Patient and Patient-to-Collimator
+ ;; transforms. These transforms, represented as matrices whose elements
+ ;; are the Rxx terms here, are transposes of each other. Therefore the
+ ;; same terms are used for both when inline expansions are used following.
+ ;; Be careful about which terms are which.
+ (let* ((trn-rad (* tab #.(coerce (/ pi 180.0d0) 'single-float)))
+ (gan-rad (* gan #.(coerce (/ pi 180.0d0) 'single-float)))
+ (col-rad (* col #.(coerce (/ pi 180.0d0) 'single-float)))
+ (sin-t (sin trn-rad))
+ (cos-t (cos trn-rad))
+ (sin-g (sin gan-rad))
+ (cos-g (cos gan-rad))
+ (sin-c (sin col-rad))
+ (cos-c (cos col-rad)))
+ (declare (type single-float gan-rad col-rad trn-rad sin-g cos-g
+ sin-c cos-c sin-t cos-t))
+ (setq r00 (+ (* cos-t cos-g cos-c)
+ (* sin-t sin-c)))
+ (setq r01 (- (* sin-t cos-c)
+ (* cos-t cos-g sin-c)))
+ (setq r02 (* cos-t sin-g))
+ (setq r10 (- (* sin-g cos-c)))
+ (setq r11 (* sin-g sin-c))
+ (setq r12 cos-g)
+ (setq r20 (- (* sin-t cos-g cos-c)
+ (* cos-t sin-c)))
+ (setq r21 (- (+ (* sin-t cos-g sin-c)
+ (* cos-t cos-c))))
+ (setq r22 (* sin-t sin-g)))
+
+ ;; Transform geometric source coord from coll to patient and offset
+ ;; by couch x-y-z shift.
+ (setq src-xp (+ (* r02 g-sad) iso-xp))
+ (setq src-yp (+ (* r12 g-sad) iso-yp))
+ (setq src-zp (+ (* r22 g-sad) iso-zp))
+
+ ;;-----------------------------------------------------------
+ ;; Determine central axis SSD. Do this early to find out if
+ ;; SSD for this patient is within the limits of allowable
+ ;; extended SSD. For now, maximum allowable SSD of 120 cm
+ ;; is assumed.
+ ;;-----------------------------------------------------------
+ ;; Find geometric distance from source to isocenter and to patient surface.
+ ;; Load argument vector for call to PATHLENGTH-RAYTRACE.
+ (let ((scale-factor (/ #.Pathlength-Ray-Maxlength g-sad)))
+ (declare (type single-float scale-factor))
+ (setf (aref arg-vec #.Argv-Src-X) src-xp)
+ (setf (aref arg-vec #.Argv-Src-Y) src-yp)
+ (setf (aref arg-vec #.Argv-Src-Z) src-zp)
+ (setf (aref arg-vec #.Argv-Dp-X)
+ (+ src-xp (* scale-factor (- iso-xp src-xp))))
+ (setf (aref arg-vec #.Argv-Dp-Y)
+ (+ src-yp (* scale-factor (- iso-yp src-yp))))
+ (setf (aref arg-vec #.Argv-Dp-Z)
+ (+ src-zp (* scale-factor (- iso-zp src-zp)))))
+
+ (let ((ray-alphalist
+ (pathlength-raytrace arg-vec organ-vertices-list organ-z-extents)))
+ (declare (type list ray-alphalist))
+
+ (unless (consp ray-alphalist)
+ (sl:acknowledge
+ (format nil "Central-Axis is outside patient in beam ~S (~D of ~D)."
+ beam-name beam-num num-beams))
+ (return-from compute-electron-dose nil))
+ (setq g-ssd (caar ray-alphalist)))
+
+ ;; Compute G-SSD, geometric source-to-skin distance, and check that it is
+ ;; within appropriate range. Assuming that we have %DD data up to 120-cm
+ ;; SSD, calculation request for SSD > 120 is rejected.
+ (when (or (< g-ssd #.Electron-SSD-Minlength)
+ (> g-ssd #.Electron-SSD-Maxlength))
+ (sl:acknowledge
+ (list (format nil "Geometric SSD (~F) is outside ~F to ~F cm."
+ g-ssd #.Electron-SSD-Minlength #.Electron-SSD-Maxlength)
+ (format nil "In beam ~S (~D of ~D)."
+ beam-name beam-num num-beams)))
+ (return-from compute-electron-dose nil))
+
+ ;; Compute V-SSD, virtual source-to-skin distance, along central axis.
+ (setq v-ssd (+ v-sad (- g-ssd g-sad)))
+
+ ;; Check that cutout is within applicator dimensions.
+ (let ((sz (* 0.5 appl-size)))
+ (declare (type single-float sz))
+ (dolist (vert cutout-list)
+ (when (or (> (the single-float (abs (the single-float (first vert))))
+ sz)
+ (> (the single-float (abs (the single-float (second vert))))
+ sz))
+ (sl:acknowledge
+ (format nil
+ "Cutout is too big for applicator in beam ~S (~D of ~D)."
+ beam-name beam-num num-beams))
+ (return-from compute-electron-dose nil))))
+
+ ;; Pre-compute fluence-to-dose calibration factor.
+ ;; Reload virtual source instead of geometric source coordinates.
+ ;; Terms are virtual source coordinates transformed from collimator
+ ;; to patient coordinate system.
+ (setf (aref arg-vec #.Argv-Src-X) 0.0) ; virtual src in PC
+ (setf (aref arg-vec #.Argv-Src-Y) v-sad)
+ (setf (aref arg-vec #.Argv-Src-Z) 0.0)
+
+ ;; Find equivalent rectangle.
+ ;; Algorithm is not accurate unless cutout has minimum dimension
+ ;; (smaller of width/length) of at least 2 cm. Punt otherwise.
+ ;; Max dimension CAN be larger than applicator size, as for a diagonal
+ ;; cutout shape whose max dimension exceeds applicator edge length.
+ (multiple-value-setq (rect-width rect-height)
+ (find-equiv-rect cutout-list))
+
+ (when (or (< rect-width #.Cutout-Min-Size)
+ (< rect-height #.Cutout-Min-Size))
+ (sl:acknowledge
+ (format nil "Cutout is too small for applicator in beam ~S (~D of ~D)."
+ beam-name beam-num num-beams))
+ (return-from compute-electron-dose nil))
+
+ ;; FLU2DOSE interpolation, once RECT-WIDTH and RECT-HEIGHT are available.
+ (setq flu2dose (depth-dose-interp (dd-tables dosedata)
+ energy-value aperture-value g-ssd
+ rect-width rect-height))
+
+ (setq rof (rof-interp (rof-tables dosedata)
+ energy-value aperture-value
+ g-ssd rect-width rect-height))
+
+ ;; Halve equivalent-rectangle dimensions for QUANTIZE-EFIELD and SAIR-RECT.
+ (setq rect-width (* rect-width 0.5)
+ rect-height (* rect-height 0.5))
+
+ ;; Quantize equivalent rectangle field [using half-width and half-height].
+ (multiple-value-setq (pen-num pbeam-array)
+ (quantize-efield (list (list rect-width rect-height)
+ (list (- rect-width) rect-height)
+ (list (- rect-width) (- rect-height))
+ (list rect-width (- rect-height)))
+ appl-size airgap-val arg-vec))
+
+ ;; Transform pencil-beam coordinates from collimator to patient frame.
+ (do ((ip 0 (the fixnum (1+ ip)))
+ (pb-obj))
+ ((= ip pen-num))
+ (declare (type fixnum ip))
+ (setq pb-obj (aref (the (simple-array t 1) pbeam-array) ip))
+ (setf (pbeam-xp (the (simple-array single-float (7)) pb-obj))
+ (pbeam-xc (the (simple-array single-float (7)) pb-obj)))
+ (setf (pbeam-yp (the (simple-array single-float (7)) pb-obj))
+ (pbeam-zc (the (simple-array single-float (7)) pb-obj)))
+ (setf (pbeam-zp (the (simple-array single-float (7)) pb-obj))
+ (- (the single-float
+ (pbeam-yc (the (simple-array single-float (7)) pb-obj))))))
+
+ ;; For every depth (in CC system) renormalize FLU2DOSE [except for entry
+ ;; in slot 0 which remains 0.0]. Stop when depth exceeds Rp-Val for pencil
+ ;; beam along central axis. If depth for other pencil beams exceeds Rp-Val
+ ;; before stopping iteration [due to slant depth], extrapolate with last
+ ;; valid value.
+ (do ((czz #.(- Electron-Step-Size) (- czz #.Electron-Step-Size))
+ (proj-0-factor (/ v-sad v-scd)) ;Projection factor for depth zero.
+ (idx 1 (the fixnum (1+ idx))) ; FLU2DOSE array index <-> depth
+ (depth-lim (- rp-val)))
+ ((< czz depth-lim))
+
+ (declare (type single-float czz proj-0-factor depth-lim)
+ (type fixnum idx))
+
+ ;; Ray-trace through virtual phantom from virtual source to calc plane
+ ;; along pencil-beam axis to get depth in phantom (in PC). Normalization
+ ;; is to density = 1.0 water phantom extending over semi-infinite region
+ ;; of space [ie, all space for which Y coord (PC) <= 0.0 .
+ (do ((ip 0 (the fixnum (1+ ip)))
+ (pb-obj)
+ (proj-factor (/ (- v-sad czz) v-scd))
+ (pbcx 0.0) (pbcy 0.0) ;Pencil Beam Collimator X/Y.
+ (projpx 0.0) (projpy 0.0) (projpz 0.0) ;Patient coordinates.
+ (total-fluence 0.0)
+ (unitdepth 0.0) ; Used as local scratch var.
+ (sigma-rms 0.0)) ; Used as spatial spread parameter.
+ ((= ip pen-num)
+ (when (> total-fluence 0.0)
+ (setf (aref flu2dose idx)
+ (/ (the single-float (aref flu2dose idx)) total-fluence))))
+
+ (declare (type single-float pbcx pbcy unitdepth sigma-rms
+ projpx projpy projpz proj-factor total-fluence)
+ (type fixnum ip))
+
+ (setq pb-obj (aref (the (simple-array t 1) pbeam-array) ip)
+ pbcx (pbeam-xc (the (simple-array single-float (7)) pb-obj))
+ pbcy (pbeam-yc (the (simple-array single-float (7)) pb-obj)))
+
+ ;; Find pencil-beam axis coordinates at calc plane in PC.
+ (setq projpx (* pbcx proj-factor))
+ (setq projpy czz)
+ (setq projpz (- (* pbcy proj-factor)))
+
+ (setq unitdepth (3d-distance
+ (* pbcx proj-0-factor) ;Ray projected to virtual
+ 0.0 ;phantom surface.
+ (- (* pbcy proj-0-factor))
+ projpx projpy projpz)) ;Ray projected to calc plane.
+
+ ;; Look up SIGMA-RMS and FMCS. UNITDEPTH must be > 0.0 because
+ ;; iteration starts at depth Electron-Step-Size.
+ (when (> unitdepth rp-val)
+ ;; If slant depth for this pencil beam exceeds Rp-Val, extrapolate
+ ;; using fluence value for Rp-Val.
+ (setq unitdepth rp-val))
+
+ (let ((d (the fixnum
+ (round (the single-float
+ (* unitdepth #.(/ 1.0 Electron-Step-Size)))))))
+ (declare (type fixnum d))
+ (setq sigma-rms (* (the single-float (aref spatial-spread-vector d))
+ (the single-float (aref fmcs d)))))
+
+ ;; Calc pt is within 6 SIGMA-RMS [RMS units] of lateral distance
+ ;; between pencil axis and calc point. Distance squared being compared
+ ;; to threshold squared. <= changed to < comparison to exclude case
+ ;; of SIGMA-RMS = 0.0, causing div-by-zero in RFLUENCE.
+ (when (< (+ (sqr-float (* pbcx proj-factor))
+ (sqr-float (* pbcy proj-factor)))
+ (* 36.0 sigma-rms sigma-rms))
+
+ ;; Accumulate fluence - Fast rect method.
+ (incf
+ total-fluence
+ (* (the single-float
+ (sair-rect
+ rect-width ; Find Sair in CC
+ rect-height
+ pbcx
+ pbcy
+ (3d-distance
+ (pbeam-xp (the (simple-array single-float (7)) pb-obj))
+ (pbeam-yp (the (simple-array single-float (7)) pb-obj))
+ (pbeam-zp (the (simple-array single-float (7)) pb-obj))
+ projpx projpy projpz)
+ theta-air-val
+ proj-factor
+ erf-table))
+ ;; Find CAX rfluence in cc.
+ (the single-float
+ (rfluence
+ pbcx pbcy
+ (pbeam-wt (the (simple-array single-float (7)) pb-obj))
+ 0.0 0.0 sigma-rms proj-factor erf-table)))))))
+
+ ;; Compute dose for user specified field. Transform virtual source
+ ;; coordinates from coll to patient and offset by couch x-y-z shift.
+ ;; Load virtual source coords for calls to follow.
+ (setf (aref arg-vec #.Argv-Src-X) (setq v-spx (+ (* r02 v-sad) iso-xp)))
+ (setf (aref arg-vec #.Argv-Src-Y) (setq v-spy (+ (* r12 v-sad) iso-yp)))
+ (setf (aref arg-vec #.Argv-Src-Z) (setq v-spz (+ (* r22 v-sad) iso-zp)))
+
+ ;; Expand cutout-list and quantize into pencil beams.
+ (multiple-value-setq (pen-num pbeam-array eflist)
+ (quantize-expfield cutout-list
+ (+ appl-size #.Cutout-Expand-Width)
+ airgap-val arg-vec))
+
+ ;; Transform pencil-beam coordinates from collimator to patient frame.
+ (do ((ip 0 (the fixnum (+ ip 2)))
+ (pb-obj)
+ (pb-x 0.0) (pb-y 0.0) (pb-z 0.0))
+ ((= ip pen-num))
+ (declare (type single-float pb-x pb-y pb-z)
+ (type fixnum ip))
+ (setq pb-obj (aref (the (simple-array t 1) pbeam-array) ip)
+ pb-x (pbeam-xc (the (simple-array single-float (7)) pb-obj))
+ pb-y (pbeam-yc (the (simple-array single-float (7)) pb-obj))
+ pb-z (pbeam-zc (the (simple-array single-float (7)) pb-obj)))
+ (setf (pbeam-xp (the (simple-array single-float (7)) pb-obj))
+ (+ (* r00 pb-x) (* r01 pb-y) (* r02 pb-z) iso-xp))
+ (setf (pbeam-yp (the (simple-array single-float (7)) pb-obj))
+ (+ (* r10 pb-x) (* r11 pb-y) (* r12 pb-z) iso-yp))
+ (setf (pbeam-zp (the (simple-array single-float (7)) pb-obj))
+ (+ (* r20 pb-x) (* r21 pb-y) (* r22 pb-z) iso-zp)))
+
+ ;; Construct the root node structure.
+ (let ((qtree (make-qnode 0.0 0.0 (+ appl-size #.Cutout-Expand-Width))))
+
+ ;; Generate quadtree representation of expanded electron field EFLIST.
+ (quadtree
+ qtree ; base node
+ (cond ((< appl-size 0.0) ; node resolution
+ (error "COMPUTE-ELECTRON-DOSE [1] Negative applicator size: ~S"
+ appl-size))
+ ((<= appl-size 8.0) 32)
+ ((<= appl-size 25.0) 64)
+ (t (error "COMPUTE-ELECTRON-DOSE [2] Applicator too big: ~S"
+ appl-size)))
+ eflist arg-vec)
+
+ ;; Count number of merged nodes to determine the exact dimension
+ ;; of quadtile structure array.
+ (setq quadtiles (make-array (count-qnodes qtree)
+ :element-type t :initial-element nil))
+
+ ;; Traverse tree to tabulate survivors.
+ (setq nquad (traverse-tree qtree quadtiles 0)))
+
+ ;; Now ready to iterate over the points list or the dose grid.
+ (when (consp pts)
+ (setf (points rslt)
+ (mapcar #'(lambda (pt)
+ (* rof
+ (the single-float
+ (electron-dose
+ (x pt) (y pt) (z pt) v-spx v-spy v-spz v-sad
+ v-scd v-ssd r00 r01 r02 r10 r11 r12 r20 r21 r22
+ rp-val init-energy theta-air-val pen-num
+ pbeam-array cutout-list fmcs flu2dose
+ organ-vertices-list organ-z-extents
+ organ-density-array iso-xp iso-yp iso-zp
+ quadtiles nquad erf-table arg-vec))))
+ pts)))
+
+ (when gg
+ (let* ((nx (x-dim gg))
+ (ny (y-dim gg))
+ (nz (z-dim gg))
+ (xp-step (/ (the single-float (x-size gg))
+ (coerce (the fixnum (1- nx)) 'single-float)))
+ (yp-step (/ (the single-float (y-size gg))
+ (coerce (the fixnum (1- ny)) 'single-float)))
+ (zp-step (/ (the single-float (z-size gg))
+ (coerce (the fixnum (1- nz)) 'single-float)))
+ (dose-array (grid rslt)))
+ (declare (type (simple-array single-float 3) dose-array)
+ (type single-float xp-step yp-step zp-step)
+ (type fixnum nx ny nz))
+ (do ((x-idx 0 (the fixnum (1+ x-idx)))
+ (xp (x-origin gg) (+ xp xp-step))
+ (y-orig (y-origin gg))
+ (z-orig (z-origin gg)))
+ ((= x-idx nx))
+ (declare (type single-float xp y-orig z-orig)
+ (type fixnum x-idx))
+ (format t "~&Beam ~D of ~D, Plane ~D of ~D.~%"
+ beam-num num-beams (the fixnum (1+ x-idx)) nx)
+ (do ((y-idx 0 (the fixnum (1+ y-idx)))
+ (yp y-orig (+ yp yp-step)))
+ ((= y-idx ny))
+ (declare (type single-float yp)
+ (type fixnum y-idx))
+ (do ((z-idx 0 (the fixnum (1+ z-idx)))
+ (zp z-orig (+ zp zp-step)))
+ ((= z-idx nz))
+ (declare (type single-float zp)
+ (type fixnum z-idx))
+ (setf (aref dose-array x-idx y-idx z-idx)
+ (* rof
+ (the single-float
+ (electron-dose
+ xp yp zp v-spx v-spy v-spz v-sad v-scd v-ssd r00
+ r01 r02 r10 r11 r12 r20 r21 r22 rp-val init-energy
+ theta-air-val pen-num pbeam-array cutout-list fmcs
+ flu2dose organ-vertices-list organ-z-extents
+ organ-density-array iso-xp iso-yp iso-zp
+ quadtiles nquad erf-table arg-vec)))))))))
+
+ (setf (ssd rslt) g-ssd)
+ (setf (output-comp rslt) rof))
+
+ ;; Return T if computation completes successfully. If something goes wrong,
+ ;; function returns early with NIL indicating failure. Return value sets
+ ;; VALID-POINTS/VALID-GRID flags on return.
+ t)
+
+;;;-------------------------------------------------------------
+;;; ELECTRON-DOSE: compute electron dose to a single point
+;;;-------------------------------------------------------------
+;;; (Px, Py, Pz) = dose point coordinates in patient geometry
+;;;-------------------------------------------------------------
+
+(defun electron-dose (px py pz v-spx v-spy v-spz v-sad v-scd v-ssd r00 r01 r02
+ r10 r11 r12 r20 r21 r22 rp-val init-energy theta-air-val
+ pen-num pbeam-array cutout-list fmcs flu2dose
+ organ-vertices-list organ-z-extents organ-density-array
+ iso-xp iso-yp iso-zp quadtiles nquad erf-table arg-vec
+ &aux (cx 0.0) (cy 0.0) (cz 0.0) (cz2 0.0)
+ (proj-factor 0.0) (total-dose 0.0))
+
+ "electron-dose px py pz v-spx v-spy v-spz v-sad v-scd v-ssd
+ r00 r01 r02 r10 r11 r12 r20 r21 r22
+ rp-val init-energy theta-air-val pen-num
+ pbeam-array cutout-list fmcs flu2dose
+ organ-vertices-list organ-z-extents organ-density-array
+ iso-xp iso-yp iso-zp
+ quadtiles nquad erf-table arg-vec
+
+computes electron dose to a single point px py pz."
+
+ ;; Px Py Pz = calc point in patient coordinate system
+ ;; init-energy = initial energy of the beam (not nominal E)
+ ;; Rp-Val = practical range of the beam
+ ;; unitplen = unit pathlength (geometric distance) between skin and calc pt
+ ;; V-SPxyz = virtual source position in PC
+ ;; projPxyz = pencil beam coordinates projected onto calc depth in PC
+
+ (declare (type single-float px py pz cx cy cz v-spx v-spy v-spz v-sad v-scd
+ v-ssd init-energy rp-val theta-air-val iso-xp iso-yp iso-zp
+ proj-factor cz2 total-dose r00 r01 r02 r10 r11 r12 r20 r21 r22)
+ (type (simple-array single-float 1) fmcs flu2dose)
+ (type (simple-array t 1) pbeam-array quadtiles)
+ (type (simple-array single-float (#.Erf-Table-Size)) erf-table)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type list organ-vertices-list organ-z-extents)
+ (type (simple-array single-float 1) organ-density-array)
+ (type list cutout-list)
+ (type fixnum nquad pen-num))
+
+ ;; Transform dose point coordinates from patient to coll.
+ ;; (Px, Py, Pz) -> (Cx, Cy, Cz)
+ (let ((pp-x (- px iso-xp))
+ (pp-y (- py iso-yp))
+ (pp-z (- pz iso-zp)))
+ (declare (type single-float pp-x pp-y pp-z))
+ (setq cx (+ (* r00 pp-x) ; calc point in collimator coordinate system
+ (* r10 pp-y)
+ (* r20 pp-z)))
+ (setq cy (+ (* r01 pp-x)
+ (* r11 pp-y)
+ (* r21 pp-z)))
+ (setq cz (+ (* r02 pp-x)
+ (* r12 pp-y)
+ (* r22 pp-z)))
+ (setq cz2 (+ cz (- v-ssd v-sad)))) ;calc depth rel to CAX-skin intersec
+
+ ;; Find projection factor for this calc depth.
+ (setq proj-factor (/ (- v-sad cz) v-scd))
+
+ ;;For every pencil beam repeat
+ (do ((ip 0 (the fixnum (+ ip 2)))
+ (pb-obj)
+ (pbcx 0.0) ;Pencil Beam Collimator X coord.
+ (pbcy 0.0) ;Pencil Beam Collimator X coord.
+ (projpx 0.0) ;Projected pencil beam
+ (projpy 0.0) ;coordinates in Patient coords.
+ (projpz 0.0)
+ (zeff 0.0) ;Effective depth for pencil.
+ (unitplen 0.0) ;Unit path length along pencil.
+ (ray-alphalist nil)
+ (spatial-spread 0.0))
+ ((= ip pen-num))
+
+ (declare (type single-float pbcx pbcy projpx projpy projpz zeff
+ unitplen spatial-spread)
+ (type fixnum ip))
+
+ (setq pb-obj (aref pbeam-array ip)
+ pbcx (pbeam-xc (the (simple-array single-float (7)) pb-obj))
+ pbcy (pbeam-yc (the (simple-array single-float (7)) pb-obj)))
+
+ ;; Find pencil-beam axis coordinates at calc plane in PC.
+ (let ((pp-x (* pbcx proj-factor))
+ (pp-y (* pbcy proj-factor)))
+ (declare (type single-float pp-x pp-y))
+ (setq projpx (+ (* r00 pp-x) (* r01 pp-y) (* r02 cz) iso-xp))
+ (setq projpy (+ (* r10 pp-x) (* r11 pp-y) (* r12 cz) iso-yp))
+ (setq projpz (+ (* r20 pp-x) (* r21 pp-y) (* r22 cz) iso-zp)))
+
+ ;; Ray-trace through anatomy from virtual source to calc plane along
+ ;; pencil-beam axis to get depth in patient (in PC). Source coordinates
+ ;; were loaded before call to ELECTRON-DOSE.
+ (let ((scale-factor
+ (/ #.Pathlength-Ray-Maxlength
+ (setf (aref arg-vec #.Argv-Raylen)
+ (3d-distance v-spx v-spy v-spz projpx projpy projpz))))
+ (ray-idx (the fixnum (1+ ip))))
+ (declare (type single-float scale-factor)
+ (type fixnum ray-idx))
+ (unless (listp (setq ray-alphalist (aref pbeam-array ray-idx)))
+ (setf (aref arg-vec #.Argv-Dp-X)
+ (+ v-spx (* scale-factor (- projpx v-spx))))
+ (setf (aref arg-vec #.Argv-Dp-Y)
+ (+ v-spy (* scale-factor (- projpy v-spy))))
+ (setf (aref arg-vec #.Argv-Dp-Z)
+ (+ v-spz (* scale-factor (- projpz v-spz))))
+ (setf (aref pbeam-array ray-idx)
+ (setq ray-alphalist
+ (pathlength-raytrace arg-vec
+ organ-vertices-list
+ organ-z-extents)))))
+
+ ;; RAY-ALPHALIST must be CONSP in order to integrate, and
+ ;; PATHLENGTH-INTEGRATE returns T to indicate dosepoint-in-body.
+ (cond ((and (consp ray-alphalist)
+ (pathlength-integrate arg-vec ray-alphalist
+ organ-density-array :Both))
+ (setq unitplen (aref arg-vec #.Argv-Return-0))
+ (setq zeff (aref arg-vec #.Argv-Return-1)))
+ (t (setq unitplen 0.0)
+ (setq zeff 0.0)))
+
+ ;; Make sure pencil beam is in patient and not deeper than Rp-Val.
+ (when (and (> zeff 0.0) ; Find SPATIAL-SPREAD in PC
+ (<= zeff rp-val))
+ (let ((z-index (the fixnum
+ (round (the single-float
+ (* zeff #.(/ 1.0 Electron-Step-Size)))))))
+ (declare (type fixnum z-index))
+ (setq spatial-spread
+ (* (the single-float (aref fmcs z-index))
+ (the (single-float 0.0 *)
+ ;; Compute spatial spread parameter for inhomogeneity.
+ (sqrt
+ (the (single-float 0.0 *)
+ (cond
+ ((< unitplen #.Electron-Step-Size)
+ (* unitplen unitplen unitplen
+ (the single-float
+ (spower unitplen init-energy rp-val))))
+
+ ;; Integrate in 1-mm increments. Find skin distance.
+ (t (let* ((xdiff (- projpx v-spx))
+ (ydiff (- projpy v-spy))
+ (zdiff (- projpz v-spz))
+ (dtot (the (single-float 0.0 *)
+ (sqrt (the (single-float 0.0 *)
+ (+ (* xdiff xdiff)
+ (* ydiff ydiff)
+ (* zdiff zdiff)))))))
+
+ (declare (type single-float xdiff ydiff
+ zdiff dtot))
+
+ ;; Ray tracing loop.
+ (do ((zeta ;Source to skin along pencil-beam axis
+ (+ (- dtot unitplen) #.Electron-Step-Size)
+ (+ zeta #.Electron-Step-Size))
+ (zz 0.0)
+ (rstop 0.0) ;stopping power ratio
+ (rscat 0.0) ;scattering power ratio
+ (deff 0.0) ;effective pathlength
+ (org-density 0.0)
+ (sigma-rms 0.0))
+ ((> zeta dtot)
+ sigma-rms)
+
+ (declare (type single-float zeta zz rstop rscat
+ deff org-density sigma-rms))
+
+ (do ((alpha-pairlist ray-alphalist
+ (cdr alpha-pairlist))
+ (alpha-item) (strctr-tag 0)
+ (strctr-stack (list 0))
+ (strctr-tag-pop 0))
+ ((null alpha-pairlist)
+ ;; Pencil-beam missed patient.
+ ;; Treat as air [density = 0.0].
+ (setq org-density 0.0))
+ (declare (type list alpha-pairlist alpha-item
+ strctr-stack)
+ (type fixnum strctr-tag
+ strctr-tag-pop))
+ (setq alpha-item (car alpha-pairlist)
+ strctr-tag (cdr alpha-item)
+ strctr-tag-pop (car strctr-stack))
+
+ (cond
+ ((< (the single-float (car alpha-item))
+ zeta)
+ (cond
+ ((= strctr-tag strctr-tag-pop)
+ (setq strctr-stack (cdr strctr-stack)))
+ (t (push strctr-tag strctr-stack))))
+ (t (setq org-density
+ (aref organ-density-array
+ strctr-tag-pop))
+ (return))))
+
+ ;; For a given tissue density compute
+ ;; scattering and stopping powers relative
+ ;; to water. NOTE that fatal error occurs
+ ;; if organ density is outside [0.0,2.0]. Data
+ ;; points from ICRU-21, ICRP-23 and ICRU-35.
+ ;; Performs piecewise linear interpolation.
+ ;; BUILD-PATIENT-STRUCTURES range-checked
+ ;; ORG-DENSITY, and it cannot be negative, but
+ ;; computation is allowed with value exceeding
+ ;; positive bound, extrapolating by using
+ ;; parameter values for highest density..
+ (cond
+ ((< org-density 0.0)
+ (error
+ "ELECTRON-DOSE [1] ORG-DENSITY negative: ~S"
+ org-density))
+
+ ((< org-density 0.33)
+ (setq rstop (+ (* 0.938757576 org-density)
+ 0.00121)
+ rscat (+ (* 0.881181818 org-density)
+ 0.00121)))
+
+ ((< org-density 1.0)
+ (setq rstop (- (* 1.028358209 org-density)
+ 0.028358209)
+ rscat (- (* 1.056716418 org-density)
+ 0.056716418)))
+
+ ((<= org-density 1.04)
+ (setq rstop (- (* 1.275 org-density) 0.275)
+ rscat org-density))
+
+ ((<= org-density 1.85)
+ (setq rstop (+ (* 0.77654321 org-density)
+ 0.243395062)
+ rscat (- (* 1.962962963 org-density)
+ 1.001481481)))
+
+ (t (setq rstop (- (* 1.5 org-density)
+ 1.095)
+ rscat (- (* 1.785714286 org-density)
+ 0.673571429))))
+
+ ;; Compute effective pathlength based
+ ;; on stopping power.
+ (incf deff (* #.Electron-Step-Size rstop))
+ ;; Compute energy and feed into SPOWER which
+ ;; computes scattering power for water, then
+ ;; scale for inhomogeneity.
+ (setq zz (- zeta dtot))
+ (incf sigma-rms
+ (* rscat
+ (the single-float
+ (spower deff init-energy rp-val))
+ #.Electron-Step-Size
+ (+ (* zz zz)
+ (* #.Electron-Step-Size zz)
+ #.(/ (* Electron-Step-Size
+ Electron-Step-Size)
+ 3.0)))))))))))))
+
+ ;; If calc point is within 6 SPATIAL-SPREAD [RMS units] ... Distance
+ ;; squared being compared to threshold squared. Predicate <= changed
+ ;; to < comparison to exclude case of SPATIAL-SPREAD = 0.0, causing
+ ;; div-by-zero error in RFLUENCE.
+ (when (< (+ (sqr-float (- (* pbcx proj-factor) cx))
+ (sqr-float (- (* pbcy proj-factor) cy)))
+ (* 36.0 spatial-spread spatial-spread))
+ ;; Find slanted pencil ray distance in air between cutout
+ ;; and calc point and accumulate fluence.
+ (incf total-dose
+ (* (the single-float
+ (sair nquad quadtiles pbcx pbcy
+ (3d-distance
+ (pbeam-xp
+ (the (simple-array single-float (7)) pb-obj))
+ (pbeam-yp
+ (the (simple-array single-float (7)) pb-obj))
+ (pbeam-zp
+ (the (simple-array single-float (7)) pb-obj))
+ projpx projpy projpz)
+ theta-air-val proj-factor erf-table))
+ (the single-float
+ (rfluence
+ pbcx pbcy
+ (pbeam-wt (the (simple-array single-float (7)) pb-obj))
+ cx cy spatial-spread proj-factor erf-table))
+ (the single-float (aref flu2dose z-index))
+ (/ (sqr-float (+ v-ssd zeff))
+ (sqr-float (- v-ssd cz2)))))))))
+
+ ;;------------------------------------------------------------
+ ;; If calc pt is beyond the depth of Rp
+ ;; -AND- within the unexpanded geometric field boundary
+ ;; -AND- if integrated electron/photon dose is less than gamma
+ ;; tail dose, use gamma tail dose instead.
+ ;;------------------------------------------------------------
+ (let ((scale-factor (/ #.Pathlength-Ray-Maxlength
+ (setf (aref arg-vec #.Argv-Raylen)
+ (3d-distance v-spx v-spy v-spz px py pz))))
+ (effect-depth 0.0) (ray-alphalist))
+
+ (declare (type single-float scale-factor effect-depth)
+ (type list ray-alphalist))
+
+ ;; Source coordinates were loaded before call to ELECTRON-DOSE.
+ (setf (aref arg-vec #.Argv-Dp-X) (+ v-spx (* scale-factor (- px v-spx))))
+ (setf (aref arg-vec #.Argv-Dp-Y) (+ v-spy (* scale-factor (- py v-spy))))
+ (setf (aref arg-vec #.Argv-Dp-Z) (+ v-spz (* scale-factor (- pz v-spz))))
+
+ ;; RAY-ALPHALIST must be CONSP in order to integrate, and
+ ;; PATHLENGTH-INTEGRATE returns T to indicate dosepoint-in-body.
+ (cond
+ ((and (consp (setq ray-alphalist
+ (pathlength-raytrace arg-vec organ-vertices-list
+ organ-z-extents)))
+ (pathlength-integrate arg-vec ray-alphalist
+ organ-density-array :Heterogeneous))
+
+ (when (> (setq effect-depth (aref arg-vec #.Argv-Return-1)) rp-val)
+ (setf (aref arg-vec #.Argv-Enc-X) (/ cx proj-factor))
+ (setf (aref arg-vec #.Argv-Enc-Y) (/ cy proj-factor))
+ (when (encloses? cutout-list arg-vec)
+ (let ((flu2dose-index
+ (the fixnum
+ (round (the single-float
+ (* effect-depth #.(/ 1.0 Electron-Step-Size))))))
+ (depth-lim (array-total-size flu2dose)))
+ (declare (type fixnum flu2dose-index depth-lim))
+ (unless (< flu2dose-index depth-lim)
+ (setq flu2dose-index (the fixnum (1- depth-lim))))
+ (let ((photon-dose (aref flu2dose flu2dose-index)))
+ (declare (type single-float photon-dose))
+ (when (> photon-dose total-dose)
+ (setq total-dose photon-dose)))))))
+
+ (t (setq total-dose 0.0))))
+
+ total-dose)
+
+;;;=============================================================
+;;; FIND-EQUIV-RECT: find equivalent rectangle
+;;;=============================================================
+
+(defun find-equiv-rect (vlist)
+
+ (declare (type list vlist))
+
+ (let ((w1 0.0)
+ (w2 0.0)
+ (box-area 0.0)
+ (new-area 0.0)
+ (blist (poly:bounding-box vlist))
+ (blist-1) (blist-1-1 0.0) (blist-1-2 0.0)
+ (blist-2) (blist-2-1 0.0) (blist-2-2 0.0))
+
+ (declare (type list blist blist-1 blist-2)
+ (type single-float w1 w2 box-area new-area blist-1-1
+ blist-1-2 blist-2-1 blist-2-2))
+
+ (setq blist-1 (first blist)
+ blist-1-1 (first blist-1)
+ blist-1-2 (second blist-1)
+ blist-2 (second blist)
+ blist-2-1 (first blist-2)
+ blist-2-2 (second blist-2))
+
+ ;; Find the area of initial bounding-box.
+ (setq box-area (* (- blist-1-1 blist-2-1)
+ (- blist-1-2 blist-2-2)))
+ (setq w1 (the single-float (abs (- blist-1-1 blist-2-1)))
+ w2 (the single-float (abs (- blist-1-2 blist-2-2))))
+
+ ;; Rotate the contour to minimize the area of the bounding-box.
+ (do ((angle 1.0 (+ angle 1.0))
+ (w1tmp 0.0)
+ (w2tmp 0.0))
+ ((> angle 180.0))
+ (declare (type single-float angle w1tmp w2tmp))
+ (setq blist (poly:bounding-box (poly:rotate-vertices vlist angle))
+ blist-1 (first blist)
+ blist-1-1 (first blist-1)
+ blist-1-2 (second blist-1)
+ blist-2 (second blist)
+ blist-2-1 (first blist-2)
+ blist-2-2 (second blist-2))
+ (setq w1tmp (- blist-1-1 blist-2-1))
+ (setq w2tmp (- blist-1-2 blist-2-2))
+ (setq new-area (the single-float (abs (* w1tmp w2tmp))))
+ (when (< new-area box-area)
+ (setq box-area new-area
+ w1 (the single-float (abs w1tmp))
+ w2 (the single-float (abs w2tmp)))))
+
+ ;; Estimate the equivalent rectangle as follows:
+ ;; (1) len = the length of the bounding box
+ ;; (2) wid = (area of electron field) / len
+ (let ((electron-field-area (poly:area-of-polygon vlist))
+ (len (max w1 w2)))
+ (declare (type single-float electron-field-area len))
+ (values (/ electron-field-area len) len))))
+
+;;;-------------------------------------------------------------
+;;; SAIR: Find integrated fluence along the pencil beam axis
+;;;-------------------------------------------------------------
+;;; Input: Nq = number of quadtree tiles
+;;; pbcx = pencil beam collimator X coord
+;;; pbcy = pencil beam collimator Y coord
+;;; Zd = distance between the pencil-beam source at the
+;;; coutout plane and calc point
+;;; theta-Air-val = in-air spatial spread parameter
+;;; proj-factor = projection factor
+;;; erf-table = error function table
+;;;-------------------------------------------------------------
+
+(defun sair (nquad quadtiles pbcx pbcy zd theta-air-val proj-factor erf-table)
+
+ "sair nquad quadtiles pbcx pbcy zd theta-air-val proj-factor erf-table
+
+returns integrated fluence along the pencil beam axis (the inner sum)
+input: nquad = number of quadtree tiles
+ quadtiles = array of quadtree tiles
+ pbcx = pencil beam collimator X coord
+ pbcy = pencil beam collimator Y coord
+ zd = distance between the pencil-beam source at the
+ cutout plane and calc point
+ theta-air-val = in-air spatial spread parameter
+ proj-factor = projection factor."
+
+ (declare (type single-float pbcx pbcy zd theta-air-val proj-factor)
+ (type (simple-array t 1) quadtiles)
+ (type (simple-array single-float (#.Erf-Table-Size)) erf-table)
+ (type fixnum nquad))
+
+ (let ((sigma-air (* theta-air-val zd))
+ (tile-size 0.0)
+ (x-pos 0.0)
+ (y-pos 0.0)
+ (a 0.0)
+ (b 0.0)
+ (c 0.0)
+ (d 0.0)
+ (accum 0.0))
+
+ (declare (type single-float sigma-air tile-size x-pos y-pos a b c d accum))
+
+ (do ((idx 0 (the fixnum (1+ idx))))
+ ((= idx nquad)
+ (* 0.25 accum))
+ (declare (type fixnum idx))
+ (let ((tile-obj (aref quadtiles idx)))
+ (declare (type (simple-array single-float (3)) tile-obj))
+ (setq tile-size (tile-dimension tile-obj)
+ x-pos (tile-xpos tile-obj)
+ y-pos (tile-ypos tile-obj)))
+
+ (setq a (/ (* proj-factor (- (+ x-pos tile-size) pbcx)) sigma-air)
+ b (/ (* proj-factor (- (- x-pos tile-size) pbcx)) sigma-air)
+ c (/ (* proj-factor (- (+ y-pos tile-size) pbcy)) sigma-air)
+ d (/ (* proj-factor (- (- y-pos tile-size) pbcy)) sigma-air))
+
+ (incf accum
+ (the single-float
+ (* (- (the single-float (error-function a erf-table))
+ (the single-float (error-function b erf-table)))
+ (- (the single-float (error-function c erf-table))
+ (the single-float (error-function d erf-table)))))))))
+
+;;;-------------------------------------------------------------
+;;; SAIR-RECT: A fast version of SAIR for rectangular field
+;;;-------------------------------------------------------------
+;;; Input: w1half = half width
+;;; w2half = half height
+;;; pbcx, pbcy = pencil beam axis coordinates in collimator system
+;;; Zd = distance between the pencil-beam source at the
+;;; coutout plane and calc point
+;;; theta-Air-val = in-air spatial spread parameter
+;;; proj-factor = projection factor
+;;; erf-table = error function table
+;;;-------------------------------------------------------------
+
+(defun sair-rect (w1half w2half pbcx pbcy zd theta-air-val
+ proj-factor erf-table)
+
+ "sair-rect w1half w2half pbcx pbcy zd theta-air-val proj-factor erf-table
+
+A fast version of SAIR for rectangular field:
+
+input: w1half = half-width
+ w2half = half-height
+ pbcx, pbcy = pencil beam axis coordinates in collimator system
+ zd = distance between the pencil-beam source at the
+ cutout plane and calc point
+ theta-air-val = in-air spatial spread parameter
+ proj-factor = projection factor"
+
+ (declare (type (simple-array single-float (#.Erf-Table-Size)) erf-table)
+ (type single-float w1half w2half pbcx pbcy zd
+ theta-air-val proj-factor))
+
+ (let* ((sigma-air (/ proj-factor (* theta-air-val zd)))
+ (a (* sigma-air (- w1half pbcx)))
+ (b (* sigma-air (- (* -1.0 w1half) pbcx)))
+ (c (* sigma-air (- w2half pbcy)))
+ (d (* sigma-air (- (* -1.0 w2half) pbcy))))
+
+ (declare (type single-float sigma-air a b c d))
+
+ (* 0.25
+ (- (the single-float (error-function a erf-table))
+ (the single-float (error-function b erf-table)))
+ (- (the single-float (error-function c erf-table))
+ (the single-float (error-function d erf-table))))))
+
+;;;-------------------------------------------------------------
+;;; RFLUENCE: calculate relative fluecne at calc point at a lateral
+;;; separation (x-x', y-y') from the pencil-beam axis
+;;;
+;;; (pbcx,pbcy) = calc point coordinates in Collimator coordinates
+;;; pbwt = pencil-beam weight factor
+;;; spatial-spread = spatial spread parameter (sigma-RMS)
+;;; proj-factor = projection scaling factor
+;;; erf-table = error function table
+;;;-------------------------------------------------------------
+
+(defun rfluence (pbcx pbcy pbwt cx cy spatial-spread proj-factor erf-table)
+
+ "rfluence pbcx pbcy pbwt cx cy spatial-spread proj-factor erf-table
+
+calculates and returns relative fluence at calc point at a lateral
+separation (x-x', y-y') from the pencil-beam axis
+
+ (pbcx,pbcy) = calc point coordinates in Collimator system
+ pbwt = pencil-beam weight factor
+ spatial-spread = spatial spread parameter (sigma-rms)
+ proj-factor = projection scaling factor"
+
+ (declare (type single-float pbcx pbcy pbwt cx cy spatial-spread proj-factor)
+ (type (simple-array single-float (#.Erf-Table-Size)) erf-table))
+
+ (let* ((sigma2 (* #.(sqrt 2.0) spatial-spread))
+ (a (/ (- (* (+ pbcx #.(* 0.5 Pen-Bm-Width)) proj-factor) cx) sigma2))
+ (b (/ (- (* (- pbcx #.(* 0.5 Pen-Bm-Width)) proj-factor) cx) sigma2))
+ (c (/ (- (* (+ pbcy #.(* 0.5 Pen-Bm-Width)) proj-factor) cy) sigma2))
+ (d (/ (- (* (- pbcy #.(* 0.5 Pen-Bm-Width)) proj-factor) cy) sigma2)))
+
+ (declare (type single-float sigma2 a b c d))
+
+ (* 0.25
+ pbwt
+ (- (the single-float (error-function a erf-table))
+ (the single-float (error-function b erf-table)))
+ (- (the single-float (error-function c erf-table))
+ (the single-float (error-function d erf-table))))))
+
+;;;-------------------------------------------------------------
+;;; QUANTIZE-EFIELD: quantize electron field into pencil beams
+;;;-------------------------------------------------------------
+;;; input: cvlist - cutout vertices list
+;;; appl-size - square applicator dimension in cm
+;;; z-pos - z coordinate for collimator plane (in CC)
+;;; arg-vec - argument vector for use by ENCLOSES?
+;;; ouput: pen-num - total number of pencil beams
+;;; pbeam-array - array of pencil-beam objects
+;;;-------------------------------------------------------------
+
+(defun quantize-efield (cvlist appl-size z-pos arg-vec)
+
+ "quantize-efield cvlist appl-size z-pos arg-vec
+
+quantize electron field into pencil beams, returns total number of pencil
+beams from cvlist: cutout vertices list, appl-size: square applicator
+dimension in cm, z-pos: z coordinate for collimator plane (in CC)."
+
+ (declare (type list cvlist)
+ (type single-float appl-size z-pos)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec))
+
+ ;; Scan limits in mm - scanning should start at a point such that
+ ;; we hit the central axis.
+ (let* ((ulim-fix (the fixnum
+ (1+ (the fixnum
+ (round (the single-float
+ (/ appl-size #.(* 2.0 Pen-Bm-Width))))))))
+ (ulim-flo (coerce ulim-fix 'single-float))
+ (llim-flo (- ulim-flo))
+ ;; Estimate number of pencil beams and allocate global array.
+ (pbeam-array (make-array (sqr-fix (* ulim-fix 2))
+ :element-type t :initial-element :EOF))
+ (pen-num 0))
+
+ (declare (type (simple-array t 1) pbeam-array)
+ (type single-float ulim-flo llim-flo)
+ (type fixnum ulim-fix pen-num))
+
+ ;; Count the number of pencil beams within the efield.
+ (do ((y-val llim-flo (the single-float (1+ y-val))))
+ ((> y-val ulim-flo))
+ (declare (type single-float y-val))
+ (do ((x-val llim-flo (the single-float (1+ x-val)))
+ (x-res 0.0)
+ (y-res (* y-val #.Pen-Bm-Width)))
+ ((> x-val ulim-flo))
+ (declare (type single-float x-val x-res y-res))
+ (setq x-res (* x-val #.Pen-Bm-Width))
+ (setf (aref arg-vec #.Argv-Enc-X) x-res)
+ (setf (aref arg-vec #.Argv-Enc-Y) y-res)
+
+ (when (encloses? cvlist arg-vec)
+ (setf (aref pbeam-array pen-num) (make-pbeam 1.0 x-res y-res z-pos))
+ (setq pen-num (the fixnum (1+ pen-num))))))
+
+ (values pen-num pbeam-array)))
+
+;;;-------------------------------------------------------------
+;;; QUANTIZE-EXPFIELD: quantize expanded electron field into pencil
+;;; beams with varying weights
+;;;-------------------------------------------------------------
+;;; input: cvlist - cutout vertices list
+;;; appl-size - expanded square applicator dimension in cm
+;;; z-pos - z coordinate for collimator plane (in CC)
+;;; arg-vec - argument vector for use by ENCLOSES?
+;;; ouput: (1) pen-num - total number of pencil beams (doubled)
+;;; (2) pbeam-array - array of pencil-beam objects and raytrace-lists
+;;; (3) expanded CVLIST by ??-mm orthogonally
+;;;-------------------------------------------------------------
+
+(defun quantize-expfield (cvlist appl-size z-pos arg-vec)
+
+ "quantize-expfield cvlist appl-size z-pos arg-vec
+
+quantize expanded electron field into pencil beams with varying weights.
+
+input: cvlist - cutout vertices list
+ appl-size - expanded square applicator dimension in cm
+ z-pos - z coordinate for collimator plane (in CC)
+
+outputs: three values, pen-num - total number of pencil beams
+ pbeam-array - array of pencil beams and raytrace-lists
+ CVLIST expanded by ??-mm orthogonally"
+
+ (declare (type list cvlist)
+ (type single-float appl-size z-pos)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec))
+
+ ;; Scan limits in mm - scanning should start at a point such that we
+ ;; hit the central axis - add 0.1-cm margin to expanded field.
+ (let* ((ulim-fix (the fixnum
+ (1+ (the fixnum
+ (round (the single-float
+ (/ (+ appl-size 0.2)
+ #.(* 2.0 Pen-Bm-Width))))))))
+ (ulim-flo (coerce ulim-fix 'single-float))
+ (llim-flo (- ulim-flo))
+ ;; Estimate number of pencil beams and allocate array.
+ (pbeam-array (make-array (* (the (integer 0 100000)
+ (sqr-fix (* ulim-fix 2)))
+ 2)
+ :element-type t :initial-element :EOF))
+ (pen-num 0)
+ ;; Expand field in 0.1-cm increments.
+ (explist1 (poly:ortho-expand-contour cvlist 0.1))
+ (explist2 (poly:ortho-expand-contour cvlist 0.2))
+ (explist3 (poly:ortho-expand-contour cvlist 0.3))
+ (explist4 (poly:ortho-expand-contour cvlist 0.4))
+ ;; Contract field in 0.1-cm increments.
+ (cntrlist1 (poly:ortho-expand-contour cvlist -0.1))
+ (cntrlist2 (poly:ortho-expand-contour cvlist -0.2))
+ (cntrlist3 (poly:ortho-expand-contour cvlist -0.3))
+ (cntrlist4 (poly:ortho-expand-contour cvlist -0.4)))
+
+ (declare (type (simple-array t 1) pbeam-array)
+ (type list explist1 explist2 explist3 explist4
+ cntrlist1 cntrlist2 cntrlist3 cntrlist4)
+ (type single-float ulim-flo llim-flo)
+ (type fixnum ulim-fix pen-num))
+
+ ;; Count the number of pencil beams within the efield.
+ (do ((y-val llim-flo (the single-float (1+ y-val))))
+ ((> y-val ulim-flo))
+ (declare (type single-float y-val))
+ (do ((x-val llim-flo (the single-float (1+ x-val)))
+ (x-res 0.0)
+ (y-res (* y-val #.Pen-Bm-Width))
+ (encl-exp3?) (encl-exp2?) (encl-exp1?) (encl-cvl?)
+ (encl-cntr1?) (encl-cntr2?) (encl-cntr3?) (encl-cntr4?))
+ ((> x-val ulim-flo))
+
+ (declare (type (member nil t) encl-exp3? encl-exp2? encl-exp1?
+ encl-cvl? encl-cntr1? encl-cntr2? encl-cntr3?
+ encl-cntr4?)
+ (type single-float x-val x-res y-res))
+
+ (setq x-res (* x-val #.Pen-Bm-Width))
+ (setf (aref arg-vec #.Argv-Enc-X) x-res)
+ (setf (aref arg-vec #.Argv-Enc-Y) y-res)
+ (setq encl-exp3? (encloses? explist3 arg-vec)
+ encl-exp2? (encloses? explist2 arg-vec)
+ encl-exp1? (encloses? explist1 arg-vec)
+ encl-cvl? (encloses? cvlist arg-vec)
+ encl-cntr1? (encloses? cntrlist1 arg-vec)
+ encl-cntr2? (encloses? cntrlist2 arg-vec)
+ encl-cntr3? (encloses? cntrlist3 arg-vec)
+ encl-cntr4? (encloses? cntrlist4 arg-vec))
+
+ (cond
+ ((and (encloses? explist4 arg-vec)
+ (not encl-exp3?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.1 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ ((and encl-exp3? (not encl-exp2?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.2 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ ((and encl-exp2? (not encl-exp1?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.3 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ ((and encl-exp1? (not encl-cvl?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.5 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ ((and encl-cvl? (not encl-cntr1?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.5 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ ((and encl-cntr1? (not encl-cntr2?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.7 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ ((and encl-cntr2? (not encl-cntr3?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.8 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ ((and encl-cntr3? (not encl-cntr4?))
+ (setf (aref pbeam-array pen-num) (make-pbeam 0.9 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2))))
+ (encl-cntr4?
+ (setf (aref pbeam-array pen-num)
+ (make-pbeam 1.0 x-res y-res z-pos))
+ (setq pen-num (the fixnum (+ pen-num 2)))))))
+
+ (values pen-num pbeam-array explist4)))
+
+;;;-------------------------------------------------------------
+;;; SPOWER: Computes mass scattering power in water for a given mean
+;;; electron energy according to the ICRU-35 Table 2.6.
+;;; I tried to find a single function to fit the entire latitude of energy.
+;;; However, better accuracy was obtained by segmented fitting.
+;;;
+;;; Note: Energy must be less than 30MeV
+;;;
+;;; Sanity check:
+;;; energy calc ICRU-35
+;;; E=0.04 5.31E+02 5.16E+02
+;;; E=2 1.02E+00 1.03
+;;; E=10 6.92E-02 6.95E-02
+;;; E=20 1.997E-02 2.00E-02
+;;;-------------------------------------------------------------
+
+(defun spower (deff init-energy rp-val &aux (mean-energy 0.0))
+
+ "spower deff init-energy rp-val
+
+Computes mean electron energy at an effective depth using Harder's
+linear relationship. Then computes mass scattering power in water
+for a given mean electron energy according to the ICRU-35 Table 2.6.
+I tried to find a single function to fit the entire latitude of energy.
+However, better accuracy was obtained by segmented fitting.
+Note: Energy must be less than 30MeV. Sanity check:
+ energy calc ICRU-35
+ E=0.04 5.31E+02 5.16E+02
+ E=2 1.02E+00 1.03
+ E=10 6.92E-02 6.95E-02
+ E=20 1.997E-02 2.00E-02"
+
+ (declare (type single-float deff init-energy rp-val mean-energy))
+
+ (cond ((<= (setq mean-energy
+ (cond ((<= deff rp-val)
+ (* init-energy (- 1.0 (/ deff (+ rp-val 0.1)))))
+ (t 0.001)))
+ 0.0)
+ (error "SPOWER [1] MEAN-ENERGY negative: ~S" mean-energy))
+
+ ((<= mean-energy 0.15)
+ (* 2.0332
+ (the single-float
+ (exp (* -1.7288
+ (the single-float
+ (log (the (single-float 0.0 *) mean-energy))))))))
+
+ ((<= mean-energy 3.0)
+ (* 2.9521
+ (the single-float
+ (exp (* -1.5349
+ (the single-float
+ (log (the (single-float 0.0 *) mean-energy))))))))
+
+ ((<= mean-energy 15.0)
+ (* 3.6654
+ (the single-float
+ (exp (* -1.7241
+ (the single-float
+ (log (the (single-float 0.0 *) mean-energy))))))))
+
+ ((<= mean-energy 30.0)
+ (* 4.6735
+ (the single-float
+ (exp (* -1.821
+ (the single-float
+ (log (the (single-float 0.0 *) mean-energy))))))))
+
+ (t (error "SPOWER [2] MEAN-ENERGY out of range: ~S" mean-energy))))
+
+;;;-------------------------------------------------------------
+;;; GET-SPATIAL-SPREAD-VECTOR:
+;;; computes spatial spread parameter for density 1.0
+;;;-------------------------------------------------------------
+;;; init-energy = initial energy of the beam (not nominal E)
+;;; Rp-Val = practical range of the beam
+;;; Computes for depth at steps of Electron-Step-Size from 0.0 to Rp-Val.
+;;;-------------------------------------------------------------
+
+(defun get-spatial-spread-vector (init-energy rp-val)
+
+ "get-spatial-spread-vector init-energy rp-val
+
+returns an array of spatial spread parameter values as a function of
+depth, for unit density.
+init-energy = initial energy of the beam (not nominal E)
+rp-val = practical range of the beam"
+
+ (declare (type single-float init-energy rp-val))
+
+ (let ((spatial-spread-vector
+ (make-array
+ (1+ (the (integer 0 1000000)
+ (round (the single-float
+ (* #.(/ 1.0 Electron-Step-Size) rp-val)))))
+ :element-type 'single-float :initial-element 0.0)))
+
+ (declare (type (simple-array single-float 1) spatial-spread-vector))
+
+ ;; SPATIAL-SPREAD between 0 and 0.5 mm.
+ (setf (aref spatial-spread-vector 0) ; !!! depth is 0.05 cm here
+ (* #.(* 0.5 Electron-Step-Size
+ 0.5 Electron-Step-Size
+ 0.5 Electron-Step-Size)
+ (the single-float
+ (spower #.(* 0.5 Electron-Step-Size) init-energy rp-val))))
+
+ ;; SPATIAL-SPREAD for other depths down to [and including] Rp-Val.
+ (do ((idx 1 (the fixnum (1+ idx)))
+ (unitdepth #.Electron-Step-Size (+ unitdepth #.Electron-Step-Size)))
+ ((> unitdepth rp-val)
+ spatial-spread-vector)
+
+ (declare (type single-float unitdepth)
+ (type fixnum idx))
+
+ ;; Integrate along path - pencil-beam axis.
+ (do ((zeta #.Electron-Step-Size (+ zeta #.Electron-Step-Size))
+ (diff 0.0)
+ (sigma-rms 0.0))
+ ((> zeta unitdepth)
+ (setf (aref spatial-spread-vector idx)
+ (the (single-float 0.0 *) (sqrt sigma-rms))))
+
+ (declare (type single-float diff)
+ (type (single-float 0.0 *) zeta sigma-rms))
+
+ (setq diff (- zeta unitdepth))
+ (incf sigma-rms
+ (* #.Electron-Step-Size
+ (+ (* diff diff)
+ (* #.Electron-Step-Size diff)
+ #.(/ (* Electron-Step-Size Electron-Step-Size) 3.0))
+ (the single-float (spower zeta init-energy rp-val))))))))
+
+;;;-------------------------------------------------------------
+;;; GET-FMCS: computes spatial spread adjustment factor, FMCS
+;;; results are saved in an array
+;;;-------------------------------------------------------------
+;;; F1-val = FMCS at a shallow depth; fmcs is usually greater than 1.0
+;;; F2-val = FMCS near or at Rp; usually less than 1.0
+;;; Z1-val = depth in cm where F1 is specified
+;;; Z2-val = depth in cm where F2 is specified; must be <= Rp
+;;; Rp-Val = practical range in cm
+;;;-------------------------------------------------------------
+
+(defun get-fmcs (f1-val f2-val z1-val z2-val rp-val)
+
+ "get-fmcs f1-val f2-val z1-val z2-val rp-val
+
+returns array containing computed spatial spread adjustment factor, fmcs.
+ f1-val = fmcs at a shallow depth; fmcs is usually greater than 1.0
+ f2-val = fmcs near or at Rp-Val; usually less than 1.0
+ z1-val = depth in cm where F1-VAL is specified
+ z2-val = depth in cm where F2-VAL is specified; must be <= Rp-Val
+ Rp-Val = practical range in cm"
+
+ (declare (type single-float f1-val f2-val z1-val z2-val rp-val))
+
+ (cond ((<= z2-val rp-val)
+
+ (let* ((a (/ (- f2-val f1-val) (- z2-val z1-val)))
+ (b (- f2-val (* a z2-val)))
+ (fmcs (make-array
+ (1+ (the (integer 0 1000000)
+ (round (the single-float
+ (* #.(/ 1.0 Electron-Step-Size)
+ rp-val)))))
+ :element-type 'single-float :initial-element 0.0)))
+
+ (declare (type single-float a b)
+ (type (simple-array single-float 1) fmcs))
+
+ (do ((z-val 0.0 (+ z-val #.Electron-Step-Size)))
+ ((> z-val rp-val)
+ fmcs)
+ (declare (type single-float z-val))
+ (setf (aref fmcs (the fixnum
+ (round (the single-float
+ (* z-val
+ #.(/ 1.0 Electron-Step-Size))))))
+ (+ (* a z-val) b)))))
+
+ (t (error "GET-FMCS [1] FMCS at depth ~S past Rp-val ~S"
+ z2-val rp-val))))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/file-functions.cl b/prism/src/file-functions.cl
new file mode 100644
index 0000000..a4f7b8c
--- /dev/null
+++ b/prism/src/file-functions.cl
@@ -0,0 +1,438 @@
+;;;
+;;; file-functions
+;;;
+;;; This module provides functions for storing and retrieving
+;;; object data from files.
+;;;
+;;; 04-May-1992 I. Kalet taken from earlier prism
+;;; 13-Jul-1992 I. Kalet fix error omitting allegro-v4.1 in slot-names
+;;; 29-Jul-1992 I. Kalet change get-filename to generic function
+;;; bin-array-filename
+;;; 9-Aug-1992 I. Kalet add support in get-object, put-object for
+;;; slot-type :collection
+;;; 19-Jan-1993 I. Kalet return nil from get-all-objects if file does
+;;; not exist
+;;; 23-Mar-1993 J. Unger expand slot-names to cmulisp; modify #+/+-'s
+;;; 14-Feb-1994 I. Kalet fix Lucid for SunCL and add Genera.
+;;; 4-Mar-1994 I. Kalet consolidate Lucid, Allegro, Genera
+;;; 7-Jun-1994 J. Unger update for allegro cl v4.2
+;;; 21-Jun-1994 I. Kalet add support for slot type :timestamp
+;;; 12-Jan-1995 I. Kalet take out proclaim form, and explicit support
+;;; for VAXlisp and Lucid. Put in support for slot names to ignore,
+;;; so that obsolete data in files will not cause an error.
+;;; 13-Aug-1995 I. Kalet add lispworks in MOP version of slot-names
+;;; 19-Apr-1997 I. Kalet just assume MOP supported - no more support
+;;; for old CMU Lisp or VAXlisp.
+;;; 29-Aug-1997 BobGian clarified comments in GET-OBJECT and
+;;; PUT-OBJECT.
+;;; 12-Sep-1997 I. Kalet add get-index-list - used by db functions
+;;; 28-Jan-1998 BobGian slight speedup: EQL on symbols -> EQ.
+;;; 5-Jun-1998 I. Kalet use read-sequence to speed up read-bin-array,
+;;; also use Allegro-dependent :allocation :old to tenure the arrays.
+;;; 10-Oct-1998 C. Wilcox added the ability to swap byte orders to
+;;; address endian issues between HP-UX and Linux (x86).
+;;; 3-Dec-1998 I. Kalet took out byte swap hack, it is NOT portable.
+;;; Binary files should always be read in host byte order, standard
+;;; CL, and it is up to the creator of such files to create them in
+;;; host byte order on any host. This means that copying binary
+;;; files from a little endian machine to a big endian machine
+;;; requires that the copy operation swap the bytes, not an
+;;; application like Prism.
+;;; 2-Jan-2000 I. Kalet requalify use of MOP by #+allegro, add clisp
+;;; 27-Aug-2000 I. Kalet just add progress report when reading bin
+;;; arrays but move restored byte swap code to prism-db.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 07-Nov-2004 A. Simms condense slot-names definitions for Allegro, CMUCL
+;;; and CLisp to a single function with a Lisp specific mapcar form.
+;;; 18-Apr-2005 I. Kalet cosmetic fixes.
+;;; 24-Jun-2009 I. Kalet add explicit require for Allegro Gray streams
+;;; modules to handle non-byte streams and read-sequence
+;;;
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :streamc))
+
+(in-package :prism)
+
+;;;-------------------------------------------------------
+
+
+(defun slot-names (obj)
+
+ "slot-names obj
+
+returns a list of slot names defined for the class of which object obj
+is a member, using the MOP."
+
+ #+allegro
+ (mapcar #'clos:slot-definition-name
+ (clos:class-slots (class-of obj)))
+
+ #+cmu
+ (mapcar #'(lambda (x) (pcl::slot-value x 'pcl::name))
+ (pcl::class-slots (class-of obj)))
+
+ #+clisp
+ (mapcar #'clos::slotdef-name
+ (clos::class-slots (class-of obj)))
+
+ )
+
+
+;;;------------------------------------------
+;;; These are the least specific methods for
+;;; generic functions slot-type and not-saved.
+;;;------------------------------------------
+
+(defmethod slot-type ((object t) slotname)
+
+ "slot-type object slotname
+
+This is a default method for the generic function that returns the
+slot type of a slot. Individual classes must provide their own
+methods to return one of the keywords, :simple, :object-list,
+:collection or :bin-array, if any slots are different from :simple.
+If all slots are of type :simple then the class needs no method and
+this default method will suffice."
+
+ (declare (ignore slotname))
+ :simple)
+
+;;;-------------------------------------------
+
+(defmethod not-saved ((object t))
+
+ "not-saved object
+
+The default method for the generic function that returns a list of
+slot names which should NOT be saved in an external file. An example
+of this method for class foo which does not want to save slot c would
+look like (defmethod not-saved ((object foo)) '(c))"
+
+ nil)
+
+;;;-------------------------------------------
+
+(defmethod bin-array-pathname ((obj t))
+
+ "bin-array-pathname obj
+
+returns a string to be used as a directory name to merge in with the
+binary array filename when calling read-bin-array or write-bin-array."
+
+ *default-pathname-defaults*) ; this is just the default method
+
+;;;-------------------------------------------
+
+(defun get-object (in-stream &key (parent nil) )
+
+ "get-object in-stream &key parent
+
+reads forms from in-stream, filling in slots of a new instance of the
+class for the first symbol read from the stream. The data are assumed
+to be in the form <slot name> <slot value>, except if the slot is a
+list of other objects,in which case, get-object is called recursively
+to construct the list. The data for an object are terminated with a
+keyword :END. It returns the newly created instance along with any
+component objects, or nil if the first keyword read from in-stream is
+the keyword :END. So, :END means either end of an object list, or end
+of an object. If the slot type is :parent, the value of parent is
+bound to the slot. If the slot type is :timestamp the value is held
+until the end, since the slot may get updated by other code in the
+system as slots get filled in."
+
+ (let* ((current-key (read in-stream))
+ (object (if (eq current-key :end) nil ; end of object list
+ (make-instance current-key)))
+ (timestamp-slotname nil) ; temporary storage
+ (timestamp nil)) ; temp storage for timestamp string
+ (unless (null object)
+ (loop
+ (setq current-key (read in-stream))
+ (when (eq current-key :end) ; end of object
+ (when timestamp ; update that slot now
+ (setf (slot-value object timestamp-slotname) timestamp))
+ (return object))
+ (if (eq (slot-type object current-key) :ignore)
+ (read in-stream) ; throw away the value - usually nil
+ (setf (slot-value object current-key) ; otherwise process it
+ (case (slot-type object current-key)
+ (:simple (read in-stream))
+ (:bin-array
+ (let ((bin-info (read in-stream)))
+ (format t "Reading ~A~%" bin-info)
+ (read-bin-array (merge-pathnames
+ (first bin-info)
+ (bin-array-pathname object))
+ (rest bin-info))))
+ (:object (get-object in-stream :parent object))
+ (:object-list
+ (let ((slotlist '())
+ (next-object nil))
+ (loop
+ (setq next-object
+ (get-object in-stream :parent object))
+ (cond (next-object
+ (push next-object slotlist))
+ (t (return (nreverse slotlist)))))))
+ ;; We assume this slot is already initialized with an
+ ;; empty collection - we use it because other stuff may be
+ ;; connected to it (see for example the plans module).
+ (:collection
+ (let ((slotset (slot-value object current-key))
+ (next-object nil))
+ (loop
+ (setq next-object
+ (get-object in-stream :parent object))
+ (cond (next-object
+ (coll:insert-element next-object slotset))
+ (t (return slotset))))))
+ (:parent (progn (read in-stream) ; discard value
+ parent)) ; just use parent
+ (:timestamp (setq timestamp-slotname current-key)
+ (setq timestamp (read in-stream))))))))))
+
+;;;----------------------------------
+
+(defun tab-print (item stream tab &optional (cr nil))
+
+ "tab-print item stream tab &optional (cr nil)
+
+Given an item (eg symbol), a stream, a tab value (an integer), and
+optionally instructions to format a carriage return, a string
+representation of the item is printed after the appropriate number of
+blank spaces, as specified by tab value."
+
+ (format stream "~a"
+ (concatenate 'string
+ (make-string tab :initial-element #\space)
+ (write-to-string item :pretty t)
+ (make-string 2 :initial-element #\space)))
+ (when cr (format stream "~%")))
+
+;;;----------------------------------
+
+(defmethod bin-array-filename ((obj t) slotname)
+
+ "Default method for generating a name for a bin-array data file.
+Uses slot name and generates lower-case to work easily with Unix. You
+can provide more sophisticated methods for various object classes."
+
+ (concatenate 'string
+ (string-downcase (remove #\: (write-to-string slotname)))
+ ".bin"))
+
+;;;----------------------------------
+
+(defun put-object (object out-stream &optional (tab 0))
+
+ "put-object object out-stream &optional (tab 0)
+
+writes a printed representation of object to the stream out-stream, in
+a form suitable to be read in by get-object. It needs two generic
+functions, slot-type and not-saved. For each slot except those
+returned by not-saved, it writes the slot name, then a form that
+depends on the type of data supposed to be in that slot, as specified
+by the value of (slot-type object slotname). Tabs are optionally used
+to indent object names and slot-values hierarchically to make files
+more readable by humans."
+
+ (tab-print (class-name (class-of object)) out-stream tab t)
+ (mapc #'(lambda (slotname)
+ (when (slot-boundp object slotname)
+ (tab-print slotname out-stream (+ 2 tab))
+ (case (slot-type object slotname)
+ ((:simple :timestamp) (tab-print
+ (slot-value object slotname)
+ out-stream 0 t))
+ (:bin-array
+ (let* ((the-data (slot-value object slotname))
+ (filename (bin-array-filename object
+ slotname))
+ (dimensions (array-dimensions the-data)))
+ (tab-print (push filename dimensions)
+ out-stream 0 t)
+ (write-bin-array (merge-pathnames
+ (bin-array-pathname object)
+ filename)
+ the-data)))
+ (:object (fresh-line out-stream)
+ (put-object (slot-value object slotname)
+ out-stream (+ 4 tab)))
+ (:object-list
+ (fresh-line out-stream)
+ (mapc #'(lambda (obj)
+ (put-object obj out-stream (+ 4 tab)))
+ (slot-value object slotname))
+ (tab-print :end out-stream (+ 2 tab) t)) ; terminates list
+ (:collection ; like :object-list
+ (fresh-line out-stream)
+ (mapc #'(lambda (obj)
+ (put-object obj out-stream (+ 4 tab)))
+ (coll:elements (slot-value object slotname)))
+ (tab-print :end out-stream (+ 2 tab) t)) ; terminates list
+ (:parent (tab-print nil out-stream 0 t))))) ; just write NIL
+ (set-difference (slot-names object) (not-saved object)))
+ (tab-print :end out-stream tab t)) ; terminates object
+
+;;;----------------------------------
+
+(defun read-bin-array (filename dimensions)
+
+ "read-bin-array filename dimensions
+
+reads an array of dimensions specified by dimensions from a binary
+file named 'filename' into an array of (unsigned-byte 16). Arrays of
+1 through 3 dimensions are currently supported."
+
+ (let* ((bin-dim (if (numberp dimensions) (list dimensions)
+ dimensions))
+ (num-dim (length bin-dim)))
+ (with-open-file (infile filename :direction :input
+ :element-type '(unsigned-byte 16))
+ (case num-dim
+ (1 (let ((bin-array (make-array bin-dim
+ :element-type
+ '(unsigned-byte 16)
+ #+allegro :allocation
+ #+allegro :old)))
+ (declare (type (simple-array (unsigned-byte 16) (*))
+ bin-array))
+ (read-sequence bin-array infile)
+ bin-array))
+ (2 (let* ((bin-array (make-array bin-dim
+ :element-type
+ '(unsigned-byte 16)
+ #+allegro :allocation
+ #+allegro :old))
+ (disp-array (make-array (array-total-size bin-array)
+ :element-type
+ '(unsigned-byte 16)
+ :displaced-to bin-array)))
+ (declare (type (simple-array (unsigned-byte 16) (* *))
+ bin-array)
+ (type (simple-array (unsigned-byte 16) (*))
+ disp-array))
+ (read-sequence disp-array infile)
+ bin-array))
+ (3 (let* ((bin-array (make-array bin-dim
+ :element-type
+ '(unsigned-byte 16)
+ #+allegro :allocation
+ #+allegro :old))
+ (disp-array (make-array (array-total-size bin-array)
+ :element-type
+ '(unsigned-byte 16)
+ :displaced-to bin-array)))
+ (declare (type (simple-array (unsigned-byte 16) (* * *))
+ bin-array)
+ (type (simple-array (unsigned-byte 16) (*))
+ disp-array))
+ (read-sequence disp-array infile)
+ bin-array))))))
+
+;;;----------------------------------
+
+(defun write-bin-array (filename bin-array)
+
+ "write-bin-array filename bin-array
+
+writes an array of (unsigned-byte 16)s to a binary file named
+'filename'. Arrays of 1 through 3 dimensions are currently
+supported."
+
+ (let* ((bin-dim (array-dimensions bin-array))
+ (num-dim (length bin-dim))
+ (x-dim (nth (- num-dim 1) bin-dim))
+ (y-dim (if (< num-dim 2) 0
+ (nth (- num-dim 2) bin-dim)))
+ (z-dim (if (< num-dim 3) 0
+ (first bin-dim))))
+ (declare (fixnum num-dim x-dim y-dim z-dim))
+ (declare (type (simple-array (unsigned-byte 16)) bin-array))
+ (with-open-file (outfile filename
+ :direction :output
+ :element-type '(unsigned-byte 16)
+ :if-exists :new-version)
+ (case num-dim
+ (1 (dotimes (i x-dim)
+ (write-byte (aref bin-array i) outfile)))
+ (2 (dotimes (j y-dim)
+ (dotimes (i x-dim)
+ (write-byte (aref bin-array j i)
+ outfile))))
+ (3 (dotimes (k z-dim)
+ (format t "writing plane ~a...~%" k)
+ (dotimes (j y-dim)
+ (dotimes (i x-dim)
+ (write-byte (aref bin-array k j i)
+ outfile)))))))))
+
+;;;----------------------------------
+
+(defun get-all-objects (filename)
+
+ "get-all-objects filename
+
+opens file named filename, iteratively calls get-object to accumulate
+a list of all the objects found in the file, until end of file is
+reached. Returns the list of object instances. If the file does not
+exist, returns nil."
+
+ (with-open-file (stream filename
+ :direction :input
+ :if-does-not-exist nil)
+ (when (streamp stream)
+ (let ((object-list '()))
+ (loop
+ (cond ((eq (peek-char t stream nil :eof) :eof)
+ (return object-list))
+ (t (push (get-object stream) object-list))))))))
+
+;;;----------------------------------
+
+(defun put-all-objects (object-list filename)
+
+ "put-all-objects object-list filename
+
+opens file named filename, iteratively calls put-object on successive
+elements of the list object-list. If a file named filename already
+exists, a new version is created."
+
+ (with-open-file (stream filename
+ :direction :output
+ :if-exists :new-version)
+ (dolist (obj object-list)
+ (put-object obj stream))))
+
+;;;----------------------------------
+
+(defun get-index-list (filename database item
+ &key (key #'first) (test #'equal))
+
+ "get-index-list filename database item
+ &key (key #'first) (test #'equal)
+
+returns a list of lists, each one containing data about one database
+entry, a patient, a case, an image study, a therapy machine or other,
+from an index file. The parameters are: filename, a string naming the
+index file, database, a string or pathname specifying where the file
+is located, and item, a string or other entity to look for in the
+file. If item is not nil then the key and test functions are used to
+select only records that match the item. The returned list is in
+reverse order of the entries in the file."
+
+ (with-open-file (stream (merge-pathnames filename database)
+ :if-does-not-exist nil)
+ ;; If (streamp stream) is nil, when returns nil.
+ (when (streamp stream)
+ (do ((entry (read stream nil :eof) (read stream nil :eof))
+ (entries '()))
+ ((eq entry :eof) entries)
+ (when (or (not item)
+ (funcall test (funcall key entry) item))
+ (push entry entries))))))
+
+;;;----------------------------------
+;;; End.
diff --git a/prism/src/filmstrip.cl b/prism/src/filmstrip.cl
new file mode 100644
index 0000000..c105985
--- /dev/null
+++ b/prism/src/filmstrip.cl
@@ -0,0 +1,618 @@
+;;;
+;;; filmstrip
+;;;
+;;; The filmstrip displays a list of pixmaps in a horizontal viewing area.
+;;; A subset of the pixmap list is displayed in the viewing area, and
+;;; arrow buttons on each side provide a means for scrolling forward or
+;;; backward through the list. A refrence frame is displayed to the
+;;; left of the viewing area.
+;;;
+;;; 12-Jul-1992 I. Kalet started, and made many modifications.
+;;; 16-Feb-1993 J. Unger rewrite from I. Kalet's original code.
+;;; 26-Apr-1993 J. Unger revise after extensive discussions.
+;;; 29-Apr-1993 J. Unger modify setf index :around method so frame
+;;; corresponding to selected index moved into viewport.
+;;; 07-May-1993 J. Unger modify initialization params to initargs.
+;;; 28-May-1993 J. Unger many modifications to operate with easel.
+;;; 30-Jun-1993 J. Unger move questions to a different text file.
+;;; 2-Jul-1993 I. Kalet remove reference view stuff, move insert-at
+;;; and delete-at to misc module.
+;;; 16-Mar-1994 J. Unger add destroy method.
+;;; 21-Apr-1994 J. Unger move arrow drawing code to function in misc module
+;;; 02-Sep-1994 J. Unger make hilited fs border red.
+;;; 9-Jun-1997 I. Kalet delete global params., make width and height
+;;; attributes, use new SLIK arrow button, make button 2 move the
+;;; viewport 5 frames if possible. Don't make a subclass of
+;;; generic-panel - prepare for moving to SLIK.
+;;; 26-Jan-1998 I. Kalet incorporate more data management here instead
+;;; of in client modules. Consolidate and simplify. Add scale factor
+;;; so it does not depend on changes in other components.
+;;; 25-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 5-Jan-2000 I. Kalet parametrize format of display of frame index
+;;; info, keep value in frame-index slot instead of reading back from
+;;; readout. Relax plane match criterion for display.
+;;; 30-Jul-2000 I. Kalet put draw-image-pix code inline here, not used
+;;; anywhere else.
+;;; 24-Oct-2004 A. Simms adjust call to make-instance in make-filmstrip
+;;; to accomodate additional argument keys explicitly.
+;;; 3-Jun-2009 I. Kalet use original images instead of mini-images,
+;;; use scale-image to resize to frame size.
+;;;
+
+(in-package :prism)
+
+;;;-----------------------------------
+
+(defclass filmstrip ()
+
+ ((width :type fixnum
+ :accessor width
+ :initarg :width
+ :documentation "The overall width in pixels of the filmstrip
+frame, including the buttons.")
+
+ (height :type fixnum
+ :accessor height
+ :initarg :height
+ :documentation "The overall height in pixels of the
+filmstrip frame, including the readouts.")
+
+ (scale :type single-float
+ :accessor scale
+ :initarg :scale
+ :documentation "The number of pixels per unit of model
+space, the same in all filmstrip frames.")
+
+ (images :type list
+ :accessor images
+ :initarg :images
+ :documentation "A list of images that will appear in the
+background of some frames of the filmstrip, provided by the client
+when the filmstrip is created. Any fs-frame that has an image in it
+will stay in the fs-frames list even if there are no foreground data
+to display.")
+
+ (index :accessor index
+ :initarg :index
+ :documentation "The index value of the selected frame in the
+filmstrip's fs-frame list.")
+
+ (new-index :type ev:event
+ :accessor new-index
+ :initform (ev:make-event)
+ :documentation "Announced when index is updated.")
+
+ (window :type fixnum
+ :accessor window
+ :initarg :window
+ :documentation "The grayscale window width of the images in
+the filmstrip background.")
+
+ (level :type fixnum
+ :accessor level
+ :initarg :level
+ :documentation "The grayscale level value or center of the
+window of the images in the filmstrip background.")
+
+ (index-format :type string
+ :accessor index-format
+ :initarg :index-format
+ :documentation "The format string used to display the
+index value in each frame.")
+
+ ;;--------------------------------------------------------
+ ;; from here on this stuff is internal to the filmstrip
+ ;;--------------------------------------------------------
+
+ (fr :type sl:frame
+ :accessor fr
+ :documentation "The SLIK frame that contains the filmstrip.")
+
+ (fs-frames :type list
+ :accessor fs-frames
+ :initform nil
+ :documentation "A list of objects of type fs-frame, each
+containing the information for that individual filmstrip frame,
+including the picture, the readout and the supporting graphic and
+image data.")
+
+ (viewport :accessor viewport
+ :documentation "The available viewing area for the frames
+of the filmstrip.")
+
+ (left-frame-no :type fixnum
+ :accessor left-frame-no
+ :initform 0
+ :documentation "An integer that indicates which
+frame in the fs-frames list is currently the left-most frame in the
+viewport. When no frames are present it is 0.")
+
+ (left-arrow :type sl:picture
+ :accessor left-arrow
+ :documentation "The button on the left end which when
+pressed will scroll the viewing range one frame to the left, i.e., the
+pictures move to the right.")
+
+ (right-arrow :type sl:picture
+ :accessor right-arrow
+ :documentation "The button on the right end which when
+pressed will scroll the viewing range one frame to the right, i.e.,
+the pictures move to the left.")
+
+ )
+
+ (:default-initargs :scale 5.0 :images nil :index nil
+ :window 500 :level 1024 :index-format "~A")
+
+ (:documentation "The filmstrip shows a scrollable sequence of
+pictures and index readouts. The contents of the pictures are derived
+from initialization arguments. Left and right buttons allow scrolling
+through the set of pictures if there are too many to show at once.")
+
+ )
+
+;;;-----------------------------------
+
+(defun make-filmstrip (width height &rest initargs)
+
+ "make-filmstrip width height &rest initargs
+
+Returns a filmstrip with specified overall width, height and other
+parameters."
+
+ (apply #'make-instance 'filmstrip
+ :width width :height height :allow-other-keys t initargs))
+
+;;;-----------------------------------
+
+(defmethod destroy ((fs filmstrip))
+
+ "Releases additional X resources used by this panel."
+
+ (dolist (frm (fs-frames fs)) (destroy frm))
+ (sl:destroy (left-arrow fs))
+ (sl:destroy (right-arrow fs))
+ (sl:destroy (viewport fs))
+ (sl:destroy (fr fs)))
+
+;;;-----------------------------------
+
+(defclass fs-frame ()
+
+ ((pic :accessor pic
+ :initarg :pic
+ :documentation "The SLIK picture for this filmstrip frame.")
+
+ (bg-image :accessor bg-image
+ :initarg :bg-image
+ :documentation "The background image pixmap, or a black
+pixmap if there is no image in this frame.")
+
+ (fg-prims :type list
+ :accessor fg-prims
+ :initarg :fg-prims
+ :documentation "A list of graphic primitives that are
+drawn over the image or black background. Can be empty.")
+
+ (rdt :accessor rdt
+ :initarg :rdt
+ :documentation "The SLIK readout at the bottom of the frame,
+displaying the index value of the frame.")
+
+ (frame-index :reader frame-index
+ :initarg :frame-index
+ :documentation "The index value displayed in the frame
+readout.")
+
+ )
+
+ (:default-initargs :bg-image nil :fg-prims nil)
+
+ (:documentation "Each displayed frame in the filmstrip has all its
+components together in this one data structure, instead of maintaining
+separate lists of pictures, lists of pixmaps, etc.")
+
+ )
+
+;;;----------------------------------
+
+(defun make-fs-frame (width height parent index ulc-x fmt-string
+ &rest initargs)
+
+ (apply #'make-instance 'fs-frame
+ :pic (sl:make-picture width width
+ :parent parent
+ :ulc-x ulc-x)
+ :rdt (sl:make-readout width (- height width)
+ :info (format nil fmt-string index)
+ :parent parent
+ :ulc-x ulc-x
+ :ulc-y width)
+ :frame-index index
+ initargs))
+
+;;;----------------------------------
+
+(defmethod destroy ((frm fs-frame))
+
+ (sl:destroy (pic frm))
+ (sl:destroy (rdt frm))
+ (if (bg-image frm) (clx:free-pixmap (bg-image frm))))
+
+;;;----------------------------------
+
+(defun fs-set-color (obj color-gc fs)
+
+ "fs-set-color obj color-gc fs
+
+updates the color of each of the graphic primitives of the object obj
+in the display frames of filmstrip fs with graphic context color-gc."
+
+ (dolist (frm (fs-frames fs))
+ (dolist (prim (fg-prims frm))
+ (when (eq (object prim) obj)
+ (setf (color prim) color-gc)
+ (fs-display-frame frm)))))
+
+;;;----------------------------------
+
+(defun fs-add-contour (vol con fs)
+
+ "fs-add-contour vol con fs
+
+Adds the contour con associated with pstruct vol to the filmstrip fs
+in the fs-frame whose index is equal to the contour's z level. If no
+such fs-frame exists, creates a new one at that z-level and add to the
+fs-frames list."
+
+ (let* ((pic-width *mini-image-size*) ;; default frame width
+ (frm (find (z con) (fs-frames fs)
+ :key #'frame-index :test #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*))))
+ (prim (or (if frm (find vol (fg-prims frm) :key #'object))
+ (make-lines-prim
+ nil (sl:color-gc (display-color vol))
+ :object vol)))
+ (middle (round (/ pic-width 2))))
+ (declare (fixnum middle))
+ (draw-transverse (vertices con) prim middle middle (scale fs))
+ (if frm (push prim (fg-prims frm))
+ (let ((win (sl:window (viewport fs))))
+ (setq frm (make-fs-frame pic-width
+ (height fs) win
+ (z con) 0
+ (index-format fs)
+ :fg-prims (list prim)))
+ (ev:add-notify fs (sl:button-press (pic frm))
+ #'fs-picture-selected)
+ (setf (fs-frames fs)
+ (insert frm (fs-frames fs) :key #'frame-index))
+ (let* ((pos-newfrm (position frm (fs-frames fs)))
+ (current (left-frame-no fs))
+ (diff (- pos-newfrm current)))
+ (fs-set-viewport fs (if (and (>= diff 0)
+ (< diff (/ (clx:drawable-width win)
+ pic-width)))
+ current
+ pos-newfrm)))))
+ (fs-display-frame frm)))
+
+;;;----------------------------------
+
+(defun fs-delete-contour (vol z fs)
+
+ "fs-delete-contour vol z fs
+
+Deletes the contour associated with pstruct vol at z from the
+filmstrip. If this contour was the only information to be displayed
+at that plane (ie: no other contours or image), then deletes the
+entire fs-frame for that plane from the filmstrip."
+
+ (let ((frm (find z (fs-frames fs)
+ :test #'poly:nearly-equal :key #'frame-index)))
+ (when frm
+ (if (or (find z (images fs)
+ :test #'(lambda (a b)
+ (poly:nearly-equal a b *display-epsilon*))
+ :key #'(lambda (img) (vz (origin img))))
+ (find vol (fg-prims frm)
+ :key #'object :test-not #'eq))
+ (progn
+ (setf (fg-prims frm) ;; keep frame, delete contour
+ (remove vol (fg-prims frm) :key #'object))
+ (fs-display-frame frm))
+ (let ((left-pos (left-frame-no fs)) ;; delete the frame
+ (pos (position frm (fs-frames fs))))
+ (setf (fs-frames fs) (remove frm (fs-frames fs)))
+ (fs-set-viewport fs (if (or (/= pos left-pos)
+ (<= pos (length (fs-frames fs))))
+ left-pos ;; just close up
+ (1- pos))) ;; otherwise move over one
+ (ev:remove-notify fs (sl:button-press (pic frm)))
+ (destroy frm))))))
+
+;;;----------------------------------
+
+(defun fs-replace-points (old-pts new-pts index fs)
+
+ "fs-replace-points old-pts new-pts index fs
+
+Replaces the old points in filmstrip fs in frame with z equal to index
+with new points at z value index. If no frame exists at that index
+and new-pts is non-nil, create a new frame at that index and add to
+the filmstrip. If there are no new points and the existing frame is
+now empty, it is deleted from the filmstrip."
+
+ (let* ((pic-width *mini-image-size*)
+ (middle (round (/ pic-width 2)))
+ (scale (scale fs))
+ (frm (find index (fs-frames fs)
+ :test #'(lambda (a b)
+ (poly:nearly-equal a b *display-epsilon*))
+ :key #'frame-index))
+ (prims (mapcar #'(lambda (pt) ;; make new graphic prims
+ (make-rectangles-prim
+ (list (round (+ middle (* scale (x pt))))
+ (round (- middle (* scale (y pt))))
+ 2 2)
+ (sl:color-gc (display-color pt))
+ :object pt))
+ new-pts)))
+ (when old-pts ;; take off old gp's
+ (setf (fg-prims frm)
+ (remove-if #'(lambda (obj) (and (typep obj 'mark)
+ (find (id obj) old-pts :key #'id)))
+ (fg-prims frm)
+ :key #'object))
+ (if (or new-pts
+ (fg-prims frm)
+ (find index (images fs)
+ :test #'(lambda (a b)
+ (poly:nearly-equal a b *display-epsilon*))
+ :key #'(lambda (img) (vz (origin img)))))
+ (fs-display-frame frm)
+ (let ((left-pos (left-frame-no fs)) ;; delete the frame
+ (pos (position frm (fs-frames fs))))
+ (setf (fs-frames fs) (remove frm (fs-frames fs)))
+ (fs-set-viewport fs (if (or (/= pos left-pos)
+ (<= pos (length (fs-frames fs))))
+ left-pos ;; just close up
+ (1- pos))) ;; otherwise move over one
+ (ev:remove-notify fs (sl:button-press (pic frm)))
+ (destroy frm))))
+ (when new-pts
+ (if frm (setf (fg-prims frm) ;; just add new graphic prims
+ (append prims (fg-prims frm)))
+ (let ((win (sl:window (viewport fs)))) ;; or make a new frame
+ (setq frm (make-fs-frame pic-width
+ (height fs) win
+ index 0 (index-format fs)
+ :fg-prims prims))
+ (ev:add-notify fs (sl:button-press (pic frm))
+ #'fs-picture-selected)
+ (setf (fs-frames fs)
+ (insert frm (fs-frames fs) :key #'frame-index))
+ (let* ((pos-newfrm (position frm (fs-frames fs)))
+ (current (left-frame-no fs))
+ (diff (- pos-newfrm current)))
+ (fs-set-viewport fs (if (and (>= diff 0)
+ (< diff (/ (clx:drawable-width win)
+ pic-width)))
+ current
+ pos-newfrm)))))
+ (fs-display-frame frm))))
+
+;;;-----------------------------------
+
+(defmethod (setf index) :around (new-index (fs filmstrip))
+
+ "Updates the border highlight of the viewport pictures, moves the
+highlighted picture into the viewport if it isn't there already, and
+announces new-index when index is set."
+
+ ;; unhighlight old picture, highlight new one in filmstrip viewport
+ (let* ((old-frm (aif (index fs)
+ (find it (fs-frames fs)
+ :key #'frame-index
+ :test #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*)))))
+ (new-frm (find new-index (fs-frames fs)
+ :key #'frame-index
+ :test #'(lambda (a b)
+ (poly:nearly-equal a b *display-epsilon*)))))
+ (when old-frm
+ (setf (sl:border-width (pic old-frm)) 1)
+ (setf (sl:border-color (pic old-frm)) 'sl:white)
+ (sl:erase (pic old-frm))
+ (sl:draw-border (pic old-frm)))
+ (call-next-method)
+ (when new-frm
+ (setf (sl:border-width (pic new-frm)) 5)
+ (setf (sl:border-color (pic new-frm)) 'sl:red)
+ (sl:draw-border (pic new-frm))
+ ;; move the highlighted picture into the viewport if needed
+ (let* ((win (sl:window (pic new-frm)))
+ (dx (clx:drawable-x win))
+ (pic-width (clx:drawable-width win))
+ (vp-width (clx:drawable-width (sl:window (viewport fs)))))
+ (unless (<= 0 dx (- vp-width pic-width))
+ (fs-set-viewport fs (position new-frm (fs-frames fs))))))
+ (sl:flush-output))
+ (ev:announce fs (new-index fs) new-index)
+ new-index)
+
+;;;-----------------------------------
+
+(defun fs-set-viewport (fs left-pos)
+
+ "fs-set-viewport fs left-pos
+
+Adjusts the x coordinates of all the frame windows so that the frame
+in position left-pos in the fs-frames list of filmstrip fs is at the
+left end of the filmstrip."
+
+ (setf (left-frame-no fs) left-pos)
+ (when (fs-frames fs)
+ (let* ((width (sl:width (pic (first (fs-frames fs)))))
+ (x (- (* left-pos width))))
+ (dolist (frm (fs-frames fs))
+ (setf (clx:drawable-x (sl:window (pic frm))) x)
+ (setf (clx:drawable-x (sl:window (rdt frm))) x)
+ (incf x width)))))
+
+;;;-----------------------------------
+
+(defun fs-display-frame (frm)
+
+ "fs-display-frame frm
+
+refreshes the window of filmstrip frame frm by copying the background
+image pixmap if any, then replaying the graphic primitives and then
+exposing the data in the window, as in the usual graphic pipeline."
+
+ (let* ((img-px (bg-image frm))
+ (pic (pic frm))
+ (px (sl:pixmap pic)))
+ (if img-px
+ (clx:copy-area img-px (sl:color-gc 'sl:white) ;; image pixmap
+ 0 0
+ (clx:drawable-width img-px)
+ (clx:drawable-height img-px)
+ px 0 0)
+ (clx:draw-rectangle px (sl:color-gc 'sl:black) ;; or just set to black
+ 0 0
+ (clx:drawable-width px)
+ (clx:drawable-height px)
+ t)) ;; fill rectangle
+ (mapc #'(lambda (prim) (draw-pix prim px))
+ (fg-prims frm))
+ (sl:erase pic)
+ (sl:draw-border pic))
+ (sl:flush-output))
+
+;;;-----------------------------------
+
+(defun fs-picture-selected (fs pic code x y)
+
+ "fs-picture-selected fs pic code x y
+
+An action function that sets a new index value when a picture in the
+filmstrip is selected with the left mouse button and pointer, i.e.,
+code is 1."
+
+ (declare (ignore x y))
+ (when (= code 1) ;; left button only
+ (setf (index fs)
+ (frame-index (find pic (fs-frames fs) :key #'pic)))))
+
+;;;-----------------------------------
+
+(defun fs-move-frames (fs nframes)
+
+ "fs-move-frames fs nframes
+
+Shifts the view port, in the filmstrip fs, nframes picture widths to
+the left or right, depending on whether nframes is negative or
+positive, provided that at least one frame remains in the filmstrip at
+the left end of the viewport."
+
+ (let ((new-left-no (+ (left-frame-no fs) nframes)))
+ (when (and (>= new-left-no 0) ;; don't go off the left end
+ (< new-left-no (length (fs-frames fs)))) ;; or the right
+ (fs-set-viewport fs (setf (left-frame-no fs) new-left-no))
+ (sl:flush-output))))
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((fs filmstrip) &rest initargs)
+
+ "Initializes the user interface for the filmstrip."
+
+ (let* ((pic-size *mini-image-size*) ;; default pixmap size
+ (fsw (width fs))
+ (fsh (height fs))
+ (arrow-wd 50) ;; arrow button width
+ (frm (apply #'sl:make-frame fsw fsh
+ :title "Prism FILMSTRIP"
+ initargs))
+ (frm-win (sl:window frm))
+ (vp-width (- fsw (* 2 arrow-wd)))
+ (vp (apply #'sl:make-frame vp-width fsh
+ :parent frm-win
+ :ulc-x arrow-wd :ulc-y 0
+ initargs))
+ (left-b (apply #'sl:make-arrow-button arrow-wd fsh :left
+ :parent frm-win
+ :fg-color 'sl:red
+ :ulc-x 0 :ulc-y 0
+ initargs))
+ (right-b (apply #'sl:make-arrow-button arrow-wd fsh :right
+ :parent frm-win
+ :fg-color 'sl:red
+ :ulc-x (- fsw arrow-wd) :ulc-y 0
+ initargs)))
+ (setf (fr fs) frm
+ (viewport fs) vp
+ (left-arrow fs) left-b
+ (right-arrow fs) right-b)
+ ;; create frames for images if present
+ (when (images fs)
+ (let* ((vp-win (sl:window vp))
+ (ulc-x (- pic-size))
+ (graymap (sl:make-graymap (window fs) (level fs)
+ (range (first (images fs)))))
+ (img-dims (array-dimensions (pixels (first (images fs)))))
+ (mapped-image (make-array img-dims
+ :element-type 'clx:pixel))
+ (scaled-image (make-array (list pic-size pic-size)
+ :element-type 'clx:pixel))
+ (mag (/ pic-size (first img-dims)))
+ (x0 0)
+ (y0 0)
+ )
+ (setf (fs-frames fs)
+ (sort (mapcar #'(lambda (img)
+ (make-fs-frame
+ pic-size fsh vp-win (vz (origin img))
+ (incf ulc-x pic-size) (index-format fs)
+ :bg-image ;; transform image to pixmap
+ (let ((px (sl:make-square-pixmap pic-size
+ nil vp-win)))
+ (sl:map-image graymap (pixels img)
+ mapped-image)
+ (scale-image mapped-image scaled-image
+ mag x0 y0)
+ (sl:write-image-clx scaled-image px)
+ px))) ;; must return it from the let
+ (images fs))
+ #'<
+ :key #'frame-index))
+ (setf (index fs) (frame-index (first (fs-frames fs)))
+ (scale fs) (* mag (pix-per-cm (first (images fs))))))
+ (mapc #'(lambda (frm)
+ (ev:add-notify fs (sl:button-press (pic frm))
+ #'fs-picture-selected)
+ (fs-display-frame frm))
+ (fs-frames fs))
+ )
+ (ev:add-notify fs (sl:button-on left-b)
+ #'(lambda (strip bt)
+ (declare (ignore bt))
+ (fs-move-frames strip -1)))
+ (ev:add-notify fs (sl:button-on right-b)
+ #'(lambda (strip bt)
+ (declare (ignore bt))
+ (fs-move-frames strip 1)))
+ (ev:add-notify fs (sl:button-2-on left-b)
+ #'(lambda (strip bt)
+ (declare (ignore bt))
+ (fs-move-frames strip -5)))
+ (ev:add-notify fs (sl:button-2-on right-b)
+ #'(lambda (strip bt)
+ (declare (ignore bt))
+ (fs-move-frames strip 5)))))
+
+;;;-----------------------------------
+;;; End.
diff --git a/prism/src/image-graphics.cl b/prism/src/image-graphics.cl
new file mode 100644
index 0000000..372764b
--- /dev/null
+++ b/prism/src/image-graphics.cl
@@ -0,0 +1,248 @@
+;;;
+;;; image-graphics
+;;;
+;;; the draw methods for medical images in views
+;;;
+;;; 30-Jul-2000 I. Kalet split off from medical images, to make things
+;;; more modular.
+;;; 6-Aug-2000 I. Kalet move get-transverse-image back to
+;;; medical-images, since not view related.
+;;; 3-Sep-2000 I. Kalet take out resizing of image - not needed.
+;;; 7-Nov-2000 I. Kalet fix DRR size and position according to beam
+;;; and image data set, not the view, since GL rescales it anyway.
+;;; 13-Dec-2000 I. Kalet add use of drr-cache in beam, to avoid
+;;; unnecessary recomputing of DRR for beam's eye view, MLC panel,
+;;; block panel, and electron portal editor.
+;;; 2-Oct-2002 I. Kalet punt on generate-image-from-set for views
+;;; that don't have more specific methods
+;;; 3-Jan-2009 I. Kalet change draw method to use CLX instead of
+;;; OpenGL - do pan and zoom with scale-image and call write-image-clx.
+;;;
+
+(in-package :prism)
+
+;;;------------------------------------------
+
+(defmethod draw ((im image-2d) (v view))
+
+ "Draws image im in view v. Same code for almost all types of views
+- the caller must provide the right image data for whatever view is
+drawn into."
+
+ (let* ((scale (* (scale v)
+ (if (typep v 'beams-eye-view)
+ (/ (- (isodist (beam-for v))
+ (view-position v))
+ (isodist (beam-for v)))
+ 1.0)))
+ (im-ppcm (pix-per-cm im))
+ (mag (/ scale im-ppcm))
+ (im-x0 (- (round (* (view-x0-from-image v im) im-ppcm))))
+ (im-y0 (round (* (view-y0-from-image v im) im-ppcm)))
+ (x0 (- im-x0 (/ (x-origin v) mag)))
+ (y0 (- im-y0 (/ (y-origin v) mag)))
+ (imtmp (or (image-cache v)
+ (setf (image-cache v)
+ (sl:map-image (sl:make-graymap (window v) (level v)
+ (range im))
+ (pixels im))))))
+ (scale-image imtmp (scaled-image v) mag x0 y0)
+ (sl:write-image-clx (scaled-image v) (background v))))
+
+;;;------------------------------------------
+
+(defmethod view-x0-from-image ((v transverse-view) im)
+
+ "returns the appropriate coordinate corresponding to the type of
+view."
+
+ (vx (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-x0-from-image ((v coronal-view) im)
+
+ (vx (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-x0-from-image ((v sagittal-view) im)
+
+ (vz (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-x0-from-image ((v beams-eye-view) im)
+
+ (vx (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-y0-from-image ((v transverse-view) im)
+
+ "returns the appropriate coordinate corresponding to the type of
+view."
+
+ (vy (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-y0-from-image ((v coronal-view) im)
+
+ (- (vz (origin im))))
+
+;;;------------------------------------------
+
+(defmethod view-y0-from-image ((v sagittal-view) im)
+
+ (vy (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-y0-from-image ((v beams-eye-view) im)
+
+ (vy (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-pos-from-image ((v transverse-view) im)
+
+ "returns the appropriate coordinate corresponding to the type of
+view."
+
+ (vz (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-pos-from-image ((v coronal-view) im)
+
+ (vy (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-pos-from-image ((v sagittal-view) im)
+
+ (vx (origin im)))
+
+;;;------------------------------------------
+
+(defmethod view-pos-from-image ((v beams-eye-view) im)
+
+ (declare (ignore im))
+ (view-position v))
+
+;;;------------------------------------------
+
+(defmethod generate-image-from-set ((v transverse-view) images)
+
+ "generate-image-from-set v images
+
+Selects the transverse image that matches the view v."
+
+ (find-transverse-image (view-position v) images *display-epsilon*))
+
+;;;------------------------------------------
+
+(defmethod generate-image-from-set ((v coronal-view) images)
+
+ (make-coronal-image (view-position v) images))
+
+;;;------------------------------------------
+
+(defmethod generate-image-from-set ((v sagittal-view) images)
+
+ (make-sagittal-image (view-position v) images))
+
+;;;------------------------------------------
+
+(defmethod generate-image-from-set ((v beams-eye-view) images)
+
+ "Returns a computed radiograph image-2d to use as background image
+for the view v."
+
+ (remove-bg-drr v)
+
+ (let* ((fi (first images)) ;; need to compute these from the images
+ (orig (origin fi))
+ (size (size fi))
+ (xmin (aref orig 0))
+ (xmax (+ xmin (first size)))
+ (ymax (aref orig 1))
+ (ymin (- ymax (second size)))
+ (im-pix (pixels fi))
+ (xpix (array-dimension im-pix 0))
+ (ypix (array-dimension im-pix 1))
+ (pix-per-cm (pix-per-cm fi))
+ (x-cm (/ xpix pix-per-cm))
+ (y-cm (/ ypix pix-per-cm))
+ (bm (beam-for v))
+ (couch-displacement (make-array 3 :element-type 'single-float
+ :initial-contents
+ (list
+ (couch-lateral bm)
+ (couch-height bm)
+ (couch-longitudinal bm))))
+ (g-to-p (coll-to-couch-transform (couch-angle bm)
+ (gantry-angle bm)
+ 0.0))
+ (eyept (matrix-multiply g-to-p 0.0 0.0 (isodist bm)))
+ (centerpt couch-displacement)
+ (uppt (matrix-multiply g-to-p 0.0 (/ y-cm 2.0) 0.0)))
+
+ ;; handle couch-space to patient-space conversion
+ (dotimes (i 3)
+ (decf (aref eyept i) (aref couch-displacement i))
+ (decf (aref uppt i) (aref couch-displacement i))
+ ;; note - the following is a reuse of the couch-displacement array
+ (setf (aref centerpt i) (- (aref couch-displacement i))))
+ (multiple-value-bind (voxarray zarray) (make-3d-image images)
+ (make-instance 'image-2d
+ :id 3 ;; arbitrary
+ :description "Prism drr image"
+ :acq-date (date-time-string)
+ :acq-time ""
+ :scanner-type (scanner-type fi)
+ :hosp-name (hosp-name fi)
+ :img-type (concatenate 'string "DRR computed from "
+ (img-type fi))
+ :origin (let* ((bev-tr (bev-transform v))
+ (iso-x (+ (* (aref bev-tr 0) (aref centerpt 0))
+ (* (aref bev-tr 1) (aref centerpt 1))
+ (* (aref bev-tr 2) (aref centerpt 2))
+ (aref bev-tr 3)))
+ (iso-y (+ (* (aref bev-tr 4) (aref centerpt 0))
+ (* (aref bev-tr 5) (aref centerpt 1))
+ (* (aref bev-tr 6) (aref centerpt 2))
+ (aref bev-tr 7))))
+ (vector (- iso-x (/ x-cm 2.0))
+ (+ iso-y (/ y-cm 2.0))
+ 0.0))
+ :size (list x-cm y-cm)
+ :range (range fi)
+ :units (units fi)
+ :thickness 1.0
+
+ ;; not correct - should represent the orientation of the BEV
+ :x-orient (vector 1.0 0.0 0.0)
+ :y-orient (vector 0.0 -1.0 0.0)
+
+ :pix-per-cm pix-per-cm
+ :pixels (or (drr-cache bm)
+ (setf (drr-cache bm)
+ (drr (list xmin ymin)
+ (list xmax ymax)
+ zarray
+ eyept centerpt uppt
+ xpix ypix voxarray v)))))))
+
+;;;------------------------------------------
+
+(defmethod generate-image-from-set ((v view) images)
+
+ "If no better method, just return nil"
+
+ (declare (ignore images))
+ nil)
+
+;;;------------------------------------------
+;;; End.
diff --git a/prism/src/image-manager.cl b/prism/src/image-manager.cl
new file mode 100644
index 0000000..0ee61c1
--- /dev/null
+++ b/prism/src/image-manager.cl
@@ -0,0 +1,263 @@
+;;;
+;;; image-manager
+;;;
+;;; Mediators and functions to keep images displayed in views
+;;; consistent with the view position etc.
+;;;
+;;; 16-Oct-1992 J. Unger initial revision, using object-manager code
+;;; as a guide.
+;;; 13-Dec-1992 J. Unger modify refresh-image so that it calls draw if
+;;; there is an image at that z-level and otherwise deletes the
+;;; image-primitive object from the view if there is no such image at
+;;; this z-level. Also add draw command to image-view-mediator
+;;; init-inst method.
+;;; 31-Dec-1992 I. Kalet reorganize refresh function for image-view
+;;; mediator, since there is no image graphic primitive. Also set
+;;; origin and scale of view after drawing new image in refresh-image
+;;; 06-Jan-1993 J. Unger enhance refresh-view to compute reformatted images
+;;; for subsequent display in coronal & sagittal views on demand. Also
+;;; add a current-image cache to image-view-mediator to make the drawing
+;;; of cor/sag images more efficient.
+;;; 07-Jan-1993 J. Unger modify make-sagittal-image and make-coronal-image
+;;; to consider the origin of each slice from the original image set to
+;;; lie in the middle of the image's thickness (so anatomy appears in the
+;;; center of each strip, rather than on one end).
+;;; 24-Mar-1993 J. Unger fix type declaration related problems for cmucl
+;;; compiler.
+;;; 1-May-1993 I. Kalet move some functions to medical-images module
+;;; 5-Nov-1993 I. Kalet reset view origin and/or scale on image
+;;; refresh if changed while image is not displayed.
+;;; 18-Apr-1994 I. Kalet update refs to view origin
+;;; 8-Jan-1995 I. Kalet remove proclaim form
+;;; 3-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx.
+;;; 10-Jul-1998 I. Kalet in refresh-image check if BEV, to make new
+;;; image in that case.
+;;; 12-Aug-1998 I. Kalet add code to update DRR if BEV changes.
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 5-Jan-2000 I. Kalet relax plane match criterion for display.
+;;; 27-Jun-2000 I. Kalet parametrize format for printing plane z value
+;;; 16-Jul-2000 I. Kalet reorganize refresh-image for OpenGL rendering
+;;; of images in views.
+;;; 4-Sep-2000 I. Kalet finish reorg for OpenGL: eliminate special
+;;; handling of beam's eye views, eliminate window and level caches,
+;;; handle explicit announcements instead of former generic refresh-bg.
+;;; 13-Dec-2000 I. Kalet need *some* special handling of beam's eye
+;;; views, for DRR, including default display-func for progressive
+;;; display of DRR as it is generated, band by band.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defclass image-view-manager ()
+
+ ((image-set :type list
+ :accessor image-set
+ :initarg :image-set
+ :documentation "The set of image-2D's that are to appear
+in the views.")
+
+ (view-set ;; :type coll:collection
+ :accessor view-set
+ :initarg :view-set
+ :documentation "The set of views for some plan.")
+
+ (mediator-set ;; :type coll:collection
+ :accessor mediator-set
+ :initform (coll:make-collection)
+ :documentation "The set of image-view mediators.
+Each one handles updates of a particular view for a particular image
+set. They are created when a view is created and added to the image
+set. They are deleted when a view is deleted.")
+
+ )
+
+ (:documentation "This is the object that creates and deletes the
+mediators for an set of image-2D's to appear in a given set of views.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defclass image-view-mediator ()
+
+ ((images :reader images
+ :initarg :images
+ :documentation "The list of images this mediator manages
+views for.")
+
+ (view :reader view
+ :initarg :view
+ :documentation "The view in which an image may appear.")
+
+ (image :accessor image
+ :initarg :image
+ :initform nil
+ :documentation "A cache containing the image most recently
+associated with the view.")
+
+ ))
+
+;;;--------------------------------------------------
+
+(defun refresh-image (ivm v)
+
+ "refresh-image ivm v
+
+Refreshes the image determined by the image-view-mediator ivm's images
+list and view v's view-position to the screen."
+
+ (if (or (null (image ivm))
+ ;; compare view position with image position wrt. view
+ (not (poly:nearly-equal (view-position v)
+ (view-pos-from-image v (image ivm))
+ *display-epsilon*)))
+ ;; try to generate the required image
+ (let ((im (generate-image-from-set v (images ivm))))
+ (setf (image ivm) im)
+ (setf (image-cache v) nil)
+ (if im (draw im v)
+ (progn
+ (format t (concatenate 'string
+ "No image at plane " *display-format* "~%")
+ (view-position v))
+ (clx:draw-rectangle (background v) ; fill area with black
+ (sl:color-gc 'sl:black)
+ 0 0
+ (clx:drawable-width (background v))
+ (clx:drawable-height (background v))
+ t))))
+ ;; image present, so refresh as necessary
+ (draw (image ivm) v)))
+
+;;;--------------------------------------------------
+
+(defmethod initialize-instance :after ((ivm image-view-mediator)
+ &rest initargs)
+
+ "Draws the relevant image in the view initially as well as
+registering for future updates."
+
+ (declare (ignore initargs))
+ (let ((v (view ivm)))
+ (ev:add-notify ivm (new-position v)
+ #'(lambda (med vw newpos)
+ (declare (ignore newpos))
+ (if (background-displayed vw)
+ (refresh-image med vw)
+ (setf (image med) nil
+ (image-cache vw) nil))))
+ (ev:add-notify ivm (new-scale v)
+ #'(lambda (med vw newscl)
+ (declare (ignore newscl))
+ (if (background-displayed vw)
+ (draw (image med) vw)
+ (setf (image-cache vw) nil))))
+ (ev:add-notify ivm (new-origin v)
+ #'(lambda (med vw org)
+ (declare (ignore org))
+ (if (background-displayed vw)
+ (draw (image med) vw)
+ (setf (image-cache vw) nil))))
+ (ev:add-notify ivm (new-winlev v)
+ #'(lambda (med vw)
+ (setf (image-cache vw) nil)
+ (if (background-displayed vw)
+ (draw (image med) vw))))
+ (ev:add-notify ivm (bg-toggled v)
+ #'(lambda (med vw)
+ (if (background-displayed vw)
+ (unless (image-cache vw)
+ (refresh-image med vw)))))
+ ;; some extra initialization for BEVs
+ (when (typep v 'beams-eye-view)
+ ;; this is in case the *direction* of the view's beam changes
+ ;; we need to find a better way to detect and handle it.
+ (ev:add-notify ivm (reset-image v)
+ #'(lambda (med vw)
+ (setf (image med) nil)
+ (setf (image-cache vw) nil)
+ (setf (background-displayed vw) nil)))
+ (if (not (display-func v))
+ (setf (display-func v) #'(lambda (bev)
+ (setf (image-cache bev) nil)
+ (draw (image ivm) bev)
+ (display-view bev)))))
+ (when (background-displayed v)
+ (refresh-image ivm v)
+ (display-view v))))
+
+;;;--------------------------------------------------
+
+(defun make-image-view-mediator (images view)
+
+ "make-image-view-mediator images view
+
+Makes and returns a mediator between a list of images and a view.
+When a new position event is announced by the view, the image on the
+list corresponding to the value of the new position along the axis
+perpendicular to the view is displayed in the view. If no such image
+corresponds, the backing pixmap of the view is erased but the view is
+not changed otherwise."
+
+ (make-instance 'image-view-mediator :images images :view view))
+
+;;;--------------------------------------------------
+
+(defmethod destroy ((ivm image-view-mediator))
+
+ (ev:remove-notify ivm (new-position (view ivm)))
+ (ev:remove-notify ivm (new-scale (view ivm)))
+ (ev:remove-notify ivm (new-origin (view ivm)))
+ (ev:remove-notify ivm (new-winlev (view ivm)))
+ (ev:remove-notify ivm (bg-toggled (view ivm)))
+ (if (typep (view ivm) 'beams-eye-view)
+ (ev:remove-notify ivm (reset-image (view ivm))))
+ )
+
+;;;--------------------------------------------------
+
+(defmethod initialize-instance :after ((m image-view-manager)
+ &rest initargs)
+
+ "Fills the mediator set by iterating over views with images
+and creates the links to dynamically create and delete mediators as
+necessary when objects and views are created and deleted."
+
+ (declare (ignore initargs))
+ (let ((is (image-set m))
+ (vs (view-set m)))
+ (dolist (v (coll:elements vs))
+ (coll:insert-element (make-image-view-mediator is v)
+ (mediator-set m)))
+ (ev:add-notify m (coll:inserted vs)
+ #'(lambda (md a v)
+ (declare (ignore a))
+ (coll:insert-element
+ (make-image-view-mediator is v)
+ (mediator-set md))))
+ (ev:add-notify m (coll:deleted vs)
+ #'(lambda (md a v)
+ (declare (ignore a))
+ (let ((med-set (mediator-set md)))
+ (dolist (med (coll:elements med-set))
+ (when (eq (view med) v)
+ (coll:delete-element med med-set)
+ (destroy med))))))))
+
+;;;--------------------------------------------------
+
+(defun make-image-view-manager (image-set view-set)
+
+ "make-image-view-manager image-set view-set
+
+Returns an instance of an image-view-manager, a mediator between a
+set of images and a set of views they appear in."
+
+ (make-instance 'image-view-manager
+ :image-set image-set
+ :view-set view-set))
+
+;;;--------------------------------------------------
+;;; End.
diff --git a/prism/src/import-structure-sets.cl b/prism/src/import-structure-sets.cl
new file mode 100644
index 0000000..0818639
--- /dev/null
+++ b/prism/src/import-structure-sets.cl
@@ -0,0 +1,299 @@
+;;;
+;;; import-structure-sets
+;;;
+;;; 6 May 03 M Phillips
+;;; A panel for importing structure sets into the Prism current patient
+;;; case from user-specified files. This was originally the file
+;;; IMPORT-ANATOMY. It has been modified to work with enhancements to
+;;; the DICOM server in handling structure sets. It is more hard-wired
+;;; for directories and what is in each file, than was the old version.
+;;;
+;;; 15-May-2003 BobGian provide branch for "structure.index" file not found.
+;;; 30-May-2003 BobGian add mechanism to lock structure Z-coodinates to
+;;; Z-coordinate of nearest image slice. Image set must be pre-loaded.
+;;; 06-Jun-2003 BobGian: ORIGIN slot of IMAGE is declared to be
+;;; (VECTOR SINGLE-FLOAT 3) but it is (SIMPLE-ARRAY T 3) instead, as created
+;;; by GET-ALL-OBJECTS. Type-casting error in Z-coord justification fcn.
+;;; 12-Jun-2003 BobGian parameterize structure-set directory as value
+;;; of variable *structure-database*. Also, IMPORT-STRUCTURE-SET removed;
+;;; MAKE-IMPORT-STRUCTURE-SET-PANEL called directly from *SPECIAL-TOOLS*.
+;;; 22-Aug-2003 BobGian add 180-degree rotation to structure-set contour vertex
+;;; set when structure-set corresponds to image from a patient scanned prone
+;;; (that is, PAT-POS of image is "HFP" or "FFP").
+;;; 13-Nov-2009 I. Kalet Modify initialization method for
+;;; import-structure-set-panel to allow for importing structure sets
+;;; without having a corresponding image set. There was no reason to
+;;; require it, though it is important to match the Z values when an
+;;; image set is present. This was initially in a patch file,
+;;; struct-import-patch, loaded at run time, which is now no longer needed.
+;;;
+
+(in-package :Prism)
+
+;;;------------------------------------------------------
+
+(defclass import-structure-set-panel (generic-panel)
+
+ ((patient-of :accessor patient-of
+ :initarg :patient-of
+ :documentation "The patient - needed for list of plans")
+ (panel-frame :accessor panel-frame
+ :documentation "Slik frame for this panel")
+ (cancel-but :accessor cancel-but
+ :documentation "The cancel panel button.")
+ (accept-but :accessor accept-but
+ :documentation "The accept button for the function.")
+ (namelist-but :accessor namelist-but
+ :documentation "Allows user to select file using a menu.")
+ (pat-name :accessor pat-name
+ :documentation "Readout with name of patient if obtained from
+ namelist")
+ (objects-scr :accessor objects-scr
+ :documentation "Scrolling list that contains all the
+ objects available to import.")
+ (objects-title :accessor objects-title)
+ )
+ (:documentation "Panel for importing anatomy data from an external
+ non-Prism data file.")
+ )
+
+;;;-----------------------------------------------------------
+
+(defmethod initialize-instance :after ((issp import-structure-set-panel)
+ &rest initargs)
+
+ (let* ((btw 100)
+ (bth 25)
+ (isspfr (apply #'sl:make-frame 375 375
+ :title "INSERT STRUCTURE SET PANEL"
+ :bg-color 'sl:gray initargs))
+ (win (sl:window isspfr))
+ (cancel-b (apply #'sl:make-button btw bth
+ :label "CANCEL" :parent win
+ :ulc-x 225 :ulc-y 345
+ :bg-color 'sl:red
+ :fg-color 'sl:black
+ initargs))
+ (accept-b (apply #'sl:make-button btw bth
+ :label "ACCEPT" :parent win
+ :ulc-x 15 :ulc-y 345
+ :bg-color 'sl:green
+ :fg-color 'sl:black
+ initargs))
+ (namelist-but (apply #'sl:make-button (+ 30 (* 2 btw)) bth
+ :label "AVAILABLE STRUCTURE SETS"
+ :parent win
+ :ulc-x 15 :ulc-y 15
+ initargs))
+ (pat-name (apply #'sl:make-readout 310 bth
+ :bg-color 'sl:yellow :fg-color 'sl:black
+ :label "Patient name: "
+ :ulc-x 15 :ulc-y 50 :parent win initargs))
+ (objects-title (apply #'sl:make-readout 200 bth
+ :ulc-x 15 :ulc-y 100
+ :info "AVAILABLE OBJECTS"
+ :parent win initargs))
+ (objects-scr (apply #'sl:make-scrolling-list 200 200
+ :ulc-x 15 :ulc-y 125
+ :parent win initargs))
+ (s-file (concatenate 'string *structure-database* "structure.index"))
+ (objects-alist '()) ; association list for scrolling list
+ (selected-list '()) ; list for structures selected by user
+ (selected-name nil) ; patient name read from structure set file
+ (selected-file nil))
+
+ (setf (panel-frame issp) isspfr
+ (cancel-but issp) cancel-b
+ (accept-but issp) accept-b
+ (namelist-but issp) namelist-but
+ (objects-title issp) objects-title
+ (objects-scr issp) objects-scr
+ (pat-name issp) pat-name)
+
+ (ev:add-notify issp (sl:button-on cancel-b)
+ #'(lambda (panel button)
+ (declare (ignore button))
+ (destroy panel)))
+
+ (ev:add-notify issp (sl:button-on accept-b)
+ #'(lambda (panel button)
+ (cond
+ ((= 0 (patient-id (patient-of panel)))
+ (sl:acknowledge "Patient needs to be selected.")
+ (setf (sl:on button) nil))
+ ((null selected-list)
+ (sl:acknowledge "Please select at least one structure.")
+ (setf (sl:on button) nil))
+ ((sl:confirm
+ (format nil
+ "Prism patient is [ ~A ]. Selected patient is [ ~A ]."
+ (name (patient-of panel)) selected-name))
+ (let* ((pat (patient-of panel))
+ (images (image-set pat)))
+ (cond ((consp images)
+ (let* ((pat-position (pat-pos (first images)))
+ (prone? (or (string= pat-position "HFP")
+ (string= pat-position "FFP")))
+ (z-coords
+ (mapcar #'(lambda (im)
+ (aref (origin im) 2))
+ images)))
+ (dolist (struct selected-list)
+ (justify-coordinates struct z-coords prone?)
+ (cond ((typep struct 'organ)
+ (coll:insert-element struct (anatomy pat)))
+ ((typep struct 'tumor)
+ (coll:insert-element struct (findings pat)))
+ ((typep struct 'target)
+ (coll:insert-element struct (targets pat)))))
+ (destroy panel)))
+ (t (if (sl:confirm '("No image set loaded."
+ "Are you sure you want to proceed?"))
+ (progn
+ (dolist (struct selected-list)
+ (cond ((typep struct 'organ)
+ (coll:insert-element
+ struct (anatomy pat)))
+ ((typep struct 'tumor)
+ (coll:insert-element
+ struct (findings pat)))
+ ((typep struct 'target)
+ (coll:insert-element
+ struct (targets pat)))))
+ (destroy panel))
+ (setf (sl:on button) nil))))))
+ (t (setf (sl:on button) nil)))))
+
+ (ev:add-notify issp (sl:button-on namelist-but)
+ #'(lambda (panel button)
+ ;clean up buttons made by previous selection if present
+ (dolist (o objects-alist)
+ (sl:delete-button (cdr o) objects-scr))
+ (setq objects-alist '())
+ (setq selected-name nil)
+ (cond
+ ((null (image-set (patient-of panel)))
+ (sl:acknowledge "No image set loaded."))
+ ((probe-file s-file)
+ ; read in structures.index and put them in scrolling list
+ (let ((input-list '())
+ (selected-index nil))
+ (with-open-file (in s-file :direction :input)
+ (loop
+ (let ((s (read in nil nil)))
+ (cond (s (push s input-list))
+ (t (return))))))
+ (setq selected-index
+ (sl:popup-scroll-menu
+ (mapcar
+ #'(lambda (x) (format nil "~A" x))
+ (mapcar #'cdr input-list))
+ 700 200))
+ (when selected-index
+ (setq selected-file
+ (format nil
+ "~Apat-~D.structure-set"
+ *structure-database*
+ (car (nth selected-index input-list))))
+ (dolist (obj (get-all-objects selected-file))
+ (cond
+ ((null obj)
+ (sl:acknowledge "Error in object. It is NIL."))
+ ((null (contours obj))
+ (sl:acknowledge "No contours in object."))
+ ((or (typep obj 'organ)
+ (typep obj 'tumor)
+ (typep obj 'target))
+ (setq selected-name
+ (second (nth selected-index input-list)))
+ (setf (sl:info (pat-name issp)) selected-name)
+ (let ((btn (sl:make-list-button
+ objects-scr
+ (format nil "~A" (name obj)))))
+ (sl:insert-button btn objects-scr)
+ (setq objects-alist (acons obj btn objects-alist)))
+ ))))))
+ (t (sl:acknowledge "No structure-sets found.")))
+ (setf (sl:on button) nil)))
+
+ (ev:add-notify issp (sl:selected objects-scr)
+ #'(lambda (issp objects-scr btn)
+ (declare (ignore issp objects-scr))
+ (let ((object (first (rassoc btn objects-alist))))
+ (setq selected-list (append selected-list (list object)))
+ (format t "~%Selected-list: ~S" selected-list))))
+
+ (ev:add-notify issp (sl:deselected objects-scr)
+ #'(lambda (issp objects-scr btn)
+ (declare (ignore issp objects-scr))
+ (let ((object (first (rassoc btn objects-alist))))
+ (format t "~%Object: ~S" object)
+ (setq selected-list (remove object selected-list))
+ (format t "~%New selected-list: ~S" selected-list))))))
+
+;;;-----------------------------------------------------------
+
+(defun justify-coordinates (obj z-coords prone?)
+
+ ;; OBJ is an ORGAN, TUMOR, or TARGET object.
+ ;; Z-COORDS is a LIST of Z-coordinates [each a FLONUM] representing
+ ;; the Z-coordinate of an image in the patient's image-set.
+ ;; PRONE? is T or NIL indicating Prone or Supine, respectively.
+
+ ;; We destructively modify the coordinates of the object [that is,
+ ;; the Z of the CONTOUR in the CONTOURS slot of OBJ, and the X and Y
+ ;; coords of the contour vertices if PRONE? is T] here.
+ ;; That is OK since the object was newly-created via GET-ALL-OBJECTS.
+
+ (dolist (contour-obj (contours obj))
+ (do ((structure-z-val (z contour-obj))
+ (coordlist z-coords (cdr coordlist))
+ (image-z-val 0.0)
+ (this-difference 0.0)
+ (best-difference 1000000.0)
+ (best-struc-z-val 0.0))
+ ((null coordlist)
+ (setf (z contour-obj) best-struc-z-val)
+
+ ;; If image is oriented prone, rotate contour vertices by 180 degrees
+ ;; by multiplying by -1.0 each of the X and Y coordinates.
+ (when prone?
+ (dolist (vert (vertices contour-obj))
+ ;; Iterate through the two [X and Y] coordinates of each vertex.
+ (do ((coords vert (cdr coords)))
+ ((null coords))
+ (setf (car coords)
+ (* -1.0 (car coords)))))))
+
+ (declare (type list coordlist)
+ (type single-float structure-z-val image-z-val
+ this-difference best-difference best-struc-z-val))
+
+ ;; Find Z coordinate in image nearest Z coordinate in structure-set,
+ ;; and assign that coordinate as new Z coordinate for structure-set.
+ (setq image-z-val (car coordlist))
+ (when (< (setq this-difference (abs (- structure-z-val image-z-val)))
+ best-difference)
+ (setq best-struc-z-val image-z-val)
+ (setq best-difference this-difference)))))
+
+;;;-----------------------------------------------------------
+
+(defmethod destroy :before ((issp import-structure-set-panel))
+
+ (sl:destroy (cancel-but issp))
+ (sl:destroy (accept-but issp))
+ (sl:destroy (objects-title issp))
+ (sl:destroy (objects-scr issp))
+ (sl:destroy (namelist-but issp))
+ (sl:destroy (pat-name issp))
+ (sl:destroy (panel-frame issp)))
+
+;;;-----------------------------------------------------------
+
+(defun make-import-structure-set-panel (pat &rest initargs)
+
+ (apply #'make-instance 'import-structure-set-panel :patient-of pat initargs))
+
+;;;--------------------------------------------------------------------
+;;; End.
diff --git a/prism/src/imrt-segments.cl b/prism/src/imrt-segments.cl
new file mode 100644
index 0000000..386d57f
--- /dev/null
+++ b/prism/src/imrt-segments.cl
@@ -0,0 +1,589 @@
+;;;
+;;; imrt-segments
+;;;
+;;; Handle multi-segment IMRT beams composed of ordinary Prism beams
+;;; Contains functions used in Client only.
+;;;
+;;; At this writing (Sep 2001) Prism does not provide a multisegment beam
+;;; class. In the output list of Prism beams sent, some beams are
+;;; interpreted as static beams, while other *consecutive sequences* of
+;;; ordinary Prism beams are interpreted as dynamic (multisegment) beams.
+;;;
+;;; 01-Oct-2001 J. Jacky calc-seg-info,segment-violations from dicom-panel.cl
+;;; 08-Nov-2001 BobGian: Add missing IN-PACKAGE form.
+;;; 27-Aug-2003 BobGian: Uniformize variable names in preparation
+;;; for adding Dose Monitoring Points.
+;;; 03-Oct-2003 BobGian: Change defstruct name and slot names in SEG-REC-...
+;;; to SEGMENT-DESCRIPTOR-... to make DMP code more readable.
+;;; Ditto with a few local variables.
+;;; STATIC, DYNAMIC, SEGMENT (Prism pkg) -> Keyword pkg.
+;;; 04-Oct-2003 BobGian: Rewrite CALC-SEG-INFO to add DMPs and
+;;; to improve understandability.
+;;; 07-Oct-2003 BobGian: CALC-SEG-INFO input includes DMP list, which is passed
+;;; to new slot in SEGMENT-DESCRIPTOR object (shared with all segs in beam).
+;;; 07-Oct-2003 BobGian: Move ADD-SEG-INFO "dicom-panel.cl -> here.
+;;; 14-Nov-2003 BobGian: Fix bug: DMP list was not being pooled over all segs
+;;; belonging to a beam.
+;;; 24-Nov-2003 BobGian: DMP auto-replication scheme altered. In function
+;;; ADD-SEG-INFO, the DMP list is scanned, and shared DMPs [contributed to
+;;; by more than one beam] are replicated so that one shared DMP remains
+;;; [whose dose slot values are updated to be cumulative over all beams
+;;; sharing this DMP] and one new DMP is created for each beam in which the
+;;; shared DMP appears and which is contributed to only by that one beam.
+;;; Each auto-replicated DMP gets a name formed by concatenating the point
+;;; name and the beam name. The newly-created, single-beam DMPs must be
+;;; placed AHEAD of the shared DMPs on the DMP list for each beam, so that
+;;; ASSEMBLE-FRACTION-GROUPS can calculate the correct value for the output
+;;; component 300A:0084 Beam Dose, which is based on dose at the norm point
+;;; DMP from a single beam rather than on the combined dose at the norm
+;;; point from all beams contributing to a DMP shared by multiple beams.
+;;; [See changelog notes, same date, in "dicom-panel" and "dicom-rtplan".]
+;;; 25-Nov-2003 BobGian: Finished auto-replication of DMPs by ADD-SEG-INFO.
+;;; Needs additional DMP-CNT arg to allow counting while replicating.
+;;; 26-Nov-2003 BobGian: Added DMP name creation via concatenation of Point
+;;; and Beam names for DMPs auto-replicated from a shared DMP but specific
+;;; to each beam separately. Ditto calculation of their other slot values.
+;;; 28-Nov-2003 BobGian: Move DMP defstruct "dicom-rtplan" -> here to
+;;; simplify dependencies.
+;;; 04-Dec-2003 BobGian: SEGMENT-DESCRIPTOR-... -> SEGDATA-... (less clutter).
+;;; 15-Dec-2003 BobGian: CALC-SEG-INFO needs <OrigBmInst> and <CurrBmInst>.
+;;; Fixed errors in beam segment dose accumulation and DMP auto-replication.
+;;; 25-Dec-2002 BobGian: Flushed all "...OTHER-..." slots. Now allocate a
+;;; separate DMP object for each segment in which the DMP appears, linking
+;;; them through the list in the DMP-SEGLIST slot of each so that dose can
+;;; be accumulated properly across all segments in a single beam.
+;;; 28-Dec-2003 BobGian: DMP slots ...-dose -> ...-cGy to emphasize dose units.
+;;; Also auto-replication strategy changed - instead of replicating a shared
+;;; DMP as new non-shared ones, we now allocate a non-shared one each time
+;;; a point is selected for any beam, and then shared ones are created by
+;;; pooling the non-shared ones (by fcn ADD-SEG-INFO).
+;;; 30-Dec-2003 BobGian, Mark Phillips: Decided on simplified design which
+;;; factors segment/beam packaging from beam/DMP allocation. This greatly
+;;; simplifies ADD-SEG-INFO - no auto-replication, but user is free to
+;;; create DMPs with any subset of beams contributing their doses.
+;;; 31-Dec-2003 BobGian: ADD-SEG-INFO no longer needs DMP-CNT - no replicating.
+;;; New strategy [per 30-Dec-2003 meeting with Mark P] implemented.
+;;; 27-Jan-2004 BobGian began integration of new DMP Panel by Mark Phillips
+;;; with rest of Dicom Panel and interface to Dicom SCU.
+;;; 12-Feb-2004 BobGian: ADD-SEG-INFO call chain no longer transfers DMPs to
+;;; ASSEMBLE-DICOM; information passed directly via passback from DMP panel.
+;;; 19-Feb-2004 BobGian - introduced uniform naming convention explained below.
+;;; Includes: SEGDATA-... -> PR-BEAM-...
+;;; 25-Feb-2004 BobGian - ADD-SEG-INFO -> GENERATE-PBEAM-INFO.
+;;; Also added PBEAM->DBEAM-GROUPER.
+;;; 26-Feb-2004 BobGian: Completed DMP integration.
+;;; 28-Feb-2004 BobGian: Fixed bug in PBEAM->DBEAM-GROUPER.
+;;; 07-Mar-2003 BobGian: Added slots to DI-BEAM and DI-DMP and code to
+;;; PBEAM->DBEAM-GROUPER to track segment doses at each DMP properly,
+;;; to fix incorrect cumulative dose calculation when generating control
+;;; point sequence.
+;;; Removed PR-BEAM-TOTSEGS slot - last seg ascertained by position in list.
+;;; Removed PR-BEAM-SEGNUM slot - indexed via position in list.
+;;; Removed DI-DMP-COORDS slot - computed when needed.
+;;; 10-Mar-2004 BobGian: DI-DMP-PRIOR-CGY and DI-DMP-TOTAL-CGY -> FIXNUM.
+;;; 02-Apr-2004 BobGian: Updated comment explaining DI-DMP-TOTAL-CGY slot.
+;;; 04-Apr-2004 BobGian: Change DI-DMP-TOTAL-CGY to record either computed
+;;; dose or user-textline-typed dose [using DI-DMP-DOSE-TYPE slot to
+;;; indicate which via value :Computed or :User, respectively].
+;;; 30-Apr-2004 BobGian: Renamed a few fcn params and local vars to distinguish
+;;; more clearly between Original and Current Prism beam instances.
+;;; 17-May-2004 BobGian complete process of extending all instances of Original
+;;; and Current Prism beam instances to include Copied beam instance too,
+;;; to provide copy for comparison with Current beam without mutating
+;;; Original beam instance.
+;;; 26-May-2004 BobGian: Move SEGMENT-VIOLATIONS here -> "dicom-panel".
+;;; 12-Sep-2004 BobGian: Rename PR-BEAM-CUM-MU slot to PR-BEAM-CUM-MU-INC
+;;; and add PR-BEAM-CUM-MU-EXC to hold cumulative MU for the beam Inclusive
+;;; and Exclusive (respectively) of the current segment. Needed to provide
+;;; exactly repeating MU values on accumulating segment MU values.
+;;; 05-Oct-2004 BobGian fixed a few lines to fit within 80 cols.
+;;; 12-Oct-2004 BobGian DI-DMP-TREATED-CGY -> DI-DMP-PRIOR-CGY slot name change
+;;; for better consistency with Dicom-RT standard and Elekta documentation.
+;;; DI-DMP-TOTAL-CGY split into DI-DMP-ACCUM-CGY [part that accumulates dose
+;;; from current beams only] and DI-DMP-TOTAL-CGY [sum of accumulated
+;;; current dose and prior (previously-treated) dose] to fix inconsistency
+;;; between new revised specification and current implementation.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+;;; Uniform naming convention.
+;;;
+;;; There are two kinds of Beams:
+;;;
+;;; A "Dicom" beam represents a single segment [in static or non-IMRT case]
+;;; or a group of multiple segments [in dynamic IMRT case]. Each individual
+;;; segment of such a Dicom beam is represented by what Prism calls an ordinary
+;;; beam. In the DMP source files, a "Prism" beam is synonymous with a
+;;; "segment", and a "Dicom" beam is a group of segment beams treated as a
+;;; single IMRT beam by the Dicom standard.
+;;;
+;;; Dose-Monitoring-Points are represented only by per-Dicom-beam structures
+;;; encoding information about the DMP viewed as an object related to one or
+;;; more Dicom beams.
+;;;
+;;; There are also three kinds of objects that need to be named consistently -
+;;; class instance slot names, DEFSTRUCT accessor slot names, and local
+;;; variables bound to the appropriate kinds of objects.
+;;;
+;;; The following naming convention distinguishes the possible cases
+;;; [in some cases the leading/trailing "..." and hyphen might be null]:
+;;;
+;;; Prism Beam:
+;;;
+;;; Class slots are named PRISM-BEAM-...
+;;; DEFSTRUCT slots are named PR-BEAM-...
+;;; Local variables pointing to contents of either are named ...-P-BM-...
+;;; The Prism BEAM instance object by variables spelled ...-PBI-...
+;;; [for "Prism Beam Instance"].
+;;;
+;;; The description "Prism Beam", objects/slots named PRISM-BEAM-...
+;;; or PR-BEAM-..., and local vars named ...-P-BM-... all refer to the
+;;; STRUCTURE described here.
+;;;
+;;; The description "Prism Beam Instance", objects/slots named PRISM-BI-...
+;;; or ...-PRISM-BI, and local vars named ...-PBI all refer to the an
+;;; instance of the Prism BEAM object.
+;;;
+;;; Prism beam instances [segments of Dicom beams] are one of three types:
+;;; Original - instances of Prism BEAM class objects, containing dose
+;;; information. Indicated by prefix of "o" or "orig-" in names.
+;;; Copied - instances of copied Prism BEAM class objects, copied so that
+;;; side-effects to them do not mutate the original Prism beam object,
+;;; but not mutated by user. Names use prefix "copy-".
+;;; Current - instances of copied Prism BEAM class objects, copied to
+;;; avoid side-effects to original Prism beam object. These ARE
+;;; potentially mutated by user. Names use prefix "curr-".
+;;; Sometimes other prefixes are used, like "new-", which are explained
+;;; in the context of their use.
+;;;
+;;; Dicom Beam:
+;;;
+;;; Class slots are named DICOM-BEAM-...
+;;; DEFSTRUCT slots are named DI-BEAM-...
+;;; Local variables pointing to contents of either are named ...-D-BM-...
+;;;
+;;; DMP, Dicom beam:
+;;; Class slots are named DICOM-DMP-...
+;;; DEFSTRUCT slots are named DI-DMP-...
+;;; Local variables pointing to contents of either are named ...-D-DMP-...
+;;; [There is no DMP object for Prism beams.]
+;;;
+;;; Spelling conventions for local variables and slot names versus types
+;;; of data objects to which they point:
+;;;
+;;; O-BMDATA:
+;;; ( <Btn> <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <New?> <Color> )
+;;;
+;;; OUTPUT-ALIST, O-ALIST, GENERATE-PBEAM-INFO in, PBEAM->DBEAM-GROUPER in:
+;;; List of O-BMDATA items.
+;;;
+;;; P-BMDATA:
+;;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <PR-BEAM-Obj> )
+;;;
+;;; P-BM-INFO, GENERATE-PBEAM-INFO output,
+;;; List of P-BMDATA items.
+;;;
+;;; DICOM-BEAM-LIST, PBEAM->DBEAM-GROUPER output, D-BMLIST:
+;;; List of DI-BEAM structure instances.
+;;;
+;;; BM-PAIR: ( <CurrBmInst> <New-Bm?> )
+;;;
+;;; BM-PAIR-LIST, CALC-SEG-INFO input:
+;;; List of BM-PAIR objects.
+;;;
+;;; P-BMLIST, CALC-SEG-INFO output:
+;;; List of PR-BEAM structure instances.
+;;;
+;;; PR-BEAM: Structure defining a segment [a Prism beam as an
+;;; element of a Dicom beam].
+;;; DI-BEAM: Structure defining a Dicom beam [a group of segments,
+;;; each a PR-BEAM instance].
+;;; DI-DMP: Structure defining a Dicom Dose Monitoring Point.
+;;;
+;;; P-BM-OBJ: Instance of structure defining a segment [PR-BEAM].
+;;; D-BM-OBJ: Instance of structure defining a DicomBmInst.
+;;; D-DMP-OBJ: Instance of structure defining a DicomDMP.
+;;;
+;;; DICOM-DMP-LIST: List of <DicomDMP> objects.
+;;; D-DMP-LIST: List of <DicomDMP> objects.
+;;;
+;;; PLAN-ALIST: List of ( <Btn> <Plan> ) items.
+;;; PRISM-BEAM-ALIST: List of ( <Btn> <OrigBmInst> ) items.
+;;; D-DMP-ALIST: List of ( <Btn> <DicomDMP> ) items.
+;;; D-BM-ALIST: List of ( <Btn> <DicomBmInst> ) items.
+;;; DICOM-ALIST: Multilevel list passed to Dicom client as output.
+
+;;; Terminology note:
+;;;
+;;; "Instance" in reference to a Prism beam, or the abbreviation "...BmInst",
+;;; means an instance of the Prism BEAM class [which represents a "segment"
+;;; of a Dicom beam.
+;;;
+;;; The terms "BmObj", "Object", or "structure instance" refer to an instance
+;;; of a structure, not of the Prism BEAM class.
+
+;;;=============================================================
+
+(defstruct pr-beam
+ segtype ; :Static, :Dynamic, or :Segment
+ dbeam-num ;Fixnum
+ seg-mu ;Single-Float
+ cum-mu-exc ;Single-Float
+ cum-mu-inc ;Single-Float
+ tot-mu) ;Single-Float
+
+;;; The PR-BEAM object represents data about the Prism-beam comprising
+;;; each segment of a single or multiple-segment Dicom beam.
+;;;
+;;; The meaning of the fields is:
+
+;;; SEGTYPE [symbol] ->
+;;; :STATIC indicates an ordinary [non-IMRT] beam [Dicom beam contains
+;;; a single Prism beam],
+;;; :DYNAMIC indicates the first segment in an IMRT segment sequence, and
+;;; :SEGMENT indicates other segments in the segment sequence.
+
+;;; DBEAM-NUM [fixnum] - Dicom beam number, order of this static beam or
+;;; segment group in the output list, starting with 1. All Prism beams that
+;;; belong to the same [static or dynamic] Dicom beam have the same
+;;; DBEAM-NUM [ie, shared by all segments in each Dicom beam].
+
+;;; SEG-MU [single-float] - monitor units for this Prism beam [for this
+;;; segment, if type is :SEGMENT or :DYNAMIC].
+
+;;; CUM-MU-EXC [single-float] - cumulative monitor units for all the
+;;; preceding segments in the current Dicom-beam segment sequence,
+;;; EXCLUSIVE of this segment.
+
+;;; CUM-MU-INC [single-float] - cumulative monitor units for this segment plus
+;;; all the preceding segments in the current Dicom-beam segment sequence,
+;;; INCLUSIVE of this segment.
+
+;;; TOT-MU [single-float] - total monitor units in all segments in the
+;;; current Dicom-beam segment sequence. If type is :STATIC, TOT-MU = SEG-MU,
+;;; CUM-MU-EXC = 0.0, and TOT-MU = CUM-MU-INC must be true, otherwise
+;;; TOT-MU > SEG-MU should be true for all segments, TOT-MU > CUM-MU-EXC
+;;; should be true for all segments, and TOT-MU > CUM-MU-INC should be true
+;;; for all segments but the last, for which TOT-MU = CUM-MU-INC should hold.
+;;; Shared by all segments in a Dicom beam.
+
+;;;-------------------------------------------------------------
+;;; Structure for Dicom beams [grouped segments treated as single Dicom beam].
+
+(defstruct di-beam
+ name ;Name of Dicom beam
+ opbi-list ;List of segs [uncopied Orig Prism Beam Instances] in Dicom beam.
+ opbi-doses ;List of dose sublists for each OPBI in this Dicom beam.
+ )
+
+;;; OPBI-LIST and OPBI-DOSES are parallel lists. For each OPBI in OPBI-LIST,
+;;; the corresponding element of OPBI-DOSES is the a list of point doses
+;;; for that OPBI [segment]. That is, each sublist is a list of doses [actual
+;;; dose, not dose/MU] for each point, one sublist for each segment, and list
+;;; of doses parallel to list of points. The slot therefore contains
+;;; information about dose/MU at ALL points in the beam.
+;;;
+;;; Doses here are cGy as SMALL-FLOAT values.
+;;;
+;;; DI-BEAM-OPBI-DOSES [all for single DI-BEAM]:
+;;; ( ( Pt-1-dose Pt-2-dose ... Pt-N-dose ) <- Seg-1 or OPBI-1
+;;; ( Pt-1-dose Pt-2-dose ... Pt-N-dose ) <- Seg-2 or OPBI-2
+;;; ...
+;;; ( Pt-1-dose Pt-2-dose ... Pt-N-dose ) ) <- Seg-M or OPBI-M
+
+;;;-------------------------------------------------------------
+;;; Structure for Dose Monitoring Points - per-Dicom-beam version.
+
+(defstruct di-dmp
+ name ;Name of Dicom DMP.
+
+ point ;Prism MARK object [with Prism coordinates in cm].
+
+ counter ;Fixnum, incremented index.
+
+ ;; Fixnum, prior or previously-treated dose, cGy, at this DMP.
+ ;; This is dose administered prior to or outside the current treatment plan
+ ;; and therefore is NOT due to any contribution from beams contributing to
+ ;; this DMP.
+ ;;
+ prior-cGy
+
+ ;; Fixnum, dose accumulated from all beams contributing to this DMP, in cGy.
+ ;; Dose is total accumulated and not per fraction or per MU.
+ ;;
+ ;; The value may be calculated from Prism beam doses [which are then summed]
+ ;; or may be typed in via the "Total dose: " textline.
+ ;;
+ ;; If typed, the amount by which the "Total dose: " textline typed value
+ ;; exceeds the current PRIOR dose [the value in the PRIOR-CGY slot, which is
+ ;; zero by default] is divided by the number of Dicom beams contributing to
+ ;; this DMP to give the per-beam dose at this DMP. The per-beam dose is then
+ ;; divided by the number of segments for that beam to give the per-segment
+ ;; dose for the beam. The dose accumulated at the control point representing
+ ;; a segment is the accumulated per-segment dose [divided by number of
+ ;; fractions to give dose/fraction]. Typed total dose therefore assumes
+ ;; equal contribution of dose to the DMP from each Dicom beam and equal
+ ;; contribution from each segment to the total for the beam - it is NOT
+ ;; weighted proportionally to Prism's calculated beam doses.
+ ;;
+ ;; The symbol in the DOSE-TYPE slot indicates which calculation is used
+ ;; for the value in this and in the TOTAL-CGY slots.
+ ;;
+ accum-cGy
+
+ ;; Fixnum, total dose accumulated from all beams contributing to this DMP
+ ;; PLUS any non-zero PRIOR dose assigned to this DMP, in cGy. Dose is total
+ ;; accumulated and not per fraction or per MU.
+ ;;
+ ;; See comments immediately above for the ACCUM-CGY slot for a detailed
+ ;; explanation of the meaning and method of calculation of the value
+ ;; in this slot.
+ ;;
+ total-cGy
+
+ ;; Indicates whether ACCUM-CGY and TOTAL-CGY are not yet computed [NIL],
+ ;; computed from Prism beam doses [:Computed], or subdivided from value
+ ;; typed into "Total dose:" textline [:User].
+ ;;
+ dose-type ;Symbol [NIL, :Computed, :User].
+
+ ;; DBEAMS and PDOSES are parallel lists. For each Dicom beam in DBEAMS,
+ ;; the corresponding element of PDOSES is a LIST of point doses [actual dose,
+ ;; not dose per MU] at the point POINT, one element for each segment in the
+ ;; Dicom beam. Note that this slot's values describe doses at each segment
+ ;; and at a SINGLE point, whereas the DI-BEAM-OPBI-DOSES slot values describe
+ ;; doses at each segment but for ALL the available points [whether selected
+ ;; for DMP duty or not].
+ ;;
+ ;; Doses here are cGy as SMALL-FLOAT values.
+ ;; This is total dose [not dose/MU] over all fractions [not per-fraction].
+ ;;
+ ;; DI-DMP-PDOSES [all for single DMP]:
+ ;; ( ( OPbi-1-dose OPbi-2-dose ... OPbi-N-dose ) <- D-Beam-1
+ ;; ( OPbi-1-dose OPbi-2-dose ... OPbi-N-dose ) <- D-Beam-2
+ ;; ...
+ ;; ( OPbi-1-dose OPbi-2-dose ... OPbi-N-dose ) ) <- D-Beam-M
+ ;;
+ dbeams ;List of Dicom beams contributing to this DMP.
+ ;;
+ pdoses ;Nested list of segment doses per beam and beam doses per DMP.
+
+ )
+
+;;;=============================================================
+
+(defun pbeam->dbeam-grouper (o-alist &aux (segment-accumulator '())
+ (doses-accumulator '()) (outputlist '()))
+
+ "pbeam->dbeam-grouper o-alist
+
+Converts O-ALIST [an assoc list of all Prism beams, not segmented into Dicom
+beams] into a list of Dicom beams by grouping the beams and creating a
+Dicom-Beam structure for each group."
+
+ ;; Input O-ALIST is list [in reverse order, guaranteed non-empty]
+ ;; of objects, each:
+ ;; ( <Button> <OrigBmInst> <CopyBmInst> <CurrBmInst>
+ ;; <Plan> <New-Bm?> <SegColor> )
+ ;; <New-Bm? T:Static/:Dynamic[1st-of-seq], NIL:subsequent-of-seq>
+ ;;
+ ;; This list contains all Prism beams - that is, all segments for all
+ ;; Dicom beams, arranged in Dicom-beam segment order - all segments for
+ ;; one Dicom beam followed by all segments for the next, and so forth.
+ ;;
+ ;; OrigBmInst is uncopied original Prism beam.
+ ;; CopyBmInst and CurrBmInst are both copied beams so that changes
+ ;; to their collimators will not side-effect real Prism beams.
+ ;;
+ ;; Output is a list of Dicom beam instances, each containing a list of Prism
+ ;; beam instances. "Prism Beam" passed through in that slot is an uncopied
+ ;; Original-Prism-Beam instance.
+
+ (declare (type list o-alist segment-accumulator
+ doses-accumulator outputlist))
+
+ ;; Scanning O-ALIST in reverse order, so all successor-segments first are
+ ;; pushed onto SEGMENT-ACCUMULATOR [which will then be in FORWARD order],
+ ;; and then when first segment is encountered [sixth of O-BMDATA = T] we
+ ;; push it and then push resulting Dicom beam [containing the accumulated
+ ;; list of forward-ordered Original Prism beam instances] onto OUTPUTLIST
+ ;; [which must be reversed before return].
+ ;;
+ ;; As we push each SEGMENT we also push its Point-dose-RESULT object
+ ;; onto the parallel list DOSES-ACCUMULATOR [also now in forward order].
+ ;;
+ (dolist (o-bmdata o-alist)
+ (let* ((orig-pbi (second o-bmdata))
+ (point-list (points (result orig-pbi)))
+ (opbi-mu (monitor-units orig-pbi)))
+ (declare (type list point-list)
+ (type single-float opbi-mu))
+ (cond ((sixth o-bmdata) ;New-Bm? = T -> First segment of Dicom beam
+ (push orig-pbi segment-accumulator) ;Include first segment
+ (push (mapcar #'(lambda (pt-dose/mu) ;and doses.
+ (declare (type single-float pt-dose/mu))
+ (* pt-dose/mu opbi-mu))
+ point-list)
+ doses-accumulator)
+ ;; Make Dicom beam and save it in output.
+ ;; Doses here are cGy as SMALL-FLOAT values.
+ (push (make-di-beam :name (string-trim " " (name orig-pbi))
+ :opbi-list segment-accumulator
+ :opbi-doses doses-accumulator)
+ outputlist)
+ (setq segment-accumulator '()) ;Reset for next Dicom beam
+ (setq doses-accumulator '()))
+ ;; For each segment, save Original Prism beam instance and doses.
+ (t (push orig-pbi segment-accumulator)
+ (push (mapcar #'(lambda (pt-dose/mu)
+ (declare (type single-float pt-dose/mu))
+ (* pt-dose/mu opbi-mu))
+ point-list)
+ doses-accumulator)))))
+
+ ;; Input O-ALIST was in reverse order, so PUSHes put OUTPUTLIST back forward.
+ outputlist)
+
+;;;-------------------------------------------------------------------------
+
+(defun generate-pbeam-info (o-alist)
+
+ "generate-pbeam-info o-alist
+
+Converts O-ALIST [an assoc list of all Prism beams, not yet segmented into
+Dicom beams] to forward-ordered list of one 4-item sublist per Prism beam.
+Each output sublist is in form:
+ ( OrigBmInst CopyBmInst CurrBmInst Plan Prism-Beam-Object )."
+
+ ;; Input O-ALIST is list [in reverse order, guaranteed non-empty]
+ ;; of objects, each:
+ ;; ( <Button> <OrigBmInst> <CopyBmInst> <CurrBmInst>
+ ;; <Plan> <New-Bm?> <SegColor> )
+ ;; <New-Bm? T:Static/:Dynamic[1st-of-seq], NIL:subsequent-of-seq>
+ ;;
+ ;; OrigBmInst is uncopied original Prism beam.
+ ;; CopyBmInst and CurrBmInst are both copied beams so that changes
+ ;; to their collimators will not side-effect real Prism beams.
+ ;;
+ ;; This list contains all Prism beams - that is, all segments for all
+ ;; Dicom beams, arranged int Dicom-beam order - all segments for one
+ ;; Dicom beam followed by all segments for the next, and so forth.
+
+ (declare (type list o-alist))
+
+ ;; Destructive reversal does not destroy O-ALIST [list in OUTPUT-ALIST
+ ;; slot of Dicom-Panel object] because NREVERSE acts on list newly-CONSed
+ ;; by MAPCAR.
+ (setq o-alist (nreverse (mapcar #'cdr o-alist)))
+
+ ;; O-ALIST is list [now in forward order] of objects, each:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <New-Bm?> <SegColor> )
+ ;; <New-Bm? T:Static/:Dynamic[1st-of-seq], NIL:subsequent-of-seq>
+ ;;
+ ;; Output is a forward-order list, one entry for each segment, each entry:
+ ;; ( <OrigBmInst> <CopyBmInst> <CurrBmInst> <Plan> <Prism-Beam-Object> )
+
+ (mapcar #'(lambda (b s)
+ (list (first b) ; OrigBmInst
+ (second b) ; CopyBmInst
+ (third b) ; CurrBmInst
+ (fourth b) ; Current Plan
+ s)) ; Prism-Beam-Object
+ o-alist
+ (calc-seg-info
+ (mapcar #'(lambda (b)
+ (list (third b) ; CurrBmInst
+ (fifth b))) ; New-Bm? [T or NIL]
+ o-alist))))
+
+;;;-------------------------------------------------------------------------
+
+(defun calc-seg-info (bm-pair-list)
+
+ "calc-seg-info bm-pair-list
+
+ Returns a list of PR-BEAM structure instances, one for each entry
+in BM-PAIR-LIST."
+
+ ;; Each entry in BM-PAIR-LIST is a list where the first element is the
+ ;; current Prism beam instance, and second element is NIL if that beam is
+ ;; a static beam or the initial segment in a segment sequence. It is T if
+ ;; that beam is a subsequent beam in a segment sequence.
+ ;;
+ ;; The BM-PAIR-LIST list is in FORWARD order [order beam segs were selected].
+ ;;
+ ;; Each BM-PAIR is:
+ ;; ( <CurrBmInst> <New-Bm?> )
+ ;; <New-Bm? T:Static/:Dynamic[1st-of-seq], NIL:subsequent-of-seq>
+ ;; and BM-PAIR-LIST is a list of such pairs.
+ ;;
+ ;; CurrBmInst is copied beam so changes to its collimator will not
+ ;; side-effect real Prism beam.
+
+ (declare (type list bm-pair-list))
+
+ (do ((p-bms bm-pair-list (cdr p-bms))
+ (bnum 0) ;order of current segment sequence in output list
+ (mu-val 0.0)
+ (cum-mu-exc 0.0) ;cumulative MU excluding current segment
+ (cum-mu-inc 0.0) ;cumulative MU including current segment
+ (p-bmlist '())
+ (bm-pair) (new-beam?))
+ ((null p-bms)
+ ;; P-BMLIST is created in reverse order and reversed here for return.
+ (nreverse p-bmlist))
+
+ (declare (type list p-bms p-bmlist bm-pair)
+ (type (member nil t) new-beam?)
+ (type single-float mu-val cum-mu-exc cum-mu-inc)
+ (type fixnum bnum))
+
+ (setq bm-pair (car p-bms)
+ mu-val (monitor-units (first bm-pair))
+ new-beam? (second bm-pair))
+
+ (cond (new-beam? ;Starting a new Dicom beam.
+ (setq bnum (the fixnum (1+ bnum))
+ cum-mu-exc 0.0
+ cum-mu-inc mu-val))
+
+ (t (setq cum-mu-exc cum-mu-inc) ;Adding segment to Dicom beam.
+ (setq cum-mu-inc (+ cum-mu-inc mu-val))
+
+ ;; Propagate slot values that are shared by all segments to the
+ ;; segments "earlier" in list of segments for this Dicom beam.
+ ;; Since P-BMLIST is currently in reverse order, "earlier" in
+ ;; sublist for a given segment actually occurs toward current
+ ;; tail of the list of items for that Dicom beam.
+
+ ;; P-BM-OBJ descriptors [BM-PAIR, MU-VAL, etc] are processed in
+ ;; FORWARD order. P-BMLIST member objects are allocated and
+ ;; processed here in REVERSE order. P-BMLIST is list of segment
+ ;; objects allocated [temporally] up to but not including the
+ ;; "current" one, which gets created by upcoming MAKE-PR-BEAM.
+ (dolist (p-bm-obj p-bmlist)
+ (setf (pr-beam-tot-mu p-bm-obj) cum-mu-inc)
+ (let ((seg-type (pr-beam-segtype p-bm-obj)))
+ ;; Beginning of sublist for this Dicom beam.
+ ;; Change type to :DYNAMIC.
+ (cond ((eq seg-type :static)
+ (setf (pr-beam-segtype p-bm-obj) :dynamic)
+ (return))
+ ;; Found beginning of sublist - done.
+ ((eq seg-type :dynamic)
+ (return)))))))
+
+ ;; Mark as :STATIC in case this is a singleton-segment beam. If it is
+ ;; first seg of multiseg sequence, this slot will be changed to :DYNAMIC.
+ (push (make-pr-beam :segtype (if new-beam? :static :segment)
+ :dbeam-num bnum ;Increments each Dicom beam
+ :seg-mu mu-val
+ :cum-mu-exc cum-mu-exc
+ :cum-mu-inc cum-mu-inc
+ :tot-mu cum-mu-inc)
+ p-bmlist)))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/inference.cl b/prism/src/inference.cl
new file mode 100644
index 0000000..b4038aa
--- /dev/null
+++ b/prism/src/inference.cl
@@ -0,0 +1,172 @@
+;;;
+;;; inference
+;;;
+;;; Mock Prolog example from ANSI Common Lisp chapter 15
+;;; with a few enhancements (see bottom of file)
+;;;
+;;; 13-Sep-2005 I. Kalet created from Graham book and added a few
+;;; things
+;;;
+
+;;;-------------------------------------
+
+(defpackage "INFERENCE"
+ (:nicknames "INF")
+ (:use "COMMON-LISP")
+ (:export "<-" "<--" "ASSERT-VALUE" "REPLACE-ASSERT-VALUE"
+ "ASSERT-SLOT" "ASSERT-LIST-SLOT"
+ "WITH-ANSWER"))
+
+(in-package :inference)
+
+;;;---------------------------------------------------------
+;;; the original Graham code
+;;;---------------------------------------------------------
+
+(defun match (x y &optional binds)
+ (cond
+ ((eql x y) (values binds t))
+ ((assoc x binds) (match (binding x binds) y binds))
+ ((assoc y binds) (match x (binding y binds) binds))
+ ((var? x) (values (cons (cons x y) binds) t))
+ ((var? y) (values (cons (cons y x) binds) t))
+ (t
+ (when (and (consp x) (consp y))
+ (multiple-value-bind (b2 yes)
+ (match (car x) (car y) binds)
+ (and yes (match (cdr x) (cdr y) b2)))))))
+
+(defun var? (x)
+ (and (symbolp x)
+ (eql (char (symbol-name x) 0) #\?)))
+
+(defun binding (x binds)
+ (let ((b (assoc x binds)))
+ (if b
+ (or (binding (cdr b) binds)
+ (cdr b)))))
+
+(defvar *rules* (make-hash-table))
+
+(defmacro <- (con &optional ant)
+ `(length (push (cons (cdr ',con) ',ant)
+ (gethash (car ',con) *rules*))))
+
+(defun prove (expr &optional binds)
+ (case (car expr)
+ (and (prove-and (reverse (cdr expr)) binds))
+ (or (prove-or (cdr expr) binds))
+ (not (prove-not (cadr expr) binds))
+ (t (prove-simple (car expr) (cdr expr) binds))))
+
+(defun prove-simple (pred args binds)
+ (mapcan #'(lambda (r)
+ (multiple-value-bind (b2 yes)
+ (match args (car r)
+ binds)
+ (when yes
+ (if (cdr r)
+ (prove (cdr r) b2)
+ (list b2)))))
+ (mapcar #'change-vars
+ (gethash pred *rules*))))
+
+(defun change-vars (r)
+ (sublis (mapcar #'(lambda (v) (cons v (gensym "?")))
+ (vars-in r))
+ r))
+
+(defun vars-in (expr)
+ (if (atom expr)
+ (if (var? expr) (list expr))
+ (union (vars-in (car expr))
+ (vars-in (cdr expr)))))
+
+(defun prove-and (clauses binds)
+ (if (null clauses)
+ (list binds)
+ (mapcan #'(lambda (b)
+ (prove (car clauses) b))
+ (prove-and (cdr clauses) binds))))
+
+(defun prove-or (clauses binds)
+ (mapcan #'(lambda (c) (prove c binds))
+ clauses))
+
+(defun prove-not (clause binds)
+ (unless (prove clause binds)
+ (list binds)))
+
+(defmacro with-answer (query &body body)
+ (let ((binds (gensym)))
+ `(dolist (,binds (prove ',query))
+ (let ,(mapcar #'(lambda (v)
+ `(,v (binding ',v ,binds)))
+ (vars-in query))
+ , at body))))
+
+;;;---------------------------------------------------------
+;;; additions by IK
+;;;---------------------------------------------------------
+
+(defmacro <-- (con &optional ant)
+
+ "like <- but replaces the hash table entry rather than adding it"
+
+ `(length (setf (gethash (car ',con) *rules*)
+ (list (cons (cdr ',con) ',ant)))))
+
+;;;-------------------------------------------------
+
+(defun assert-value (pred obj &optional val)
+
+ "converts an object value pair to an assertion"
+
+ (if val
+ (eval `(<- (,pred ,obj ,val)))
+ (eval `(<- (,pred ,obj)))))
+
+;;;-------------------------------------------------
+
+(defun replace-assert-value (pred obj &optional val)
+
+ "converts an object value pair to an assertion, replacing previous
+ ones for that predicate"
+
+ (if val
+ (eval `(<-- (,pred ,obj ,val)))
+ (eval `(<-- (,pred ,obj)))))
+
+;;;-------------------------------------------------
+;;; Here's a way to make the connection between slot values in CLOS
+;;; classes and Mock Prolog facts.
+;;;-------------------------------------------------
+
+(defun assert-slot (slot obj &optional replace)
+
+ "deals with slots that have a single item in them"
+
+ (if replace (replace-assert-value slot obj (funcall slot obj))
+ (assert-value slot obj (funcall slot obj))))
+
+;;;-------------------------------------------------
+
+(defun assert-list-slot (slot obj &optional replace)
+
+ "deals with slots that have a list of items in them"
+
+ (dolist (item (funcall slot obj))
+ (if replace (replace-assert-value slot obj item)
+ (assert-value slot obj item))))
+
+;;;-------------------------------------------------
+;;; debugging tool
+;;;-------------------------------------------------
+
+(defun hashtest (hashtable)
+ (maphash #'(lambda (key val)
+ (format t "Key: ~S~% Value: ~S~%" key val))
+ hashtable))
+
+;;;-------------------------------------------------
+;;; End.
diff --git a/prism/src/isocontour.cl b/prism/src/isocontour.cl
new file mode 100644
index 0000000..72f1b5a
--- /dev/null
+++ b/prism/src/isocontour.cl
@@ -0,0 +1,422 @@
+;;;
+;;; isocontours
+;;;
+;;; This file contains updated code for the isodose contour extraction
+;;; facility. Originally from contour-functions.lsp in the old prism
+;;; SCCS directory on eowyn.
+;;;
+;;; Reference: see CONLIN.FOR, an old piece of FORTRAN code used in PLAN32.
+;;; The spirit, if not the letter of that code is followed below.
+;;;
+;;; 20-Sep-1993 J. Unger bring up to current specs.
+;;; 05-Oct-1994 J. Unger fix bug in get-isodose-curves which would cause
+;;; curves of less than three vertices to be returned when a samples array
+;;; value exactly equal to the supplied threshold was detected.
+;;; 8-Jan-1995 I. Kalet remove proclaim form
+;;; 3-Sep-1995 I. Kalet change some macros to functions, delete
+;;; points-adjacent, not used anywhere.
+;;; 03-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx .
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defun found-new-contour (unmarked samples level a b c d)
+
+ "FOUND-NEW-CONTOUR unmarked samples level a b c d
+
+Returns true iff both of the following conditions hold:
+ 1. Either location (a,b) or location (c,d) in the samples array has not
+ yet been marked.
+ 2. The value of samples array entry (a,b), the supplied level parameter,
+ and the value of samples array entry (c,d) are strictly increasing.
+ Testing one side of this inequality is adequate to determine whether
+ an isolevel contour passes between (a,b) and (c,d) when the entire
+ plane is searched, since if the inequality were true in the other
+ direction, some other part of this contour would be detected
+ elsewhere."
+
+ (and
+ (or (aref unmarked a b) (aref unmarked c d))
+ (< (aref samples a b) level (aref samples c d))))
+
+;;;---------------------------------------------
+
+(defun crossed-segment (samples level a b c d)
+
+ "CROSSED-SEGMENT samples level a b c d
+
+Returns true if level falls strictly between the values of the samples
+ array at index (a,b) and index (c,d)."
+
+ (or
+ (< (aref samples a b) level (aref samples c d))
+ (> (aref samples a b) level (aref samples c d))))
+
+;;;---------------------------------------------
+
+(defun out-of-bounds (dim-i dim-j a b c d)
+
+ "OUT-OF-BOUNDS dim-i dim-j a b c d
+
+Returns t iff the point (a,b) or (c,d) is outside of the samples array --
+ ie, outside the region bounded by 0..(dim-1) in each dimension."
+
+ (or (< a 0) (< b 0) (< c 0) (< d 0)
+ (>= a dim-i) (>= b dim-j) (>= c dim-i) (>= d dim-j)))
+
+;;;---------------------------------------------
+
+(defun back-to-start (a b c d p q r s)
+
+ "BACK-TO-START a b c d p q r s
+
+Returns t iff the points (a,b) and (c,d) coincide (up to order) with
+ the points (p,q) and (r,s)."
+
+ (or
+ (and (= a p) (= b q) (= c r) (= d s))
+ (and (= a r) (= b s) (= c p) (= d q))))
+
+;;;---------------------------------------------
+
+(defun initialize-unmarked-array (unmarked dim-i dim-j)
+
+ "INITIALIZE-UNMARKED-ARRAY unmarked dim-i dim-j
+
+Sets all entries in the subarray of the unmarked array from (0,0) to
+ (dim-i, dim-j) to t."
+
+ (dotimes (i dim-i)
+ (dotimes (j dim-j)
+ (setf (aref unmarked i j) t))))
+
+;;;---------------------------------------------
+
+(defun borders-zero (samples a b c d)
+
+ "BORDERS-ZERO samples a b c d
+
+Returns t iff the dose at either of the points (a,b) or (c,d) in the
+ samples array is zero."
+
+ (or
+ (poly:nearly-equal (aref samples a b) 0.0)
+ (poly:nearly-equal (aref samples c d) 0.0)))
+
+;;;---------------------------------------------
+
+(defun compute-location (samples level a b c d)
+
+ "COMPUTE-LOCATION samples level a b c d
+
+Given indices (a,b) and (c,d) into the samples array, computes and
+returns the location in 3-space of the point between the two through
+which the contour of the specified level passes, using linear
+interpolation."
+
+ (let* ((level-ab (aref samples a b))
+ (level-cd (aref samples c d))
+ (frac (float (/ (- level level-ab) (- level-cd level-ab)))))
+
+ (declare (single-float level-ab level-cd frac))
+ (declare (fixnum a b c d))
+
+ (list
+ (+ a (* frac (- c a)))
+ (+ b (* frac (- d b))))))
+
+;;;---------------------------------------------
+
+(defun follow-contour (unmarked samples level p q r s
+ &key checking complete)
+
+ "FOLLOW-CONTOUR unmarked samples level p q r s
+ &key checking complete)
+
+Follows the contour between points pq and rs in the samples array,
+ initially from the direction determined by checking, and returns the
+ contour. If complete is false, then the returned contour will have
+ gaps where the isolevel curve is adjacent to regions of the samples
+ matrix equal to 0.0; otherwise the complete curve is returned. A list
+ of 2-tuples is returned, where the first element of a given 2-tuple is
+ one of :open or :closed (to indicate whether the associated vertex-list
+ is implicitly a closed loop or an open segment), and the secone element
+ of a given 2-tuple is the vertex-list itself. More than one such 2-tuple
+ may be returned, since it is possible (when complete is false) for
+ several disjoint components of the same isocurve (separated by regions of
+ zero-adjacency) to be returned.
+
+ NOTE that the order of the input pair of points is critically dependent
+ on the intial value of checking; in particular -
+
+ if checking = :left or :right then pq must be 'above' rs (ie > y val)
+ if checking = :top or :bottom then pq must be 'to left of' rs (ie < x val)"
+
+ ;; Algorithm: the locations indexed by pq and rs are known to lie on
+ ;; either side of the isocurve. Consider the square in the lattice
+ ;; one of whose sides consists of the segment from pq to rs (there are
+ ;; actually two such squares, but the algorithm considers the one which
+ ;; is appropriate for the direction of the search conducted by the calling
+ ;; routine). The isocurve enters the square through this segment and
+ ;; must leave it by one of the other three segments. Systematically
+ ;; test the sample values at the endpoints of the other three segments
+ ;; against the supplied level to determine which the isocurve crosses
+ ;; through to exit. Compute the location of the exiting isocurve and
+ ;; follow it to the next square, repeating the search, and adding these
+ ;; points to the vertex list to be returned as we go. Take care to
+ ;; mark the points along this isocontour so we don't 'find' it again
+ ;; later in our search. We stop following this isocontour when we
+ ;; return to our starting point, or when we run off the edge of the
+ ;; samples array. If we run off the samples array (out-of-bounds),
+ ;; then add the vertex-list from this-piece to pieces-seen (if this
+ ;; piece is non-nil) and convert each vertex list on the pieces-seen
+ ;; list to a 2-tuple of the form (:open vertex-list). If we end up
+ ;; back at the start, check pieces-seen -- if nil, then the entire
+ ;; accumulated curve is in this-piece; return a list of the form
+ ;; (:closed this-piece) -- if non-nil, we may need to splice back
+ ;; together a disconnected segment that we 'found' in the beginning
+ ;; of the search and just finished finding at the end; see below
+ ;; for details.
+
+ ;; Note that if complete is false, then we need to recognize when we've
+ ;; followed the contour into a region where it is bordered by zero's,
+ ;; and if so, we continue to follow the contour but do not add successive
+ ;; points to the result; any new contour points in a non-zero region
+ ;; are added to a new this-piece list.
+
+ (let ((a p) (b q) (c r) (d s)
+ (dim-i (array-dimension samples 0))
+ (dim-j (array-dimension samples 1))
+ (this-piece nil) ;; A single isocurve component
+ (pieces-seen nil)) ;; Multiple components, separated
+ ;; by regions of zero-adjacency.
+
+ (declare (fixnum a b c d p q r s))
+
+ (loop
+
+ (when (crossed-segment samples level a b c d)
+ (setq checking
+ (case checking
+ (:top :bottom) (:bottom :top) (:left :right) (:right :left)))
+
+ ;; condition on 'if' directly below will be true when we're allowed
+ ;; to add the point just found to the growing this-piece list; else,
+ ;; push any segment on the this-piece list onto the pieces-seen list,
+ ;; and make a new this-piece list, but don't add anything to the new
+ ;; this-piece list since we're bordering zero's and need to watch for
+ ;; that.
+
+ (if (or complete (not (borders-zero samples a b c d)))
+ (push (compute-location samples level a b c d) this-piece)
+ (when this-piece
+ (push this-piece pieces-seen)
+ (setq this-piece nil)))
+
+ (setf (aref unmarked a b) nil) ;; flag these points as marked
+ (setf (aref unmarked c d) nil)) ;; (end of 'when' at top of loop)
+
+ (case checking
+ (:bottom (setq checking :left) (incf b) (decf c))
+ (:left (setq checking :top) (incf c) (incf d))
+ (:top (setq checking :right) (incf a) (decf d))
+ (:right (setq checking :bottom) (decf a) (decf b)))
+
+ ;; if out of bounds, we can return any pieces-seen (& this-piece) as
+ ;; open segments directly.
+
+ (when (out-of-bounds dim-i dim-j a b c d)
+ (when this-piece (push this-piece pieces-seen))
+ (return (mapcar #'(lambda (piece) (list :open piece)) pieces-seen)))
+
+ ;; if back to start, first check pieces-seen -- if it's nil, then
+ ;; all the info is contained in this-piece, which must be a single,
+ ;; closed loop, so return it directly. If pieces-seen is non-nil,
+ ;; then some regions bordering 0 must have been omitted from the
+ ;; curve. Check this-piece -- it it's nil, then all info is on
+ ;; pieces seen and consists of a series of open segments delineated
+ ;; by regions of 0-borders, so return all segments marked as open.
+ ;; If this-piece is non-nil, then there is info on both lists, and
+ ;; again all segments found are open, delineated by 0-borders. But
+ ;; we must splice back together the first segment encountered with
+ ;; the last one, since these are two pieces of the same stretch of
+ ;; contour, which we 'found' at the beginning and end of the search.
+ ;; The two points which need to be spliced together are the first
+ ;; encountered point on pieces-seen and the last encountered point on
+ ;; this-piece. The former point is the last point of the last vertex
+ ;; list on pieces-seen, since we pushed points onto the vertex list and
+ ;; pushed vertex lists onto pieces-seen in the order we saw them. The
+ ;; latter point is the first point on this-piece, again, since we were
+ ;; pushing previously seen points onto this vertex list. Append the
+ ;; last vertex-list on pieces-seen to the this-piece vertex list; and
+ ;; cons this composite list into the rest of the pieces-seen list.
+
+ (when (back-to-start a b c d p q r s)
+ (if (null pieces-seen)
+ (return (list (list :closed this-piece)))
+ (if (null this-piece)
+ (return (mapcar #'(lambda (piece) (list :open piece)) pieces-seen))
+ (cons
+ (append (first (last pieces-seen)) this-piece)
+ (butlast pieces-seen))))))))
+
+;;;---------------------------------------------
+
+(defun normalize-isodose-curves (curves samples x-size y-size x-orig y-orig)
+
+ "NORMALIZE-ISODOSE-CURVES curves samples x-size y-size x-orig y-orig
+
+Takes the values of each point in each vertex list in curves and scales
+ it into the space determined by the size and origin of the original
+ samples array in that space."
+
+ (let ((dx (float (/ x-size (1- (array-dimension samples 0)))))
+ (dy (float (/ y-size (1- (array-dimension samples 1))))))
+
+ (dolist (curve curves)
+ (dolist (vertex (second curve))
+ (setf (first vertex) (+ x-orig (* dx (first vertex))))
+ (setf (second vertex) (+ y-orig (* dy (second vertex))))))
+
+ curves))
+
+;;;---------------------------------------------
+
+(defun get-isodose-curves (samples x-size y-size x-orig y-orig level
+ &key (unmarked nil) (complete t))
+
+ "GET-ISODOSE-CURVES samples x-size y-size x-orig y-orig level
+ &key (unmarked nil) (complete t)
+
+Given samples (a 2D array of float values representing dose absorption
+ information on a regular grid of lattice points), x-size and y-size
+ both floats defining the size of each dimension of the grid in patient
+ space), x-orig and y-orig (defining the patient space location of the
+ x and y coordinates of the (0,0) entry of the grid), and level (a float
+ which represents the isodose threshold at which to extract curves), this
+ routine computes and returns a list of lists of coordinate pairs,
+ each list of coordinate pairs representing the vertices of the a segment
+ of the set of isodose lines running through the samples array at the
+ supplied threshold.
+
+ The caller may optionally supply an 'unmarked' keyword, which must be
+ a 2D array of t/nil entries whose dimensions are at least as large as
+ the samples array; this unmarked array is used internally by the function.
+ If omitted, an unmarked array will be dynamically allocated automatically,
+ each time this routine is called. This allocation reduces the efficiency
+ of this function, and it is intended that the caller explicitly allocate
+ an unmarked array once and then reuse it on successive calls to this
+ function for different levels.
+
+ If the 'complete' keyword is true (its default), then the complete
+ set of isodose curves is returned, unaffected by the presence of 0.0's
+ in the samples matrix. If this keyword is nil, then this routine
+ does not consider points on an isolevel line which border areas
+ of zero level to be part of the resulting isodose curve; these areas
+ are not included in the returned polylines and/or contours. This is at
+ the request of the dosimetrists who don't want to see multiple contour
+ lines piled up on top of each other near the skin surface."
+
+ (let* ((curves nil)
+ (last-i (1- (array-dimension samples 0)))
+ (last-j (1- (array-dimension samples 1))))
+
+ (declare (type (simple-array single-float 2) samples))
+ (declare (fixnum last-i last-j))
+
+ ;; if no unmarked array, create one dynamically
+
+ (unless unmarked
+ (setq unmarked (make-array (array-dimensions samples)
+ :element-type '(member t nil))))
+
+ ;; initialize all entries of unmarked array to t
+
+ (initialize-unmarked-array unmarked (1+ last-i) (1+ last-j))
+
+ ;; Search algorithm to find isolevel curves in samples: check consecutive
+ ;; elements of samples along bottom row, right column, top row, and left
+ ;; column to see if an isolevel contour crosses enters the samples array
+ ;; from the outside. Then check remaining adjacent elements of samples
+ ;; array, row by row, to find isolevel curves completely inside the array.
+ ;; If an isolevel curve is found between two adjacent array entries at
+ ;; any time, follow that curve through the array and, when finished, add
+ ;; the curve to the list to be returned. This list consists of 2-tuples,
+ ;; of the format (status vertex-list) where status is one of :open or
+ ;; :closed.
+
+ ;;---------- check bottom row, left to right
+
+ (do ((i 0 (1+ i))) ((= i last-i))
+ (when (found-new-contour unmarked samples level i 0 (1+ i) 0)
+ (dolist (s (follow-contour
+ unmarked samples level i 0 (1+ i) 0
+ :checking :top :complete complete))
+ (push s curves))))
+
+ ;;---------- check right column, bottom to top
+
+ (do ((j 0 (1+ j))) ((= j last-j))
+ (when (found-new-contour unmarked samples level last-i j last-i (1+ j))
+ (dolist (s (follow-contour
+ unmarked samples level last-i (1+ j) last-i j
+ :checking :left :complete complete))
+ (push s curves))))
+
+ ;;---------- check top row, right to left
+
+ (do ((i last-i (1- i))) ((zerop i))
+ (when (found-new-contour unmarked samples level i last-j (1- i) last-j)
+ (dolist (s (follow-contour
+ unmarked samples level (1- i) last-j i last-j
+ :checking :bottom :complete complete))
+ (push s curves))))
+
+ ;;---------- check left column, top to bottom
+
+ (do ((j last-j (1- j))) ((zerop j))
+ (when (found-new-contour unmarked samples level 0 j 0 (1- j))
+ (dolist (s (follow-contour
+ unmarked samples level 0 j 0 (1- j)
+ :checking :right :complete complete))
+ (push s curves))))
+
+ ;;---------- check remaining rows
+
+ (do ((j 1 (1+ j))) ((= j last-j))
+ (dotimes (i last-i)
+ (when (found-new-contour unmarked samples level i j (1+ i) j)
+ (dolist (s (follow-contour
+ unmarked samples level i j (1+ i) j
+ :checking :top :complete complete))
+ (push s curves)))))
+
+ ;; filter out curves with less than 3 vertices on them - it is possible,
+ ;; though extremely rare, that follow-contour such curves will return
+ ;; such curves, if samples array values are encountered that are exactly
+ ;; equal to the supplied threshold.
+
+ (setq curves
+ (remove-if-not #'(lambda (curve) (rest (rest (second curve)))) curves))
+
+ ;; scale curves from 'array space' to patient space
+
+ (setq curves
+ (normalize-isodose-curves curves samples x-size y-size x-orig y-orig))
+
+ ;; duplicate first point to last of each curve if it is closed.
+
+ (mapcar #'(lambda (curve)
+ (case (first curve)
+ (:open (second curve))
+ (:closed (append
+ (second curve)
+ (list
+ (first (second curve))
+ (second (second curve)))))))
+ curves)
+))
+
+;;;---------------------------------------------
diff --git a/prism/src/linear-expand.cl b/prism/src/linear-expand.cl
new file mode 100644
index 0000000..f0d7393
--- /dev/null
+++ b/prism/src/linear-expand.cl
@@ -0,0 +1,178 @@
+;;;
+;;; linear-expand
+;;;
+;;; The linear volume expansion panel, used for generating a target
+;;; from a tumor by linearly expanding the tumor's contours in the x,
+;;; y, & z directions.
+;;;
+;;; 4-May-1994 J. Unger created.
+;;; 4-May-1994 I. Kalet change ORGAN- to TARGET-
+;;; 6-May-1994 J. Unger only one margin textline, w/ default value.
+;;; 6-May-1994 J. Unger modify expansion algorithm to Jon Jacky's
+;;; specs.
+;;; 8-Jul-1994 J. Unger have only tumors w/ 2 or more contours in
+;;; list.
+;;; 8-Oct-1996 I. Kalet make textline numeric.
+;;; 26-Mar-1998 I. Kalet cosmetic cleanup -- eliminate globals.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------
+
+(defun cap-contours (con dz margin)
+
+ "CAP-CONTOURS con dz margin
+
+Given con (a prism contour object), dz (the z-plane spacing between
+contours in the pstruct of which con is a member), and margin (an
+amount by which to extend the pstruct of which con is a member),
+creates 0 or more contours at dz intervals to fill the region between
+con's z coordinate and that z coordinate plus (dz/2 + margin). Returns
+the new contour objects on a list."
+
+ (do* ((j 1 (1+ j))
+ (jdz (* j dz) (* j dz))
+ (edge-z (z con))
+ (edge-verts (vertices con))
+ (center (poly:centroid edge-verts))
+ (x-tc (first center))
+ (y-tc (second center))
+ (new-edge-z (+ margin (/ dz 2.0)))
+ (factor (/ jdz new-edge-z) (/ jdz new-edge-z))
+ (results nil))
+ ((>= (abs jdz) (abs new-edge-z)) results)
+ (push
+ (make-contour
+ :vertices (mapcar #'(lambda (coord)
+ (let ((x-ei (first coord))
+ (y-ei (second coord)))
+ (list
+ (- x-ei (* factor (- x-ei x-tc)))
+ (- y-ei (* factor (- y-ei y-tc))))))
+ edge-verts)
+ :z (fix-float (+ edge-z jdz) 3))
+ results)))
+
+;;;---------------------------------------
+
+(defun linear-expand-target (tumor margin)
+
+ "LINEAR-EXPAND-TARGET tumor margin
+
+Returns a target instance whose contours are generated by linear
+expansion of the contours of the supplied tumor. Each segment of
+existing tumor contour is expanded outward, perpendicular to the
+segment, by the amount specified by margin, and the vertices of the
+expanded contour are computed from the locations at which these
+expanded segments intersect. Zero or more contours are added to the
+top and bottom contours of the expanded target. These extra capping
+contours are added at each additional z-plane crossed, when the top
+and bottom of the tumor are extended outward by margin. These capping
+contours grow smaller, the further away from the top and bottom of the
+tumor."
+
+ (let* ((con-list (mapcar
+ #'(lambda (con)
+ (make-contour
+ :vertices (poly:ortho-expand-contour
+ (poly:convex-hull (vertices con))
+ margin)
+ :z (z con)))
+ (contours tumor)))
+ (sorted (sort (copy-list con-list) #'> :key #'z))
+ (dz (- (z (first sorted)) (z (second sorted))))
+ )
+ (make-target (format nil "~a" (gensym "TARGET-"))
+ :contours (append
+ con-list
+ (cap-contours (first sorted) dz margin)
+ (cap-contours (first (last sorted))
+ (- dz)
+ (- margin))))))
+
+;;;---------------------------------------
+
+(defun make-lin-expanded-target (all-tumors)
+
+ "MAKE-LIN-EXPANDED-TARGET all-tumors
+
+Returns a target instance whose contours are determined by linear
+expansion of a tumor. The tumor to choose and expansion factors are
+specified by the user through a special purpose panel at a nested
+event processing level. Only the tumors in the all-tumors collection
+that have at least two contours are candidates for linear expansion."
+
+ (sl:push-event-level)
+ (let* ((offset 10)
+ (textwid 175)
+ (texthgt 30)
+ (scrollhgt (* 2 texthgt))
+ (wid (+ (* 3 offset) (* 2 textwid)))
+ (hgt (+ (* 2 offset) (* 3 texthgt)))
+ (frm (sl:make-frame wid hgt
+ :title "PRISM Linear Volume Expansion Editor"))
+ (frm-win (sl:window frm))
+ (accept-b (sl:make-exit-button textwid texthgt
+ :parent frm-win
+ :ulc-x (+ (* 2 offset) textwid)
+ :ulc-y (+ offset (* 2 texthgt))
+ :label "Accept"
+ :bg-color 'sl:blue))
+ (tumor-r (sl:make-readout textwid texthgt
+ :parent frm-win
+ :ulc-x offset
+ :ulc-y 2
+ :label "Sel Tumor:"
+ :border-width 0))
+ (tumor-s (sl:make-radio-scrolling-list textwid scrollhgt
+ :parent frm-win
+ :ulc-x offset
+ :ulc-y texthgt))
+ (m-tln (sl:make-textline textwid texthgt
+ :parent frm-win
+ :ulc-x (+ (* 2 offset) textwid)
+ :ulc-y texthgt
+ :numeric t
+ :lower-limit 0.0
+ :upper-limit 10000.0
+ :label "Dist: "))
+ (tumors (remove-if #'(lambda (tum)
+ (> 2 (length (contours tum))))
+ (coll:elements all-tumors)))
+ (tumor-btns nil)
+ (tumor nil)
+ (margin 0.5))
+ (dolist (item tumors)
+ (let ((btn (sl:make-list-button tumor-s (name item))))
+ (push btn tumor-btns)
+ (sl:insert-button btn tumor-s)))
+ (setq tumor-btns (reverse tumor-btns))
+ (sl:select-button (first tumor-btns) tumor-s)
+ (setq tumor (first tumors))
+ (setf (sl:info m-tln) margin)
+ (ev:add-notify frm (sl:selected tumor-s)
+ #'(lambda (l a btn)
+ (declare (ignore l a))
+ (setq tumor
+ (nth (position btn tumor-btns) tumors))))
+ (ev:add-notify frm (sl:new-info m-tln)
+ #'(lambda (l a info)
+ (declare (ignore l a))
+ (setq margin (coerce (read-from-string info)
+ 'single-float))))
+ (sl:process-events)
+ (sl:destroy tumor-s)
+ (sl:destroy m-tln)
+ (sl:destroy accept-b)
+ (sl:destroy tumor-r)
+ (sl:destroy frm)
+ (sl:pop-event-level)
+ (linear-expand-target tumor margin)))
+
+;;;---------------------------------------
+
+
+
+
+
diff --git a/prism/src/locators.cl b/prism/src/locators.cl
new file mode 100644
index 0000000..e7da403
--- /dev/null
+++ b/prism/src/locators.cl
@@ -0,0 +1,436 @@
+;;;
+;;; locators
+;;;
+;;; This file includes the locator class, and the mediators required
+;;; to maintain the locator bars that reference other views in a given
+;;; view.
+;;;
+;;; 18-Jan-1993 I. Kalet taken from views.cl
+;;; 28-Jan-1994 I. Kalet locator bar grab boxes at last, also move a
+;;; little bit of code to views module.
+;;; 18-Apr-1994 I. Kalet update to use new pickable objects facility.
+;;; Move some code here from views. Uodate refs to view origin.
+;;; 22-May-1994 I. Kalet ignore grab box motion unless button 1 down
+;;; 8-Jan-1995 I. Kalet destroy locators when a view is deleted (in
+;;; delete-intersect code) in order to free the line gcontext
+;;; 12-Mar-1995 I. Kalet in view-set-mediator, call display-view in
+;;; lambda function for view deleted, only for the view that remains,
+;;; not in delete-intersect. This allows the view to be destroyed as
+;;; well as deleted.
+;;; 3-Sep-1995 I. Kalet add coerce to single-float in locator
+;;; position update from grab box.
+;;; 19-Sep-1996 I. Kalet take out keywords and &rest from draw methods.
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 13-Oct-2002 I. Kalet don't make locators for bev, oblique or room views.
+;;; 25-May-2009 I. kalet remove ref to room view altogether.
+;;;
+
+(in-package :prism)
+
+;;;-------------------------------------
+
+(defvar *horiz-intersect-table*
+ '((transverse-view coronal-view)
+ (coronal-view sagittal-view)
+ (coronal-view transverse-view))
+ "The for-view in-view class name pairs that correspond to horizontal
+locator bars.")
+
+;;;-------------------------------------
+
+(defun find-orient (for-v in-v)
+
+ "find-orient for-v in-v
+
+returns either :horizontal or :vertical depending on how the locator
+bar should be oriented in in-v for for-v."
+
+ (let ((f-cl (class-name (class-of for-v)))
+ (v-cl (class-name (class-of in-v))))
+ (if (member (list f-cl v-cl) *horiz-intersect-table* :test #'equal)
+ :horizontal
+ :vertical)))
+
+;;;-------------------------------------
+
+(defclass locator ()
+
+ ((in-view :accessor in-view
+ :initarg :in-view
+ :documentation "The view in which this locator appears.")
+
+ (loc-position :type single-float
+ :accessor loc-position
+ :initarg :loc-position
+ :documentation "The real space position of the
+locator bar in its view.")
+
+ (new-position :type ev:event
+ :accessor new-position
+ :initform (ev:make-event)
+ :documentation "Announced when the locator bar
+position changes.")
+
+ (orient :type (member :horizontal :vertical)
+ :accessor orient
+ :initarg :orient
+ :documentation "The orientation of this locator in the view
+in which it appears.")
+
+ (visible :accessor visible
+ :initform t
+ :documentation "T if the bar is specified as visible by
+the view it represents, false if it should not appear.")
+
+ (line-gc :accessor line-gc
+ :initarg :line-gc
+ :initform (sl:make-duplicate-gc (sl:color-gc 'sl:blue))
+ :documentation "The color gc for the locator line.")
+
+ )
+
+ (:documentation "A locator bar is a line drawn in a view to
+represent the view-position of another orthogonal view.")
+
+ )
+
+;;;--------------------------------------
+
+(defun locator-pos (loc)
+
+ "locator-pos loc
+
+returns the pixel position of the locator in its view."
+
+ (let* ((v (in-view loc))
+ (x0 (x-origin v))
+ (y0 (y-origin v))
+ (raw-pix (round (* (scale v) (loc-position loc))))) ;; cm to pix
+ (if (eql (orient loc) :horizontal)
+ (typecase v
+ (coronal-view (+ y0 raw-pix))
+ (t (- y0 raw-pix)))
+ (+ x0 raw-pix))))
+
+;;;--------------------------------------
+
+(defun locator-box-xy (loc)
+
+ "locator-box-xy loc
+
+returns as multiple values the x and y pixel coordinates of the
+location where the locator grab box for locator loc should go."
+
+ (let ((horiz (eql (orient loc) :horizontal))
+ (pos (locator-pos loc))
+ (wid (clx:drawable-width
+ (sl:window (picture (in-view loc))))))
+ (values (if horiz (- wid 20) ;; arbitrary - right hand side
+ pos)
+ (if horiz pos
+ (- wid 20))))) ;; arbitrary - bottom
+
+;;;-------------------------------------
+
+(defmethod draw ((l locator) (v view))
+
+ "This draw method just draws the locator in the view with the
+current gcontext. It does not check for visible etc. It adds or
+updates a graphic primitive in the view's foreground list."
+
+ (let* ((wid (clx:drawable-width (sl:window (picture v))))
+ (horiz (eql (orient l) :horizontal))
+ (pos (locator-pos l))
+ (x1 (if horiz 0 pos))
+ (x2 (if horiz wid pos))
+ (y1 (if horiz pos 0))
+ (y2 (if horiz pos wid))
+ (bar (list x1 y1 x2 y2))
+ (segs-prim (find l (foreground v) :key #'object)))
+ (if segs-prim (setf (points segs-prim) bar)
+ (push (make-segments-prim bar (line-gc l) :object l)
+ (foreground v)))))
+
+;;;--------------------------------------
+
+(defmethod destroy ((l locator))
+
+ (clx:free-gcontext (line-gc l)))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((loc locator) &rest initargs)
+
+ "registers with view refresh-fg, makes grab box and registers with
+it, adds locator to in-view locators set."
+
+ (declare (ignore initargs))
+ (let ((in-v (in-view loc))
+ (grab-box (multiple-value-bind (x y) (locator-box-xy loc)
+ (sl:make-square loc x y))))
+ (sl:add-pickable-obj grab-box (picture in-v))
+ (if (and (visible loc) (local-bars-on in-v))
+ (progn (draw loc in-v)
+ (display-view in-v)) ;; because it is a new one
+ (setf (sl:enabled grab-box) nil)) ;; because default is t
+ ;; update grab box and redraw locator bar when refreshing view
+ ;; because scale or origin may have changed
+ (ev:add-notify loc (refresh-fg in-v)
+ #'(lambda (l v)
+ (when (and (local-bars-on v) (visible l))
+ (let ((gb (first (sl:find-pickable-objs
+ l (picture v)))))
+ ;; update position of grab box
+ (multiple-value-bind (x y) (locator-box-xy l)
+ (setf (sl:x-center gb) x
+ (sl:y-center gb) y))
+ ;; and refresh the locator bar
+ (draw l v)))))
+ (ev:add-notify loc (sl:motion grab-box)
+ #'(lambda (l gb x y state)
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (sl:update-pickable-object gb x y)
+ (let* ((v (in-view l))
+ (x0 (x-origin v))
+ (y0 (y-origin v))
+ (horiz (eql (orient l) :horizontal))
+ (pos (if horiz y x)))
+ (setf (loc-position l)
+ (coerce (/ (if horiz
+ (typecase v
+ (coronal-view (- pos y0))
+ (t (- y0 pos)))
+ (- pos x0))
+ (scale v))
+ 'single-float))))))
+ (ev:add-notify loc (sl:deselected grab-box)
+ #'(lambda (l gb)
+ (declare (ignore gb))
+ (ev:announce l (new-position l)
+ (loc-position l))))
+ (coll:insert-element loc (locators in-v))))
+
+;;;--------------------------------------
+
+(defmethod (setf loc-position) :after (new-pos (l locator))
+
+ "sets the loc-position attribute of locator l to new-pos and
+announces new-position. Redraws only if already drawn."
+
+ (let* ((v (in-view l))
+ (gb (first (sl:find-pickable-objs l (picture v)))))
+ ;; update position of grab box in view picture's pick-list
+ (multiple-value-bind (x y) (locator-box-xy l)
+ (setf (sl:x-center gb) x
+ (sl:y-center gb) y))
+ ;; then draw locator if called for
+ (when (and (visible l) (local-bars-on v))
+ (draw l v)
+ (display-view v))
+ (ev:announce l (new-position l) new-pos)))
+
+;;;--------------------------------------
+
+(defun locator-draw-box-enable (l)
+
+ "locator-draw-box-enable l
+
+sets enable flag on grab box for locator l and draws it or deletes it
+from the in-view display list."
+
+ (let* ((v (in-view l))
+ (gb (first (sl:find-pickable-objs l (picture v)))))
+ (if (and (local-bars-on v) (visible l))
+ (progn
+ (setf (sl:enabled gb) t) ;; turn on grab boxes
+ (draw l v)) ;; draw bars that are visible
+ (progn
+ (setf (sl:enabled gb) nil) ;; turn off grab boxes
+ (setf (foreground v) ;; remove others from display list
+ (remove l (foreground v) :test #'eq :key #'object))))))
+
+;;;--------------------------------------
+
+(defmethod (setf visible) :after (val (l locator))
+
+ "draws or erases the locator bar as needed."
+
+ (declare (ignore val))
+ (locator-draw-box-enable l)
+ (display-view (in-view l)))
+
+;;;-------------------------------------
+
+(defmethod (setf local-bars-on) :after (on (v view))
+
+ "Redraws the locator graphics. Provided with locators instead of
+views since it depends on locator stuff and supplements the standard
+method."
+
+ (declare (ignore on))
+ (mapc #'locator-draw-box-enable (coll:elements (locators v)))
+ (display-view v))
+
+;;;--------------------------------------
+
+(defclass view-locator-mediator ()
+
+ ((locator :accessor locator
+ :initarg :locator
+ :documentation "The locator this mediator manages.")
+
+ (for-view :accessor for-view
+ :initarg :for-view
+ :documentation "The view that this locator represents.")
+
+ (busy :accessor busy
+ :initform nil)
+
+ )
+
+ (:documentation "This mediator maintains the relation between a
+locator and the view it represents.")
+
+ )
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((vlm view-locator-mediator)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (ev:add-notify vlm (new-position (locator vlm))
+ #'(lambda (med a pos)
+ (declare (ignore a))
+ ;; check if grab-box active - if so, don't set
+ ;; the view-position yet
+ (let* ((loc (locator med))
+ (vw (in-view loc))
+ (grab-box (first (sl:find-pickable-objs
+ loc (picture vw)))))
+ (when (and (not (busy med))
+ (not (sl:active grab-box)))
+ (setf (busy med) t)
+ (setf (view-position (for-view med)) pos)
+ (setf (busy med) nil)))))
+ (ev:add-notify vlm (new-position (for-view vlm))
+ #'(lambda (med v position)
+ (declare (ignore v))
+ (when (not (busy med))
+ (setf (busy med) t)
+ (setf (loc-position (locator med)) position)
+ (setf (busy med) nil))))
+ (ev:add-notify vlm (remote-bars-toggled (for-view vlm))
+ #'(lambda (med a on)
+ (declare (ignore a))
+ (setf (visible (locator med)) on))))
+
+;;;--------------------------------------
+
+(defclass view-set-mediator ()
+
+ ((views :accessor views
+ :initarg :views
+ :documentation "The set of all views in the plan.")
+
+ (locator-mediators :accessor locator-mediators
+ :initform (coll:make-collection)
+ :documentation "The set of view-locator-mediators.")
+ )
+
+ (:documentation "This mediator maintains the relations between views
+in a set in the face of addition or deletion of a view.")
+
+ )
+
+;;;---------------------------------------
+
+(defun make-view-set-mediator (view-set)
+
+ "make-view-set-mediator view-set
+
+returns an instance of a view-set-mediator with view-set as its
+initial set of views."
+
+ (make-instance 'view-set-mediator :views view-set))
+
+;;;---------------------------------------
+
+(defun add-intersect (for-v in-v vsm)
+
+ "add-intersect for-v in-v vsm
+
+adds a locator to the locators in in-v for for-v, adds a locator
+mediator to view-set-mediator vsm."
+
+ (unless (or (typep for-v 'beams-eye-view)
+ (typep in-v 'beams-eye-view)
+ (typep for-v 'oblique-view)
+ (typep in-v 'oblique-view))
+ (coll:insert-element
+ (make-instance 'view-locator-mediator
+ :locator (make-instance 'locator
+ :in-view in-v
+ :loc-position (view-position for-v)
+ :orient (find-orient for-v in-v)
+ :line-gc (sl:make-duplicate-gc
+ (sl:color-gc (sl:border-color (picture for-v)))))
+ :for-view for-v)
+ (locator-mediators vsm))))
+
+;;;---------------------------------------
+
+(defun delete-intersect (for-v in-v vsm)
+
+ "delete-intersect for-v in-v vsn
+
+deletes the locator and locator mediator for the combination of for-v
+and in-v."
+
+ (let* ((loc-m-set (locator-mediators vsm))
+ (loc-m (coll:collection-member ; find the locator mediator
+ (list for-v in-v) loc-m-set
+ :test #'(lambda (view-pair lm)
+ (if (equal (list (for-view lm)
+ (in-view (locator lm)))
+ view-pair)
+ lm nil))))
+ (locator (if loc-m (locator loc-m))))
+ (when loc-m
+ (coll:delete-element locator (locators in-v))
+ (ev:remove-notify locator (refresh-fg in-v))
+ (setf (foreground in-v) (remove locator (foreground in-v)
+ :test #'eq :key #'object))
+ (sl:remove-pickable-objs locator (picture in-v))
+ (ev:remove-notify loc-m (new-position for-v))
+ (ev:remove-notify loc-m (remote-bars-toggled for-v))
+ (coll:delete-element loc-m loc-m-set)
+ (destroy locator)))) ;; to free the gcontext
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((view-sm view-set-mediator)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (ev:add-notify view-sm (coll:inserted (views view-sm))
+ #'(lambda (vsm view-set v)
+ (mapc #'(lambda (v1)
+ (when (not (equal (class-name
+ (class-of v))
+ (class-name
+ (class-of v1))))
+ (add-intersect v v1 vsm)
+ (add-intersect v1 v vsm)))
+ (coll:elements view-set))))
+ (ev:add-notify view-sm (coll:deleted (views view-sm))
+ #'(lambda (vsm view-set v)
+ (mapc #'(lambda (v1)
+ (delete-intersect v v1 vsm)
+ (delete-intersect v1 v vsm)
+ (display-view v1))
+ (coll:elements view-set)))))
+
+;;;---------------------------------------
+;;; End.
diff --git a/prism/src/margin-rules.cl b/prism/src/margin-rules.cl
new file mode 100644
index 0000000..53cce00
--- /dev/null
+++ b/prism/src/margin-rules.cl
@@ -0,0 +1,100 @@
+;;;
+;;; margin-rules
+;;;
+;;; 13-Sep-2005 I. Kalet transcribed from Sharon Kromhout-Schiro's
+;;; work to use Graham inference code instead of RULER.
+;;; 25-Jun-2008 I. Kalet move use-package inference to prism defpackage
+;;;
+
+(in-package :prism)
+
+;;;------------------------------------------------------------------
+;;; Measurements in cm
+;;; x: right-left
+;;; y: front-back
+;;; z: sup-inf
+;;;------------------------------------------------------------------
+
+;;;------------------------------------------------------------------
+;;; Head and neck rules
+;;;------------------------------------------------------------------
+
+(<- (setup-error ?x (0.8 0.8 0.8)) ;; (0.8,?,?) Verhey82,
+ ;; approved SH 3/5/92
+ (AND (within ?x head-and-neck)
+ (immob-type none)))
+
+(<- (pt-movement ?x (0.3 0.3 0.3)) ;; MAS/JMU-2/3/94, approved SH 3/5/92
+ (AND (within ?x head-and-neck)
+ (immob-type none)))
+
+(<- (setup-error ?x (0.5 0.5 0.5)) ;; SH 3/5/92
+ (AND (within ?x head-and-neck)
+ (immob-type mask)))
+
+(<- (pt-movement ?x (0.1 0.1 0.1)) ;; MAS/JMU-2/3/94
+ (AND (within ?x head-and-neck)
+ (immob-type mask)))
+
+;;;---------------------------------------------------------------
+;;; Nasopharynx rules
+
+(<- (tumor-movement ?x (0.0 0.0 0.0))
+ (within ?x nasopharynx))
+
+;;;----------------------------------------------------------
+;;; rules for lung
+;;;----------------------------------------------------------
+
+(<- (tumor-movement ?x (0.0 0.6 1.0)) ;; Ross89, West74 (z)
+ (AND (within ?x lung)
+ (region ?x nil)))
+
+(<- (tumor-movement ?x (0.0 0.0 0.0)) ;; MAS-2/26/92
+ (AND (within ?x lung)
+ (fixed ?x yes)))
+
+(<- (tumor-movement ?x (0.0 0.6 0.0)) ;; Ross89
+ (AND (within ?x lung)
+ (region ?x upper-lobe)))
+
+(<- (tumor-movement ?x (0.9 0.0 0.0)) ;; Ross89, MAS 2/26/92
+ (AND (within ?x lung)
+ (region ?x hilum)))
+
+(<- (tumor-movement ?x (0.8 0.0 0.0)) ;; Ross89, MAS 2/26/92
+ (AND (within ?x lung)
+ (region ?x mediastinum)))
+
+(<- (tumor-movement ?x (0.5 0.5 1.0)) ;; Ross89, West74 (z), MAS 2/26/92
+ (AND (within ?x lung)
+ (region ?x lower-lobe)))
+
+(<- (setup-error ?x (0.8 0.8 0.8)) ;; MAS/JMU-2/3/94, approved SH 3/5/92
+ (AND (within ?x lung)
+ (immob-type none)))
+
+(<- (setup-error ?x (0.6 0.6 0.6)) ;; MAS/JMU-2/3/94, approved SH 3/5/92
+ (AND (within ?x lung)
+ (immob-type alpha-cradle)))
+
+;; check these numbers!!
+(<- (setup-error ?x (0.4 0.4 0.4)) ;; MAS/JMU-2/3/94
+ (AND (within ?x lung)
+ (immob-type plaster-shell)))
+
+(<- (pt-movement ?x (0.4 0.4 0.4)) ;; MAS/JMU-2/3/94, approved SH 3/5/92
+ (AND (within ?x lung)
+ (immob-type none)))
+
+(<- (pt-movement ?x (0.2 0.2 0.2)) ;; MAS/JMU-2/3/94, approved SH 3/5/92
+ (AND (within ?x lung)
+ (immob-type alpha-cradle)))
+
+;; check these numbers!!
+(<- (pt-movement ?x (0.1 0.1 0.1)) ;; MAS/JMU-2/3/94
+ (AND (within ?x lung)
+ (immob-type plaster-shell)))
+
+;;;-------------------------------------------------------
+;;; End.
diff --git a/prism/src/medical-images.cl b/prism/src/medical-images.cl
new file mode 100644
index 0000000..e6f4a08
--- /dev/null
+++ b/prism/src/medical-images.cl
@@ -0,0 +1,538 @@
+;;;
+;;; medical-images
+;;;
+;;; These are the CLOS (class) definitions for the medical images in
+;;; radiation treatment planning, including 2-D and 3-D images.
+;;;
+;;; 9-May-1992 I. Kalet from earlier prism code
+;;; 14-Jul-1992 I. Kalet add get-transverse-image and draw functions
+;;; 31-Jul-1992 I. Kalet merge in additions from Jon Unger's imagedefs
+;;; 9-Aug-1992 I. Kalet use defs from geometry system
+;;; 7-Sep-1992 I. Kalet make window and level methods modify, not
+;;; replace, default methods
+;;; 13-Nov-1992 I. Kalet/J. Unger move window/level to view, add sl:
+;;; prefix where needed
+;;; 13-Dec-1992 I. Kalet change image-displayed to background-displayed
+;;; 31-Dec-1992 I. Kalet eliminate draw method for SLIK picture, draw
+;;; for views writes to background pixmap.
+;;; 2-Mar-1993 I. Kalet add method for bin-array-pathname
+;;; 27-Apr-1993 J. Unger fix minor bug in downsize-image.
+;;; 28-Apr-1993 J. Unger/I. Kalet break drawing of images up into two
+;;; methods, one for views and one for clx:pixmaps.
+;;; 3-May-1993 I. Kalet move some code here from image-manager, make
+;;; into generic functions instead of using typecase for dispatch.
+;;; 12-May-1993 J. Unger add reader method for pix-per-cm -- computes
+;;; from image size and dimensions of pixels array if necessary.
+;;; 28-Dec-1993 I. Kalet change downsize-image to resize-image
+;;; 7-Jan-1994 I. Kalet add code to generate-image-from-set to resize
+;;; image to view size.
+;;; 21-Jan-1994 I. Kalet add some declarations in an attempt to
+;;; further optimize resize-image.
+;;; 10-Mar-1994 I. Kalet change method draw for pixmap into function
+;;; draw-image-pix
+;;; 23-May-1994 J. Unger optimize some image manipulation code.
+;;; 8-Jun-1994 I. Kalet set ID attribute in resize-image.
+;;; 8-Jan-1995 I. Kalet remove proclaim form.
+;;; 18-Feb-1996 I. Kalet in draw-image-pix let map-image-to-clx put
+;;; the data in the pixmap, hiding the details from this module.
+;;; 19-Sep-1996 I. Kalet remove &rest from draw method.
+;;; 21-Jan-1997 I. Kalet remove references to geometry package, define
+;;; origin, x-orient and y-orient as vectors, use accessors in misc.
+;;; 1-Mar-1997 I. Kalet update calls to NEARLY- functions.
+;;; 03-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx.
+;;; 21-Jan-1998 I. Kalet some optimization mods to make-coronal-image
+;;; and make-sagittal-image.
+;;; 19-Jun-1998 I. Kalet put method for generate-image-from-set for
+;;; beams-eye-views here, with the others.
+;;; 6-Jul-1998 I. Kalet fill in details of drr parameters, add
+;;; make-3d-image.
+;;; 15-Jul-1998 I. Kalet add binarray-filename method and slots for it
+;;; to use.
+;;; 11-Aug-1998 C. Wilcox finish details of drr parameters and related
+;;; functions
+;;; 12-Aug-1998 I. Kalet in generate-image-from-set check if images in
+;;; set before attempting to generate an image from the set
+;;; 28-Sep-1998 I. Kalet set origin in DRR image properly, as it is
+;;; used in the PostScript hard copy code.
+;;; 15-Feb-1999 I. Kalet center generated coronal and sagittal images
+;;; in nominal view area.
+;;; 25-Feb-1999 I. Kalet cosmetic fixes in resize-image-pixels
+;;; 10-Apr-1999 C. Wilcox minor changes to generate-image-from-set
+;;; for bev's to support background processing and DRR's
+;;; 19-Nov-1999 BobGian add UID slot to IMAGE object for DICOM.
+;;; 5-Jan-2000 I. Kalet relax z match criterion for transverse images
+;;; in find-transverse-image.
+;;; 17-Jul-2000 I. Kalet add support for OpenGL image magnification
+;;; and display.
+;;; 30-Jul-2000 I. Kalet split off draw methods and other view related
+;;; stuff to separate file, image-graphics, move draw-image-pix to
+;;; inline code in filmstrip, since used only there.
+;;; 6-Aug-2000 I. Kalet move get-transverse-image back here, not
+;;; related to views.
+;;; 18-Sep-2002 BobGian add PAT-POS (default "HFS") slot to IMAGE class
+;;; for describing patient position as scanned (Head-First Supine, etc)
+;;; 26-Jun-2005 I. Kalet change single-float calls to coerce.
+;;; 3-Jan-2009 I. Kalet add new procedure scale-image that does what
+;;; resize-image-pixels did but way faster in the general case, to
+;;; replace the use of OpenGL for images.
+;;; 1-Jun-2009 I. Kalet remove resize-image-pixels and resize-image
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------
+
+(defclass image ()
+
+ ((id :accessor id
+ :initarg :id)
+
+ (uid :type string
+ :accessor uid
+ :initarg :uid)
+
+ (patient-id :type fixnum
+ :accessor patient-id
+ :initarg :patient-id
+ :documentation "The patient id of the patient this
+image belongs to.")
+
+ (image-set-id :type fixnum
+ :accessor image-set-id
+ :initarg :image-set-id
+ :documentation "The image set id of the primary image
+set the image belongs to, can also be changed in order to make it part
+of another image set.")
+
+ (pat-pos :type string
+ :accessor pat-pos
+ :initarg :pat-pos
+ :documentation "String, one of \"HFP\", \"HFS\", \"FFP\", \"FFS\"
+describing patient position as scanned (Head/Feet-First Prone/Supine, etc).
+Also legal but not used in Prism are \"HFDR\", \"HFDL\", \"FFDR\", \"FFDL\"
+for Head/Feet-first Decubitus Right/Left.")
+
+ (description :type string
+ :accessor description
+ :initarg :description)
+
+ (acq-date :type string
+ :accessor acq-date
+ :initarg :acq-date)
+
+ (acq-time :type string
+ :accessor acq-time
+ :initarg :acq-time)
+
+ (scanner-type :type string
+ :accessor scanner-type ;; GE9800, SOMATOM-DR, etc
+ :initarg :scanner-type)
+
+ (hosp-name :type string
+ :accessor hosp-name
+ :initarg :hosp-name)
+
+ (img-type :type string
+ :accessor img-type ;; CT, NMR, PET, etc
+ :initarg :img-type)
+
+ (origin :type (vector single-float 3)
+ :accessor origin
+ :initarg :origin
+ :documentation "Origin refers to the location in patient
+space of the corner of the image as defined by the point at pixel
+array reference 0 0 or voxel array reference 0 0 0 -- see the pixels
+and voxels slot in the respective image-2D and image-3D subclasses.")
+
+ (size :type list ;; of two or three elements, x y z
+ :accessor size
+ :initarg :size
+ :documentation "The size slot refers to the overall size of
+the image in each dimension, measured in centimeters in patient
+space.")
+
+ (range :type fixnum
+ :accessor range
+ :initarg :range
+ :documentation "Range refers to the maximum pixel/voxel
+value possible for this type of image.")
+
+ (units :type string
+ :accessor units
+ :initarg :units) ;; eg: Hounsfield numbers
+
+ )
+
+ (:default-initargs :id 0 :uid "" :patient-id 0 :image-set-id 0
+ :pat-pos "HFS" :description ""
+ :acq-date "missing" :acq-time "missing"
+ :scanner-type "GE9800Q" :hosp-name "UWMC"
+ :img-type "X-ray CT" :range 4095 :units "H - 1024")
+
+ (:documentation "The basis for all kinds of geometric studies upon
+patients, including 2-D images, 3-D images, 2-D image sets, like a
+series of CT slices, and 3-D image sets. The information here defines
+all the parameters relevant to the moment of study itself and to
+parameters found in all images.")
+
+ )
+
+;;;--------------------------------------------
+
+(defmethod bin-array-pathname ((im image))
+
+ "returns the directory pathname for the image data binary files and
+index files."
+
+ *image-database*)
+
+;;;--------------------------------------------
+
+(defmethod bin-array-filename ((im image) slotname)
+
+ "returns the filename for the image data binary file to which to
+write image im."
+
+ (declare (ignore slotname))
+ (format nil "pat-~D.image-~D-~D"
+ (patient-id im) (image-set-id im) (id im)))
+
+;;;--------------------------------------------
+
+(defclass image-2D (image)
+
+ ((thickness :type single-float
+ :accessor thickness
+ :initarg :thickness)
+
+ (x-orient :type (vector single-float 3)
+ :accessor x-orient
+ :initarg :x-orient
+ :documentation "The x-orient and y-orient slots are
+vectors in patient space that define the orientation of the X and Y
+axes of the image respectively, relative to the patient coordinate
+system.")
+
+ (y-orient :type (vector single-float 3)
+ :accessor y-orient
+ :initarg :y-orient
+ :documentation "See x-orient.")
+
+ (pix-per-cm :type single-float
+ :accessor pix-per-cm
+ :initarg :pix-per-cm)
+
+ (pixels :type (simple-array (unsigned-byte 16) 2)
+ :accessor pixels
+ :initarg :pixels
+ :documentation "Pixels is the array of image data itself.
+The value at each index of the array refers to a sample taken from the
+center of the region indexed, and values for images with non-zero
+thickness refer to points mid-way through the image's thickness. The
+origin of the pixels array is in the upper left hand corner, and the
+array is stored in row-major order so values are indexed as row,
+column pairs, i.e., the dimensions are y, x.")
+
+ )
+
+ (:documentation "An image-2D depicts some 2-D slice, cross section
+or projected view of a patient's anatomy and is typically a single CT
+image, an interpolated cross section of a volume, or the result of ray
+tracing through a volume from an eyepoint to a viewing plane.")
+
+ )
+
+;;;--------------------------------------------
+
+(defmethod pix-per-cm :before ((img image-2D))
+
+ "Computes the pixels per centimeters if not already set."
+
+ (unless (slot-boundp img 'pix-per-cm)
+ (setf (slot-value img 'pix-per-cm)
+ (float (/ (array-dimension (pixels img) 1) (first (size img)))))))
+
+;;;--------------------------------------------
+
+(defmethod slot-type ((object image-2D) slotname)
+
+ (case slotname
+ (pixels :bin-array)
+ (otherwise (call-next-method))))
+
+;;;--------------------------------------------
+
+(defun scale-image (old new mag x0 y0)
+
+ "Does pan and zoom of array data in old to generate new, using mag
+ as the magnification from old to new, and x0 and y0 are the array
+ coordinates in old of the 0,0 pixel in new. The arrays are assumed
+ to be of type unsigned-byte 32, or clx:pixel."
+
+ (let* ((old-dim (array-dimension old 0))
+ (new-dim (array-dimension new 0))
+ (delta (/ 1.0 mag))
+ (old-dim-flt (coerce old-dim 'single-float))
+ (xstart (- x0 delta))
+ (x xstart) ;; initial value not really used
+ (y (- y0 delta)) ;; this is ystart also
+ (yint 0)
+ )
+ (declare (type (simple-array (unsigned-byte 32) 2) old new)
+ (type fixnum x0 y0 old-dim new-dim yint)
+ (type single-float mag delta old-dim-flt xstart x y))
+ (dotimes (j new-dim)
+ (declare (type fixnum j))
+ (incf y delta)
+ (setq yint (round y)
+ x xstart)
+ (dotimes (i new-dim)
+ (declare (type fixnum i))
+ (incf x delta)
+ (setf (aref new j i)
+ (if (or (< x 0.0)
+ (< yint 0)
+ (> x old-dim-flt)
+ (> yint old-dim))
+ 0
+ (aref old yint (the fixnum (round x)))))))
+ new))
+
+;;;--------------------------------------------
+
+(defun find-transverse-image (z images epsilon)
+
+ "find-transverse-image z images
+
+Scans images, a list of image-2D's, for an image whose z-coordinate
+is nearly equal to the z parameter, and returns such an image, if one
+exists, or nil if no such image exists."
+
+ (find z images
+ :test #'(lambda (a b) (poly:nearly-equal a b epsilon))
+ :key #'(lambda (img) (vz (origin img)))))
+
+;;;--------------------------------------------
+
+(defun make-coronal-image (y images)
+
+ "make-coronal-image y images
+
+If y lies within the y-extent of images, a list of image-2D's, this
+routine computes and returns an image-2D whose pixels are a reformatting
+of images at the sagittal plane determined by y. If y lies outside
+the y-extent of images, nil is returned."
+
+ (let ((fi (first images)))
+ (when (poly:nearly-increasing
+ 0.0 (- (vy (origin fi)) y) (second (size fi)))
+ (let* ((new-pix (make-array (array-dimensions (pixels fi))
+ :element-type '(unsigned-byte 16)
+ :initial-element 0))
+ (zlist (mapcar #'(lambda (img) (- (vz (origin img))
+ (/ (thickness img) 2.0)))
+ images))
+ (top-z (* 0.5 (+ (apply #'min zlist) (apply #'max zlist)
+ (- (second (size fi)))))))
+ (declare (single-float top-z)
+ (type (simple-array (unsigned-byte 16) 2) new-pix))
+ (dolist (img images)
+ (let* ((ppcm (pix-per-cm img))
+ (img-pix (pixels img))
+ (new-row (round (* ppcm (- (vz (origin img))
+ (/ (thickness img) 2.0)
+ top-z))))
+ (pixels-thick (truncate (1+ (* ppcm (thickness img)))))
+ (img-dim-x (array-dimension img-pix 0))
+ (img-dim-y (array-dimension img-pix 1))
+ (img-row 0))
+ (declare (single-float ppcm)
+ (type (simple-array (unsigned-byte 16) 2) img-pix)
+ (fixnum pixels-thick img-dim-x
+ img-dim-y new-row img-row))
+ (when (< -1 new-row img-dim-y)
+ (setq img-row (round (* ppcm (- (vy (origin img)) y))))
+ (dotimes (i pixels-thick) ;; row replication
+ (when (< new-row img-dim-y)
+ (dotimes (new-col img-dim-x) ;; pixels in the row
+ (declare (fixnum new-col))
+ (setf (aref new-pix new-row new-col)
+ (aref img-pix img-row new-col))))
+ (incf new-row)))))
+ (make-instance 'image-2D
+ :id 1 ;; arbitrary
+ :description "Prism coronal image"
+ :acq-date (acq-date fi)
+ :acq-time (acq-time fi)
+ :scanner-type (scanner-type fi)
+ :hosp-name (hosp-name fi)
+ :img-type (img-type fi)
+ :origin (vector (vx (origin fi)) y top-z)
+ :size (size fi)
+ :range (range fi)
+ :units (units fi)
+ :thickness 1.0
+ :x-orient (vector 1.0 0.0 0.0)
+ :y-orient (vector 0.0 0.0 1.0)
+ :pix-per-cm (pix-per-cm fi)
+ :pixels new-pix)))))
+
+;;;--------------------------------------------
+
+(defun make-sagittal-image (x images)
+
+ "make-sagittal-image x images
+
+If x lies within the x-extent of images, a list of image-2D's, this
+routine computes and returns an image-2D whose pixels are a reformatting
+of images at the sagittal plane determined by x. If x lies outside
+the x-extent of images, nil is returned."
+
+ (let ((fi (first images)))
+ (when (poly:nearly-increasing
+ 0.0 (- x (vx (origin fi))) (first (size fi)))
+ (let* ((new-pix (make-array (array-dimensions (pixels fi))
+ :element-type '(unsigned-byte 16)
+ :initial-element 0))
+ (zlist (mapcar #'(lambda (img) (- (vz (origin img))
+ (/ (thickness img) 2.0)))
+ images))
+ (top-z (* 0.5 (+ (apply #'min zlist) (apply #'max zlist)
+ (- (second (size fi)))))))
+ (declare (single-float top-z)
+ (type (simple-array (unsigned-byte 16) 2) new-pix))
+ (dolist (img images)
+ (let* ((ppcm (pix-per-cm img))
+ (img-pix (pixels img))
+ (new-col (round (* ppcm (- (vz (origin img))
+ (/ (thickness img) 2.0)
+ top-z))))
+ (pixels-thick (truncate (1+ (* ppcm (thickness img)))))
+ (img-dim-x (array-dimension img-pix 0))
+ (img-dim-y (array-dimension img-pix 1))
+ (img-col 0))
+ (declare (single-float ppcm)
+ (type (simple-array (unsigned-byte 16) 2) img-pix)
+ (fixnum pixels-thick img-dim-x
+ img-dim-y new-col img-col))
+ (when (< -1 new-col img-dim-x)
+ (setq img-col (round (* ppcm (- x (vx (origin img))))))
+ (dotimes (i pixels-thick) ;; column replication
+ (when (< new-col img-dim-x)
+ (dotimes (new-row img-dim-y)
+ (declare (fixnum new-row))
+ (setf (aref new-pix new-row new-col)
+ (aref img-pix new-row img-col))))
+ (incf new-col)))))
+ (make-instance 'image-2D
+ :id 2 ;; arbitrary
+ :description "Prism sagittal image"
+ :acq-date (acq-date fi)
+ :acq-time (acq-time fi)
+ :scanner-type (scanner-type fi)
+ :hosp-name (hosp-name fi)
+ :img-type (img-type fi)
+ :origin (vector x (vy (origin fi)) top-z)
+ :size (size fi)
+ :range (range fi)
+ :units (units fi)
+ :thickness 1.0
+ :x-orient (vector 1.0 0.0 0.0)
+ :y-orient (vector 0.0 0.0 1.0)
+ :pix-per-cm (pix-per-cm fi)
+ :pixels new-pix)))))
+
+;;;--------------------------------------------
+
+(defun make-3d-image (images)
+
+ "make-3d-image z-size images
+
+returns a 3D array and a list of z values from images, a list of
+image-2d, in which the number of pixels in the z direction is z-size."
+
+ (let* ((z-list nil)
+ (count 0)
+ (prev 0.0)
+ (z-array (make-array (+ 1 (length images))
+ :element-type 'single-float))
+ (3dimage (make-array (length images))))
+ ;; create a list to sort the images by z value
+ ;; without side-effecting images
+ (dolist (i images)
+ (setf z-list (cons (list (aref (origin i) 2) count) z-list))
+ (incf count 1))
+ (setq z-list (sort z-list #'< :key #'car))
+ ;; build the sorted arrays for images and corresponding z-values
+ (setf count 0)
+ (setf prev (first (first z-list)))
+ (dolist (e z-list)
+ (setf (aref 3dimage count)
+ (pixels (nth (second e) images)))
+ (setf (aref z-array count)
+ (coerce (/ (+ prev (first e)) 2.0) 'single-float))
+ (setf prev (first e))
+ (incf count 1))
+ (setf (aref z-array count) (coerce prev 'single-float))
+ (values 3dimage z-array)))
+
+;;;--------------------------------------------
+
+(defclass image-3d (image)
+
+ ((voxels :type (simple-array (unsigned-byte 16) 3)
+ :accessor voxels
+ :initarg :voxels
+ :documentation "Voxels is the array of intensities itself
+The value at each index of the array refers to a sample taken from the
+center of the region indexed. The origin of the voxels array is in
+the upper left back corner and the array is stored in row, then plane
+major order, so values are indexed as plane, row, column triples, i.e.
+the dimensions are ordered z, y, x.")
+
+ )
+
+ (:documentation "An image-3D depicts some 3-D rectangular solid
+region of a patient's anatomy.")
+
+ )
+
+;;;--------------------------------------------
+
+(defmethod slot-type ((object image-3d) slotname)
+
+ (case slotname
+ (voxels :bin-array)
+ (otherwise (call-next-method))))
+
+;;;--------------------------------------------
+
+(defun get-transverse-image (im3d z)
+
+ "get-transverse-image im3d z
+
+returns an image-2d instance that corresponds to the transverse image
+at z through the image-3d im3d."
+
+ (let ((vox (voxels im3d))
+ (org (origin im3d))
+ (size (size im3d)))
+ (make-instance 'image-2d
+ :description (format nil "Image at z = ~A" z)
+ :acq-date (acq-date im3d)
+ :acq-time (acq-time im3d)
+ :scanner-type (scanner-type im3d)
+ :hosp-name (hosp-name im3d)
+ :img-type (img-type im3d)
+ :origin (vector (vx org) (vy org) 0.0)
+ :size (list (first size) (second size))
+ :range (range im3d)
+ :units (units im3d)
+ :thickness (/ (float (array-dimension vox 2)) (third size))
+ :x-orient (vector 1.0 0.0 0.0)
+ :y-orient (vector 0.0 1.0 0.0)
+ :pix-per-cm (/ (float (array-dimension vox 1)) (second size))
+ :pixels (sl:get-z-array vox (vz org) (third size) z))))
+
+;;;--------------------------------------------
+;;; End.
diff --git a/prism/src/misc.cl b/prism/src/misc.cl
new file mode 100644
index 0000000..5209392
--- /dev/null
+++ b/prism/src/misc.cl
@@ -0,0 +1,386 @@
+;;;
+;;; misc - miscellaneous functions needed in various Prism modules
+;;;
+;;; 1-Aug-1992 I. Kalet created from the old sys-tools package
+;;; 13-Nov-1992 I. Kalet change half-between to average, put
+;;; get-string, get-number here instead of views
+;;; 2-Jul-1993 I. Kalet put insert-at and delete-at macros here
+;;; 15-Feb-1994 I. Kalet add run-subprocess def for Lucid.
+;;; 19-Apr-1994 J. Unger move fix-float here from dose-panels
+;;; 21-Apr-1994 J. Unger add draw-on-picture
+;;; 25-Apr-1994 J. Unger add optimization to fix-float.
+;;; 12-Jul-1994 J. Unger add compute-tics & supporting code fm beam-graphics
+;;; 11-Aug-1994 J. Unger enhance def of run-subprocess to support :wait param
+;;; 04-Oct-1994 J. Unger move solid <--> dashed color transformations here
+;;; from other places.
+;;; 04-Oct-1994 J. Unger fix omission in find-dashed/solid-color
+;;; functions.
+;;; 8-Jan-1995 I. Kalet remove proclaim form and VAX, Lucid support
+;;; 4-Sep-1995 I. Kalet change some macros to functions, remove
+;;; average, since it is never used. Add type declarations for fast
+;;; arithmetic. Move compute-tics and pixel-segments to
+;;; contour-graphics since they now use pix-x and pix-y.
+;;; [contour-graphics now renamed to pixel-graphics - BobGian]
+;;; 1-Oct-1995 I. Kalet in Allegro version of run-subprocess, use
+;;; excl:run-shell-command for both :wait t and :wait nil cases.
+;;; This should fix an error that occurs with excl:shell on the SGI
+;;; in Be'er Sheva.
+;;; 15-Jan-1996 I. Kalet put average back in - used in coll-panels
+;;; 8-Oct-1996 I. Kalet move find-dashed-color and find-solid-color
+;;; to clx-support, in SLIK.
+;;; 21-Jan-1997 I. Kalet add macros to return coords of a simple 3
+;;; component vector.
+;;; 1-Mar-1997 I. Kalet change NEARLY- macros to functions, change
+;;; key to optional instead of keyword parameter. Also change
+;;; AVERAGE to function.
+;;; 8-May-1997 BobGian add SQR; inline SQR, AVERAGE.
+;;; 8-May-1997 BobGian change (EXPT (some-form) 2) to (SQR
+;;; (some-form)).
+;;; 8-Jun-1997 I. Kalet remove draw-on-picture, replaced by new SLIK
+;;; button type, icon-button.
+;;; 3-Jul-1997 BobGian remove NEARLY-EQUAL, NEARLY-INCREASING, and
+;;; NEARLY-DECREASING from this file; they were duplicated here. All
+;;; are now in math.cl and in the POLYGONS package. (PRISM system now
+;;; explicitly depends on POLYGONS system.) Updated all calls throughout
+;;; PRISM to use the new definitions.
+;;; 3-Oct-1997 BobGian remove AVERAGE, LO-HI-COMPARE - now expanded in-place.
+;;; 27-Oct-1997 BobGian redefine SQR as macro to force compiler to inline it.
+;;; Allegro compiler does not obey INLINE decl for user-defined functions,
+;;; which is perfectly legal by CommonLisp spec.
+;;; 27-Jan-1998 I. Kalet add insert function, remove insert-at and
+;;; delete-at macros, add anaphoric macros from Graham, On Lisp.
+;;; 24-Dec-1998 I. Kalet fix up run-subprocess a little, and change
+;;; upper case to lower.
+;;; 23-Jan-2002 I. Kalet add listify function, add nearest function
+;;; 17-Feb-2005 A. Simms add getenv function as an implementation neutral
+;;; mechanism to access environment variables from Allegro and CMUCL.
+;;; 18-Apr-2005 I. Kalet cosmetic fixes
+;;; 22-Jun-2007 I. Kalet take out declarations in vx, vy and vz macros
+;;; - they are unnecessary and cause warnings in other functions.
+;;;
+
+(in-package :prism)
+
+;;;------------------------------------------
+
+(defun date-time-string ()
+
+ "date-time-string
+
+Takes no parameters and returns the current system date and time as a
+string."
+
+ (multiple-value-bind
+ (second minute hour date month year) (get-decoded-time)
+ (format nil "~d-~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;~
+ Sep~;Oct~;Nov~;Dec~]-~d ~d:~2,'0d:~2,'0d"
+ date (1- month) year hour minute second)))
+
+;;;------------------------------------------
+
+(defun listify (str len)
+
+ "listify str len
+
+returns a list of strings, that are sequential substrings of str each
+of length len."
+
+ (let ((strlen (length str))
+ str-list)
+ (dotimes (i (ceiling strlen len) str-list)
+ (setf str-list
+ (append str-list
+ (list (subseq str (* len i) (min (* len (1+ i)) strlen))))))))
+
+;;;------------------------------------------
+
+(defun max-length (s)
+
+ "max-length s
+
+Finds the longest item in sequence s, and returns the length of it.
+The items are presumed to be themselves sequences."
+
+ (apply #'max (mapcar #'length s)))
+
+;;;------------------------------------------
+
+(defun nearest (x lst epsilon &optional direction)
+
+ "nearest x lst epsilon &optional direction
+
+returns the value in lst that is closest to x but not within epsilon
+of x. If direction is the keyword :below, the nearest value less than
+x is returned, and if :above, the nearest value greater than x. If
+direction is not specified the closest value is returned, except if
+there is a tie between the values below and above, the below value is
+returned. If there are not other contours to copy, returns nil."
+
+ (let* ((tmp (remove x lst :test #'(lambda (a b) (poly:nearly-equal
+ a b epsilon))))
+ (less-x (remove x tmp :test #'<))
+ (more-x (remove x tmp :test #'>))
+ (lower (if less-x (apply #'max less-x)))
+ (upper (if more-x (apply #'min more-x))))
+ (cond ((eql direction :below) lower)
+ ((eql direction :above) upper)
+ ((null lower) upper)
+ ((null upper) lower)
+ ((poly:nearly-equal (- x lower) (- upper x)) lower)
+ ((< (- x lower) (- upper x)) lower)
+ (t upper))))
+
+;;;------------------------------------------
+
+(defun insert (item lst &key (test #'>) (key #'identity))
+
+ "insert item lst &key (test #'>) (key #'identity)
+
+returns a list with item inserted in the right place in the ordered
+list lst, using test as a comparision function and key applied to each
+element of lst to provide input to the test function."
+
+ (cond ((null lst) (list item))
+ ((funcall test
+ (funcall key (first lst))
+ (funcall key item))
+ (cons item lst))
+ (t (cons (first lst)
+ (insert item (rest lst) :test test :key key)))))
+
+;;;------------------------------------------
+;;; these anaphors are straight out of
+;;; Graham, On Lisp (page 191)
+
+(defmacro aif (test-form then-form &optional else-form)
+ `(let ((it ,test-form))
+ (if it ,then-form ,else-form)))
+
+(defmacro awhen (test-form &body body)
+ `(aif ,test-form
+ (progn , at body)))
+
+(defmacro awhile (expr &body body)
+ `(do ((it ,expr ,expr))
+ ((not it))
+ , at body))
+
+;;;------------------------------------------
+
+(defun enlarge-array-2 (arr x-fac &optional (y-fac x-fac))
+
+ "enlarge-array-2 arr x-fac &optional (y-fac x-fac)
+
+Scales an array up by the given x and y factors (y-fac defaults to
+x-fac if only one factor provided) and returns the enlarged array.
+Essentially expands each element of the input array to fill a small
+cell of elements of the result array. No fancy interpolation, etc.
+Note: x and y fac must be integers."
+
+ (let* ((x-dim (array-dimension arr 1))
+ (y-dim (array-dimension arr 0))
+ (new-x (* x-fac x-dim))
+ (new-y (* y-fac y-dim))
+ (x-amt 0)
+ (y-amt 0)
+ (y-sum 0)
+ (result (make-array (list new-y new-x)
+ :element-type '(unsigned-byte 16))))
+
+ (declare (type (simple-array (unsigned-byte 16) 2) arr result))
+ (declare (fixnum x-fac y-fac x-dim y-dim new-x new-y x-amt y-amt
+ y-sum))
+
+ (dotimes (j y-dim result)
+ (declare (fixnum j))
+ (setq y-amt (* j y-fac))
+ (dotimes (i x-dim result)
+ (declare (fixnum i))
+ (setq x-amt (* i x-fac))
+ (dotimes (v y-fac result)
+ (declare (fixnum v))
+ (setq y-sum (+ y-amt v))
+ (dotimes (u x-fac result)
+ (declare (fixnum u))
+ (setf (aref result y-sum (+ x-amt u)) (aref arr j i))))))))
+
+;;;------------------------------------------
+;;; these are macros in order to get the effect
+;;; of compiling to inline code
+;;;------------------------------------------
+
+(defmacro vx (vec)
+
+ "vx vec
+
+returns the x component of the simple vector vec"
+
+ `(svref ,vec 0))
+
+;;;------------------------------------------
+
+(defmacro vy (vec)
+
+ "vy vec
+
+returns the y component of the simple vector vec"
+
+ `(svref ,vec 1))
+
+;;;------------------------------------------
+
+(defmacro vz (vec)
+
+ "vz vec
+
+returns the z component of the simple vector vec"
+
+ `(svref ,vec 2))
+
+;;;------------------------------------------
+
+(defmacro sqr (x)
+
+ "sqr x
+
+Returns X squared (single-float in/out only)."
+
+ (cond ((symbolp x)
+ ;; Simple case - can evaluate arg twice because it is a variable.
+ `(the single-float (* (the single-float ,x)
+ (the single-float ,x))))
+ ;;
+ ;; Slightly harder case - want to avoid double evaluation
+ ;; of argument form.
+ (t (let ((var (gensym)))
+ `(let ((,var (the single-float ,x)))
+ (declare (single-float ,var))
+ (the single-float (* ,var ,var)))))))
+
+;;;------------------------------------------
+
+(defun get-string (prompt)
+
+ "get-string prompt
+
+Writes the prompt to *standard-output*, waits for input from
+*standard-input*, and returns a string typed by the user."
+
+ (princ prompt)
+ (let ((str ""))
+ (loop
+ (setq str (read-line))
+ (unless (equal str "") (return str)))))
+
+;;;------------------------------------------
+
+(defun get-number (prompt &optional ll ul)
+
+ "get-number prompt &optional ll ul
+
+Writes the prompt to *standard-output*, waits for input from
+*standard-input*, and returns a number typed by the user. If the
+input is outside the range (ll ul), or not a number, the user is
+reprompted."
+
+ (let ((stuff ""))
+ (loop
+ (princ prompt)
+ (setq stuff (read))
+ (if (numberp stuff)
+ (if (and ll ul) ;; assume values are valid if not nil
+ (if (and (>= stuff ll)
+ (<= stuff ul))
+ (return stuff))
+ (return stuff))
+ (format T "Please enter a number ~%")))
+ stuff))
+
+;;;------------------------------------------
+
+(defun fix-float (flt int)
+
+ "fix-float flt int
+
+Returns flt, rounded to int significant digits to the right of the
+decimal point."
+
+ (let ((pow (expt 10.0 (float int))))
+ (declare (single-float flt pow))
+ (declare (fixnum int))
+ (/ (round (* pow flt)) pow)))
+
+;;;------------------------------------------
+;;; versions of run-subprocess for different lisp
+;;; implemenations.
+;;;------------------------------------------
+
+(defun run-subprocess (command &key (wait t))
+
+ "run-subprocess command &key (wait t)
+
+Invokes the string command in a shell as a subprocess. If the keyword
+parameter wait is t (the default), the subprocess is run
+synchronously, i.e., the caller waits until the subprocess terminates
+before control is returned to it and run-subprocess returns the exit
+status. If wait is nil, the subprocess runs asynchronously and the
+function returns immediately, returning the process-id of the shell
+that is created."
+
+ #+allegro
+ (multiple-value-bind (status v pid) ;; note - if wait is nil, status
+ ;; is actually a stream but we don't care in that case
+ (excl:run-shell-command (format nil "~a" command) :wait wait)
+ (declare (ignore v))
+ (if wait status pid))
+
+ #+cmu
+ (let (p)
+ (setq p (extensions:run-program command :wait wait))
+ (cond
+ ((extensions:process-p p)
+ (if wait
+ (extensions:process-status p)
+ (extensions:process-pid p)))
+ (t
+ nil)))
+
+ )
+
+;;;-----------------------------------
+
+(defun distance (a b c d)
+
+ "distance a b c d
+
+Returns the distance between the point (a,b) and the point (c,d)."
+
+ (declare (single-float a b c d))
+ (the single-float (sqrt (+ (sqr (- c a)) (sqr (- d b))))))
+
+;;;-----------------------------------
+;;; versions of getenv for different lisp
+;;; implemenations.
+;;;------------------------------------------
+
+(defun getenv (varname)
+
+ "getenv varname
+
+Searches the set of enviornment variables for the name specified.
+If an environment variable of the specified name exists the
+value of the variable is returned. If the variable does not
+exist nil is returned."
+
+ #+allegro
+ (sys:getenv varname)
+
+ #+cmu
+ (if (stringp varname)
+ (cdr (assoc (intern varname "KEYWORD") ext:*environment-list*))
+ (cdr (assoc varname ext:*environment-list*)))
+
+ )
+
+;;;------------------------------------------
+;;; End.
diff --git a/prism/src/mlc-collimators.cl b/prism/src/mlc-collimators.cl
new file mode 100644
index 0000000..df9c184
--- /dev/null
+++ b/prism/src/mlc-collimators.cl
@@ -0,0 +1,659 @@
+;;;
+;;; mlc-collimators
+;;;
+;;; Functions and constants for dealing with collimators
+;;; which have both leaves and jaws.
+;;; Contains functions used in Client only.
+;;;
+;;; These collimators are instances of the multileaf-coll class,
+;;; but much of this code is specific to Elekta SL20 machines.
+;;; We made some effort to factor out the machine-specific features
+;;; to the multileaf-collim-info class, represented here by
+;;; the instance *sl-collim-info*, and some of the code here
+;;; might be made more machine independent by passing an instance of
+;;; multileaf-collim-info to some functions.
+;;;
+;;; But other features here
+;;; are specific to Elekta machines and are not parameterized:
+;;; the constraints on movement and proximity of leaves and jaws
+;;; which make "flagpole" configurations necessary, and the
+;;; nomenclature that appears in messages.
+;;;
+;;; Changes made in the old constraints.cl:
+;;; 10-Jul-2001 J. Jacky Started
+;;; 13-Jul-2001 J. Jacky Correct def'n of exposed
+;;; 27-Jul-2001 J. Jacky Change 3,1 formats to 4,2
+;;; 28-Aug-2001 J. Jacky Remove "Upper", "Lower" from msgs, remove bank var
+;;; Changes made in the old dicom-panel.cl:
+;;; 11-Jul-2001 J. Jacky defparameter *sl-collim-info* not SL20A-6MV-MLC
+;;; 27-Jul-2001 J. Jacky Don't overcenter last open leaf
+;;; 1-Aug-2001 J. Jacky make leaf-pair-map in *sl-collim-info* match RTD
+;;; 28-Aug-2001 J. Jacky new make-flagpole
+;;; 30-Aug-2001 J. Jacky adjust-ends: handle very small fields, flagpole
+;;; 31-Aug-2001 J. Jacky make-flagpole: refine criteria for flagpole left/rt.
+;;; 5-Sep-2001 J. Jacky adjust-ends: fix when ymax < half leaf width
+;;; 10-Sep-2001 J. Jacky beam-warnings uses new shape-diff
+;;; 11-Sep-2001 J. Jacky beam-warnings: include tol in check, use nleaves,
+;;; if flagpole but field shape preserved say so
+;;; shape-diff: use nleaves not hard-coded 39
+;;; Changes made in the new sl-collimators.cl:
+;;; 11-Sep-2001 J. Jacky Begun, extracted from dicom-panel.cl, constraints.cl
+;;; Move magic numbers to (let...) at start of each fcn.
+;;; rename beam-warnings to collim-warnings, pass colls
+;;; rename constraint-violations to collim-constraint-..
+;;; 12-Sep-2001 J. Jacky new make-multileaf-coll
+;;; make-flagpole takes, returns a multileaf-coll
+;;; make-adjusted-ends takes, returns a multileaf-coll
+;;; 31-Jan-2002 I. Kalet move round-digits here from dicom-panel to
+;;; remove circular module dependency.
+;;; 28-May-2002 I. Kalet parametrize minimum leaf separation (local
+;;; variable mls below).
+;;; 27-Aug-2003 BobGian Uniformize variable names in preparation
+;;; for adding Dose Monitoring Points.
+;;; 06-Oct-2003 BobGian Uniformize indentation/commenting style.
+;;; LET* -> LET where possible (vars not bound sequentially).
+;;; 12-May-2004 BobGian:
+;;; COLLIM-WARNINGS - reversed coll args [consistent with other comparisons].
+;;; FLAG-DIFF - reversed coll args [as above], plus fixed bogus doc string.
+;;; SHAPE-DIFF - reversed collimator args [as above].
+;;; 17-May-2004 BobGian complete process of extending all instances of Original
+;;; and Current Prism beam instances to include Copied beam instance too,
+;;; to provide copy for comparison with Current beam without mutating
+;;; Original beam instance.
+;;; 05-Oct-2004 BobGian fixed a few lines to fit within 80 cols.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+;;; This information also appears in each of the SL20 machine data files
+;;; but we can't depend on knowing any of their names so we need this parameter
+
+(defparameter *sl-collim-info*
+ (make-instance 'multileaf-collim-info
+ :col-headings " X Y2 Leaves Y1 Leaves X"
+ :num-leaf-pairs 40
+ :edge-list '(20.0 19.0 18.0 17.0 16.0 15.0 14.0 13.0 12.0 11.0
+ 10.0 9.0 8.0 7.0 6.0 5.0 4.0 3.0 2.0 1.0 0.0 -1.0
+ -2.0 -3.0 -4.0 -5.0 -6.0 -7.0 -8.0 -9.0 -10.0 -11.0
+ -12.0 -13.0 -14.0 -15.0 -16.0 -17.0 -18.0 -19.0 -20.0)
+ :leaf-pair-map '((1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)
+ (10 10) (11 11) (12 12) (13 13) (14 14) (15 15) (16 16)
+ (17 17) (18 18) (19 19) (20 20) (21 21) (22 22) (23 23)
+ (24 24) (25 25) (26 26) (27 27) (28 28) (29 29) (30 30)
+ (31 31) (32 32) (33 33) (34 34) (35 35) (36 36) (37 37)
+ (38 38) (39 39) (40 40))
+ :inf-leaf-scale -1.0
+ :leaf-open-limit 20.0
+ :leaf-overcenter-limit 12.5))
+
+;;;-------------------------------------------------------------
+
+(defvar *minimum-leaf-gap* 0.5 "the minimum gap between leaves
+required, changes sometimes with machine control software updates.")
+
+;;;=============================================================
+
+(defun open-pair (i leaves)
+
+ "open-pair i leaves
+
+Return t if i'th pair in leaves is open"
+
+ ;; Just checks whether there is a gap between leaves.
+ ;; Code in SHAPE-DIFF uses a different criteria, checks jaws and leaves.
+
+ (let ((eps 0.1))
+ (< (+ (first (nth i leaves)) eps) (second (nth i leaves)))))
+
+;;;-------------------------------------------------------------
+
+(defun round-digits (x n)
+
+ "round-digits x n
+
+Round float x to n decimal digits: (round-digits 7.46342 2) -> 7.46 exactly"
+
+ ;; Purpose: ensure that displayed number in ~m,nF format equals stored number
+ ;; so program doesn't complain that numbers that look okay aren't within tol.
+ ;; n digits not always possible because some neat-looking decimal numbers
+ ;; don't have an exact floating point representation so we get 0.59999996
+ ;; not 0.6 and 38.800003 not 38.80 But these are close enough for us.
+
+ (let ((k (expt 10 n)))
+ (float (/ (round (* x k)) k))))
+
+;;;-------------------------------------------------------------
+
+(defun make-multileaf-coll (coll-angle coll-vertices coll-info)
+
+ "make-multileaf-coll coll-angle coll-vertices coll-info
+
+Return an instance of multileaf-coll with leaves and jaws set
+to fit portal contour defined by coll-vertices in collimator rotated
+by coll-angle, where number/dimensions of leaves is defined in coll-info."
+
+ ;; This function computes the simplest leaf and jaw settings that fit.
+ ;; It does not set flagpole make any other adjustments to accommodate Elekta.
+
+ (let* ((coll-r-vertices (poly:rotate-vertices
+ coll-vertices (- coll-angle)))
+ (coll-box (poly:bounding-box coll-r-vertices))
+ (xmin-f (first (first coll-box)))
+ (xmax-f (first (second coll-box)))
+ (ymin-f (second (first coll-box)))
+ (ymax-f (second (second coll-box)))
+ (xmin (round-digits xmin-f 2))
+ (xmax (round-digits xmax-f 2))
+ (ymin (round-digits ymin-f 2))
+ (ymax (round-digits ymax-f 2))
+ (edges (edge-list coll-info))
+ (leaf-pos-f (compute-mlc coll-angle coll-vertices edges))
+ (leaf-pos (mapcar #'(lambda (leaf-pair)
+ (mapcar #'(lambda (leaf) (round-digits leaf 2))
+ leaf-pair))
+ leaf-pos-f)))
+ ;; multileaf-coll has accessors but not initargs, so we must be long-winded
+ (let ((c (make-instance 'multileaf-coll)))
+ (setf (x1 c) xmin (x2 c) xmax (y1 c) ymin (y2 c) ymax
+ (vertices c) (copy-tree coll-vertices)
+ (leaf-settings c) leaf-pos)
+ c)))
+
+;;;-------------------------------------------------------------
+
+(defun make-flagpole (collim)
+
+ "make-flagpole collim
+
+Return an instance of multileaf-coll which uses a flagpole configuration
+to achieve the same (or similar) field shape as the input multileaf-coll"
+
+ ;; "Flagpole" refers to a configuration of jaws and leaves that defines a
+ ;; field that does not cross Prism x axis but still meets Elekta constraints:
+ ;; y-jaws (Elekta X1 and X2 jaws) cannot overcenter, leaves must not touch
+
+ (let ((ymin (y1 collim))
+ (ymax (y2 collim))
+ (xmin (x1 collim))
+ (xmax (x2 collim))
+ (new-leaf-settings (copy-tree (leaf-settings collim))))
+ (if (and (<= ymin 0.0) (>= ymax 0.0))
+ ;; no flagpole needed but return new instance, can't share structure
+ (let ((c (copy collim))) ; copies z, vertices but not other items
+ (setf (x1 c) xmin (x2 c) xmax (y1 c) ymin (y2 c) ymax
+ (leaf-settings c) new-leaf-settings)
+ c)
+ ;; make flagpole - min leaf separation in cm + margin for rounding err
+ (let* ((mls (+ *minimum-leaf-gap* 0.001))
+ (marg 0.2) ; margin of diaphragm over leaf in flagpole
+ (dtol 0.3) ; if xldiff > xrdiff by this much,put f'pole on left
+ (last-top 19) ; index of last leaf in top half (touches cax)
+ (first-bottom 20) ; index of first leaf in bottom half (at cax)
+ (r-overlim (leaf-overcenter-limit *sl-collim-info*)) ; 12.5
+ (l-overlim (- r-overlim)) ; left overcenter limit
+ (top (> ymin 0.0)) ; open leaves in top half, all in 0..19
+ ;; lcent is index of open leaf nearest center
+ ;; compute-mlc opens leaf if portal intrudes at least .5cm
+ (lcent (if top (- last-top (round ymin))
+ (- first-bottom (round ymax))))
+ (ltop (if top (+ lcent 1) last-top)) ; index of leaf at top
+ (lbottom (if top first-bottom (- lcent 1)))
+ ;; leaf might not be open if portal contour very small
+ (cpair (nth lcent new-leaf-settings))
+ (cpair-open (open-pair lcent new-leaf-settings))
+ (xlcpair (if cpair-open (first cpair) xmin))
+ (xrcpair (if cpair-open (second cpair) xmax))
+ (xldiff (- xlcpair xmin)) ; central lf intrudes past jaw on left
+ (xrdiff (- xmax xrcpair)) ; pos diff measures badness of fit
+ (xl-l (- xmin mls marg)) ; left edge of flagpole on left side
+ (xr-l (- xmin marg)) ; right edge of flagpole on left side
+ (xl-r (+ xmax marg))
+ (xr-r (+ xmax mls marg))
+ ;; if flagpole would exceed overcenter limit, put on other side
+ ;; if xrdiff, xldiff equal within 3 mm, put flagpole more
+ ;; central; otherwise put flagpole on side where diff is least
+ (left (cond ((> xl-r r-overlim) t) ; right exceeds overctr limit
+ ((< xr-l l-overlim) nil)
+ ((< (abs (- xldiff xrdiff)) dtol) ; equal fit,
+ (< (abs xl-l) (abs xr-r))) ; choose more central
+ (t (< xldiff xrdiff)))) ; ch side with least diff
+ (xl (if left xl-l xl-r)) ; left edge of flagpole
+ (xr (if left xr-l xr-r))
+ (ymin-p (if top 0.0 ymin))
+ (ymax-p (if top ymax 0.0)))
+ #+ignore
+ (format
+ t
+ "xmin ~A xmax ~A xlcpair ~A xrcpair ~A xldiff ~A xrdiff ~A~%"
+ xmin xmax xlcpair xrcpair xldiff xrdiff)
+ #+ignore
+ (format t "xl-l ~A xr-l ~A xl-r ~A xr-r ~A left ~A~%"
+ xl-l xr-l xl-r xr-r left)
+ (if left
+ (setf (first (nth lcent new-leaf-settings)) xl
+ (second (nth lcent new-leaf-settings)) xrcpair)
+ (setf (first (nth lcent new-leaf-settings)) xlcpair
+ (second (nth lcent new-leaf-settings)) xr))
+ (do ((i ltop (+ i 1))) ; indices increase toward bottom of field
+ ((> i lbottom))
+ (setf (first (nth i new-leaf-settings)) xl)
+ (setf (second (nth i new-leaf-settings)) xr))
+
+ (let ((c (copy collim)))
+ (setf (x1 c) xmin (x2 c) xmax (y1 c) ymin-p (y2 c) ymax-p
+ (leaf-settings c) new-leaf-settings)
+ c)))))
+
+;;;-------------------------------------------------------------
+
+(defun make-adjusted-ends (collim)
+
+ "make-adjusted-ends collim
+
+Return multileaf-coll with more leaf pairs at ends of field opened if needed"
+
+ ;; To satify Elekta requirement that field ends (in Prism y-direction)
+ ;; must be formed by collimator jaws (Elekta X1, X2 jaws), not leaves
+ ;; (you can't have closed leaves exposed by Elekta X jaws)
+ ;; *sl-collim-info* is hardwired in, used to find coords of leaf edges
+
+ (let* ((xmin (x1 collim))
+ (xmax (x2 collim))
+ (ymin (y1 collim))
+ (ymax (y2 collim))
+ (collim-data *sl-collim-info*)
+ (edge-lst (edge-list collim-data))
+ (old-leaf-settings (leaf-settings collim))
+ (new-leaf-settings (copy-tree old-leaf-settings)) ; may update w/setf
+ (l-last 39) ; index of last leaf
+ (last-top 19) ; index of last leaf in top half, touches cax
+ (first-bottom 20) ; index of first leaf in bottom half, touches cax
+ (mmax 100.0) ; greater than any expected value
+ (mmin -100.0) ; less than any expected value
+ (y-ulimit (first edge-lst)) ; 20.0 for SL20
+ (y-llimit (nth (+ l-last 1) edge-lst)) ; -20.0
+ ;; ltop is index of top open leaf
+ (ltop (do ((i 0 (+ i 1))) ((> i l-last) nil) ; nil if no open leaves
+ (if (open-pair i old-leaf-settings) (return i))))
+ ;; ytop is y-coord of top edge of aperture formed by open leaves
+ (ytop (if ltop (nth ltop edge-lst)
+ mmin)) ; force ytop < ymax
+ (lbottom (do ((i l-last (- i 1))) ((< i 0) nil)
+ (if (open-pair i old-leaf-settings) (return i))))
+ (ybottom (if lbottom (nth (+ lbottom 1) edge-lst)
+ mmax))
+ (xl mmax) ; place-holder, reassign later
+ (xr mmin))
+ #+ignore
+ (format t "xmin ~A xmax ~A ymin ~A ymax ~A~%" xmin xmax ymin ymax)
+ #+ignore
+ (format t "ltop ~A ytop ~A lbottom ~A ybottom ~A~%"
+ ltop ytop lbottom ybottom)
+ ;; if leaf under top jaw edge is not open, open it
+ (if (< ytop ymax y-ulimit) ; ymax might be past last leaf
+ (progn
+ (if (and ltop (open-pair ltop old-leaf-settings))
+ (setf xl (first (nth ltop old-leaf-settings))
+ xr (second (nth ltop old-leaf-settings)))
+ (setf xl xmin xr xmax))
+ (setf ltop (- first-bottom (ceiling ymax))
+ (first (nth ltop new-leaf-settings)) xl
+ (second (nth ltop new-leaf-settings)) xr
+ ytop (nth ltop edge-lst))))
+ #+ignore
+ (format t "open leaf under top jaw: new ltop ~A ytop ~A xl ~A xr ~A~%"
+ ltop ytop xl xr)
+ ;; open one more leaf past top jaw, but never overcenter this one
+ (if (> ltop 0)
+ (let ((ltop-outer (- ltop 1)))
+ (setf xl (first (nth ltop new-leaf-settings))
+ xr (second (nth ltop new-leaf-settings))
+ (first (nth ltop-outer new-leaf-settings))
+ (if (<= xl 0.0) xl -1.0)
+ (second (nth ltop-outer new-leaf-settings))
+ (if (>= xr 0.0) xr 1.0))))
+ #+ignore
+ (format t "open leaf past top jaw ltop ~A ltop-outer ~A xl ~A xr ~A~%"
+ ltop ltop-outer xl xr)
+
+ ;; if leaf under bottom jaw edge is not open, open it
+ (if (> ybottom ymin y-llimit)
+ (progn
+ (if (and lbottom (open-pair lbottom old-leaf-settings))
+ (setf xl (first (nth lbottom old-leaf-settings))
+ xr (second (nth lbottom old-leaf-settings)))
+ (setf xl xmin xr xmax))
+ (setf lbottom (- last-top (floor ymin))
+ (first (nth lbottom new-leaf-settings)) xl
+ (second (nth lbottom new-leaf-settings)) xr
+ ybottom (nth lbottom edge-lst))))
+ ;; open one more leaf past bottom jaw, but never overcenter this one
+ (if (< lbottom l-last)
+ (let ((lbottom-outer (+ lbottom 1)))
+ (setf xl (first (nth lbottom new-leaf-settings))
+ xr (second (nth lbottom new-leaf-settings))
+ (first (nth lbottom-outer new-leaf-settings))
+ (if (<= xl 0.0) xl -1.0)
+ (second (nth lbottom-outer new-leaf-settings))
+ (if (>= xr 0.0) xr 1.0))))
+ (let ((c (copy collim)))
+ (setf (x1 c) xmin (x2 c) xmax (y1 c) ymin (y2 c) ymax
+ (leaf-settings c) new-leaf-settings)
+ c)))
+
+;;;-------------------------------------------------------------
+
+(defun collim-constraint-violations (collim)
+
+ "collim-constraint-violations collim
+
+Return list of strings describing constraint violations in collimator
+with respect to *sl-collim-info*, or nil if there are none."
+
+ ;; Constraints on minimum leaf separation are specific to the Elekta SL20
+ ;; Text in strings uses Elekta coord systems and nomenclature, not Prism
+
+ ;; minimum permissible separation between opposite leaves
+ (let* ((mls *minimum-leaf-gap*)
+ (x1 (x1 collim))
+ (x2 (x2 collim))
+ (y1 (y1 collim))
+ (y2 (y2 collim))
+ (collim-data *sl-collim-info*)
+ (leaves (leaf-settings collim))
+ (n (num-leaf-pairs collim-data))
+ (lnums (leaf-pair-map collim-data))
+ (edges (edge-list collim-data))
+ (ymax (first edges))
+ (xmax (leaf-open-limit collim-data))
+ (xover (leaf-overcenter-limit collim-data))
+ (vl nil)) ; vl is list of constraint violations
+
+ ;; Calculations are performed in Prism coordinates,
+ ;; but messages all refer to Elekta coords on DICOM panel
+
+ ;; Prism -y1, y2 are Elekta X2, X1, hard-code y limits, not in COLLIM-DATA
+ (if (< y1 (- ymax))
+ (push (format nil "X2 diaphragm open too far: ~4,2F" (- y1)) vl))
+ (if (> y1 0.0)
+ (push (format nil "X2 diaphragm overcentered: ~4,2F" y1) vl))
+ (if (> y2 ymax)
+ (push (format nil "X1 diaphragm open too far: ~4,2F" y2) vl))
+ (if (< y2 0.0)
+ (push (format nil "X1 diaphragm overcentered: ~4,2F" (- y2)) vl))
+
+ ;; Prism -x1, x2 are Elekta Y2, Y1
+ (if (> x1 x2)
+ (push
+ (format nil "Y diaphragms collide: Y2 ~4,2F Y1 ~4,2F" (- x1) x2)
+ vl))
+ (if (< x1 (- xmax))
+ (push (format nil "Y2 diaphragm open too far: ~4,2F" (- x1))
+ vl))
+ (if (> x1 xover)
+ (push (format nil "Y2 diaphragm overcentered too far: ~4,2F" x1)
+ vl))
+ (if (> x2 xmax)
+ (push (format nil "Y1 diaphragm open too far: ~4,2F" x2)
+ vl))
+ (if (< x2 (- xover))
+ (push (format nil "Y1 diaphragm overcentered too far: ~4,2F" (- x2))
+ vl))
+
+ (do* ((i 0 (1+ i)))
+ ((= i n) vl) ; vl is the return value from the do and the whole fcn
+ (let* ((lnum (first (nth i lnums))) ; leaf number
+ (onum (second (nth i lnums))) ; opposite leaf number
+ ;; in general leaves are variable width, diaphragms can overcenter
+ (exposed (or (>= y2 (nth i edges) y1) ; so must check both edges
+ (>= y2 (nth (+ i 1) edges) y1)))
+ (pair (nth i leaves))
+ (xl (first pair))
+ (xr (second pair))
+ (exposed-prev
+ (if (= i 0) nil
+ (or (>= y2 (nth (- i 1) edges) y1)
+ (>= y2 (nth i edges) y1))))
+ (xr-prev (if (= i 0) xmax (second (nth (- i 1) leaves))))
+ (exposed-next
+ (if (= i (- n 1)) nil
+ (or (>= y2 (nth (+ i 1) edges) y1)
+ (>= y2 (nth (+ i 2) edges) y1))))
+ (xr-next (if (= i (- n 1)) xmax (second (nth (+ i 1) leaves)))))
+ (if (< xl (- xmax))
+ (push (format nil "Y2 leaf ~A open too far: ~4,2F"
+ lnum (- xl)) vl))
+ (if (> xl xover)
+ (push (format nil "Y2 leaf ~A overcentered too far: ~4,2F"
+ lnum xl) vl))
+ (if (> xr xmax)
+ (push (format nil "Y1 leaf ~A open too far: ~4,2F"
+ onum xr) vl))
+ (if (< xr (- xover))
+ (push (format nil "Y1 leaf ~A overcentered too far: ~4,2F"
+ onum (- xr)) vl))
+ (if (and exposed (< (- xr xl) mls))
+ (push (format
+ nil
+ #.(concatenate 'string
+ "Leaf ~A too close to directly opposite"
+ " leaf ~A: Y2 ~4,2F Y1 ~4,2F")
+ lnum onum (- xl) xr)
+ vl))
+ (if (and exposed exposed-prev (< (- xr-prev xl) mls))
+ (push (format
+ nil
+ #.(concatenate 'string
+ "Leaf ~A too close to opposite neighbor"
+ " leaf ~A: Y2 ~4,2F Y1 ~4,2F")
+ lnum (second (nth (- i 1) lnums)) ; onum prev.
+ (- xl) xr-prev)
+ vl))
+ (if (and exposed exposed-next (< (- xr-next xl) mls))
+ (push (format
+ nil
+ #.(concatenate 'string
+ "Leaf ~A too close to opposite neighbor"
+ " leaf ~A: Y2 ~4,2F Y1 ~4,2F")
+ lnum (second (nth (+ i 1) lnums)) ; onum next
+ (- xl) xr-next)
+ vl))))))
+
+;;;-------------------------------------------------------------
+
+(defun flag-diff (copy-coll curr-coll)
+
+ "flag-diff copy-coll curr-coll
+
+ Returns T if CURR-COLL is a flagpole version of COPY-COLL, NIL otherwise."
+
+ ;; Both args are copied collimators in beams which are copies
+ ;; made from original beam in Prism plan. First is unmodified while
+ ;; second may be modified by user.
+
+ ;; for now, don't even check leaves - just look at jaws
+ (let ((ymin-o (y1 copy-coll))
+ (ymax-o (y2 copy-coll))
+ (ymin (y1 curr-coll))
+ (ymax (y2 curr-coll)))
+ (or (and (< ymax-o 0.0) (= ymax 0.0))
+ (and (> ymin-o 0.0) (= ymin 0.0)))))
+
+;;;-------------------------------------------------------------
+
+(defstruct lpair open open-o xl xl-o xr xr-o)
+
+;;;-------------------------------------------------------------
+
+(defun shape-diff (copy-coll curr-coll end-tol)
+
+ "shape-diff copy-coll curr-coll end-tol
+
+Return list of lpair structures, one for each leaf pair,
+describing differences between field shapes defined by CURR-COLL
+and COPY-COLL, considering both jaws and leaves"
+
+ ;; Both args are copied collimators in beams which are copies
+ ;; made from original beam in Prism plan. First is unmodified while
+ ;; second may be modified by user.
+
+ ;; This function does not contain any Elekta SL20 particulars
+
+ (let* ((edges (edge-list *sl-collim-info*))
+ (xmin-o (x1 copy-coll))
+ (xmax-o (x2 copy-coll))
+ (ymin-o (y1 copy-coll))
+ (ymax-o (y2 copy-coll))
+ (leaves-o (leaf-settings copy-coll))
+ (xmin (x1 curr-coll))
+ (xmax (x2 curr-coll))
+ (ymin (y1 curr-coll))
+ (ymax (y2 curr-coll))
+ (leaves (leaf-settings curr-coll))
+ (nleaves (length leaves))
+ (lpairs nil))
+ (dotimes (irev nleaves lpairs)
+ (let* ((i (- (- nleaves 1) irev)) ; reverse order, then push
+ (ytop (nth i edges))
+ (ybottom (nth (+ i 1) edges))
+ (pair (nth i leaves))
+ (xleft (first pair))
+ (xright (second pair))
+ (open (and (> (- ytop ymin) end-tol)
+ (> (- ymax ybottom) end-tol)
+ (> xright xmin) (> xmax xleft)))
+ (xl (max xleft xmin))
+ (xr (min xright xmax))
+ (pair-o (nth i leaves-o))
+ (xleft-o (first pair-o))
+ (xright-o (second pair-o))
+ (open-o (and (> (- ytop ymin-o) end-tol)
+ (> (- ymax-o ybottom) end-tol)
+ (> xright-o xmin-o) (> xmax-o xleft-o)))
+ (xl-o (max xleft-o xmin-o))
+ (xr-o (min xright-o xmax-o)))
+ ;; (format t "open ~A open-o ~A xl ~A xl-o ~A xr ~A xr-o ~A~%"
+ ;; open open-o xl xl-o xr xr-o)
+ (push (make-lpair :open open :open-o open-o
+ :xl xl :xl-o xl-o :xr xr :xr-o xr-o)
+ lpairs)))))
+
+;;;-------------------------------------------------------------
+
+(defun collim-warnings (copy-coll curr-coll)
+
+ "collim-warnings copy-coll curr-coll
+
+Returns list of strings describing warnings about collimator in current beam,
+concerning differences going from first arg to second arg, or NIL if there
+are no user-provided changes."
+
+ ;; Both args are copied collimators in beams which are copies
+ ;; made from original beam in Prism plan - first is unmodified,
+ ;; while second may be modified by user.
+
+ ;; Message text uses Elekta coordinate systems and nomenclature, not Prism.
+
+ (let* ((end-tol 0.3)
+ (tol 0.3) ; edge of leaf or jaw tol
+ (min-field 2.0) ; warn if field is smaller in either dimension
+ (nleaves (length (leaf-settings curr-coll)))
+ (xmin-o (x1 copy-coll))
+ (xmax-o (x2 copy-coll))
+ (ymin-o (y1 copy-coll))
+ (ymax-o (y2 copy-coll))
+ (xmin (x1 curr-coll))
+ (xmax (x2 curr-coll))
+ (ymin (y1 curr-coll))
+ (ymax (y2 curr-coll))
+ (flagpole? (flag-diff copy-coll curr-coll))
+ (changed (and (not flagpole?)
+ (or (/= ymax ymax-o) (/= ymin ymin-o)
+ (/= xmax xmax-o) (/= xmin xmin-o))))
+ (shapes (shape-diff copy-coll curr-coll end-tol))
+ (nopen 0) ; number of exposed open leaves
+ (maxwidth 0.0) ; max leaf opening
+ (wl nil)) ; wl is warning list to return
+
+ ;; push warning messages in opposite order they will appear
+ (dotimes (irev nleaves)
+ (let* ((i (- (- nleaves 1) irev))
+ (lf (nth i shapes))
+ (open (lpair-open lf))
+ (xl (lpair-xl lf))
+ (xr (lpair-xr lf))
+ (xwidth (- xr xl))
+ (open-o (lpair-open-o lf))
+ (xl-o (lpair-xl-o lf))
+ (xr-o (lpair-xr-o lf)))
+
+ (if open (setf nopen (+ nopen 1)))
+ (if (and open (> xwidth maxwidth)) (setf maxwidth xwidth))
+
+ (cond
+ ((and open-o (not open))
+ (setf changed t)
+ (push (format nil "Leaf pair ~A changed from open to closed"
+ (+ i 1)) wl))
+ ((and (not open-o) open)
+ (setf changed t)
+ (push (format nil "Leaf pair ~A changed from closed to open"
+ (+ i 1)) wl))
+ ((and open-o open)
+ ;; two when's are not mutually exclusive
+ (when (> (abs (- xl-o xl)) tol)
+ (setf changed t)
+ (push
+ (format
+ nil "At leaf pair ~A, left edge changed from ~5,2F to ~5,2F"
+ (+ i 1) (- xl-o) (- xl))
+ wl))
+ (when (> (abs (- xr-o xr)) tol)
+ (setf changed t)
+ (push
+ (format
+ nil
+ "At leaf pair ~A, right edge changed from ~5,2F to ~5,2F"
+ (+ i 1) xr-o xr)
+ wl))))))
+
+ (unless flagpole?
+ (if (> (abs (- xmin xmin-o)) tol)
+ (push (format nil "Y2 changed from ~5,2F to ~5,2F"
+ (- xmin-o) (- xmin)) wl))
+ (if (> (abs (- xmax xmax-o)) tol)
+ (push (format nil "Y1 changed from ~5,2F to ~5,2F" xmax-o xmax) wl))
+ (if (> (abs (- ymin ymin-o)) tol)
+ (push (format nil "X2 changed from ~5,2F to ~5,2F"
+ (- ymin-o) (- ymin)) wl))
+ (if (> (abs (- ymax ymax-o)) tol)
+ (push (format nil "X1 changed from ~5,2F to ~5,2F" ymax-o ymax) wl)))
+
+ (if changed (push "Field shape has been changed from planned shape" wl))
+
+ (if (< maxwidth min-field)
+ (push (format nil "Field width (jaws and leaves) less than ~3,1F cm"
+ min-field)
+ wl))
+ (case nopen
+ (0 (push "No leaves open" wl))
+ (1 (push "Only one leaf open" wl))
+ (2 (push "Only two leaves open" wl)))
+ (if (< (- ymax ymin) min-field)
+ (push (format nil "X jaws open less than ~3,1F cm" min-field) wl))
+ (if (< (- xmax xmin) min-field)
+ (push (format nil "Y jaws open less than ~3,1F cm" min-field) wl))
+
+ (when flagpole?
+ (if (not changed) (push "prescribed field shape preserved" wl))
+ (push
+ (format nil "Adjusted jaws and leaves to meet Elekta constraints~A"
+ (if (not changed) "," ""))
+ wl))
+
+ wl))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/mlc-panels.cl b/prism/src/mlc-panels.cl
new file mode 100644
index 0000000..2f7e344
--- /dev/null
+++ b/prism/src/mlc-panels.cl
@@ -0,0 +1,644 @@
+;;;
+;;; mlc-panels
+;;;
+;;; The combined Prism multileaf collimator portal and leaf editing
+;;; panel and associated functions. Originally leaf-panels.
+;;;
+;;; 21-Jul-1994 J. Unger implement from spec.
+;;; 02-Aug-1994 J. Unger add code to accommodate var jaw colls.
+;;; 05-Aug-1994 J. Unger elim machine attr - determine from beam-for attr,
+;;; also elim typecases for cnts special cases (now handled more mlc case).
+;;; 08-Aug-1994 J. Unger take out code to update panel when new-coll-set
+;;; is announced. The code (and intent) is confusing.
+;;; 15-Aug-1994 J. Jacky 5,1 not 5,2 format for leaf setting textlines
+;;; SCX control software only goes to nearest millimeter!
+;;; 23-Aug-1994 J. Jacky Change centerline-list to edge-list
+;;; 23-Sep-1994 J. Unger make panel narrower to fit on 1024x768 screen; make
+;;; font smaller to suit. Also make slightly taller to
+;;; give more height to the SL20 textlines.
+;;; 28-Nov-1994 J. Unger destroy bev & leaf editor in leaf pnl destroy
+;;; method.
+;;; 13-Jan-1995 I. Kalet destroy textlines too. Change beam-for to
+;;; beam-of, add plan-of and patient-of for bev-draw-all.
+;;; 19-Sep-1996 I. Kalet update calls to bev-draw-all for new
+;;; signature.
+;;; 21-Jan-1997 I. Kalet eliminate table-position.
+;;; 29-Apr-1997 I. Kalet add name of beam to title bar of leaf panel.
+;;; 5-Jun-1997 I. Kalet machine returns object, not name.
+;;; 16-Jun-1997 I. Kalet change auto leaf adjustments when collimator
+;;; angle changes to be the Auto mode on the leaf editor. Move
+;;; parameters for sizes to init inst local variables. Manage Accept
+;;; button in new style (on if volatile data present).
+;;; 09-Jul-1997 BobGian added commentary about results of
+;;; compute-mlc-vertices returning a degenerate (zero-area) contours.
+;;; Leaf editor and/or update-mlc-contour-from-leaves must be fixed.
+;;; 14-Oct-1997 BobGian fix misspelling in comment.
+;;; 11-Jun-1998 I. Kalet change :beam to :beam-for in make-view call.
+;;; 23-Jun-1998 I. Kalet destroy bev after leaf-editor, since bev
+;;; pixmap is leaf editor background.
+;;; 25-Apr-1999 I. Kalet changes for multiple colormap support.
+;;; 14-Sep-1999 I. Kalet build from leaf panel and related stuff, move
+;;; get-mlc-vertices to mlc since it is used in charts and write-neutron.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 13-Dec-2000 I. Kalet add support for DRR background, including
+;;; Image button, window and level controls, and rearrange controls to
+;;; fit better.
+;;; 19-Jan-2005 I. Kalet change make-contour-editor to make-planar-editor
+;;; 19-May-2010 I. Kalet textlines return strings, so add conversion
+;;; to float before using format to write the info back to the leaf
+;;; setting textlines
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defclass mlc-panel (generic-panel)
+
+ ((fr :accessor fr
+ :documentation "The SLIK frame that contains the leaf panel.")
+
+ (delete-b :accessor delete-b
+ :documentation "The Delete Panel button.")
+
+ (beam-of :type beam
+ :accessor beam-of
+ :initarg :beam-of
+ :documentation "The beam for this leaf panel")
+
+ (plan-of :initarg :plan-of
+ :accessor plan-of
+ :documentation "The plan containing the beam.")
+
+ (patient-of :initarg :patient-of
+ :accessor patient-of
+ :documentation "The current patient.")
+
+ (filmdist :type single-float
+ :accessor filmdist
+ :initarg :filmdist
+ :documentation "The source to film distance when using
+simulator or port films on the digitizer. Forwarded from the
+containing collimator panel.")
+
+ (bev :type beams-eye-view
+ :accessor bev
+ :documentation "A beam's eye view, not displayed, but used as
+background for the display region.")
+
+ (image-mediator :accessor image-mediator
+ :initform nil
+ :documentation "A single image-view-mediator to
+manage creation of DRR images as necessary for the view background.")
+
+ (window-control :accessor window-control
+ :documentation "The textline that displays and sets
+the window for the background view's image.")
+
+ (level-control :accessor level-control
+ :documentation "The textline that displays and sets
+the level for the background view's image.")
+
+ (ce :type planar-editor
+ :accessor ce
+ :documentation "A contour/point editor, in which the bev
+ background is displayed. The point mode is not used.")
+
+ (rotate-mode-btn :accessor rotate-mode-btn
+ :documentation "The button that toggles either
+manual or automatic leaf setting as the collimator rotates.")
+
+ (set-leaves-btn :accessor set-leaves-btn
+ :documentation "The button for setting the leaves
+to a best fit to the current contour at the current collimator
+angle.")
+
+ (set-contour-btn :accessor set-contour-btn
+ :documentation "The button for setting the contour
+to match the leaf shapes at their current settings.")
+
+ (image-button :accessor image-button
+ :documentation "The button that toggles display of
+image data in this view.")
+
+ (fg-button :accessor fg-button
+ :documentation "Brings up a popup menu of objects in the
+view to display them or not on a view by view basis.")
+
+ (viewlist-panel :accessor viewlist-panel
+ :initform nil
+ :documentation "Temporarily holds the list of
+objects visible on the screen.")
+
+ (leaf-settings :type list
+ :accessor leaf-settings
+ :initform nil
+ :documentation "A list of x y pairs, each x and y
+being the setting for a left and right collimator leaf position at
+the same y-coord in collimator space.")
+
+ (left-leaf-tlns :type list
+ :accessor left-leaf-tlns
+ :initform nil
+ :documentation "A list of left leaf position textlines.")
+
+ (right-leaf-tlns :type list
+ :accessor right-leaf-tlns
+ :initform nil
+ :documentation "A list of right leaf position textlines.")
+
+ (busy :type (member t nil)
+ :accessor busy
+ :initform nil
+ :documentation "A busy flag to prevent the leaf editor's vertex
+list from updating in response to collimator changes that were themselves
+caused by updates to the vertex list.")
+
+ )
+
+ (:default-initargs :filmdist 100.0)
+
+ (:documentation "The mlc panel displays a view of the treatment
+volume from the beam source to isocenter, with portal editing facility
+and mlc leaves overlaid on top, and textlines for editing individual
+leaf positions on the sides of the panel.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod (setf filmdist) :after (newfd (pan mlc-panel))
+
+ (setf (digitizer-mag (ce pan))
+ (/ newfd (isodist (beam-of pan)))))
+
+;;;---------------------------------------------
+
+(defun update-mlc-editor (mlc-pan)
+
+ (let* ((bm (beam-of mlc-pan))
+ (coll (collimator bm))
+ (bev (bev mlc-pan))
+ (scale (scale bev))
+ (x0 (x-origin bev))
+ (y0 (y-origin bev))
+ (color (sl:color-gc *mlc-leaf-color*))
+ (prim (find coll (foreground bev) :key #'object))
+ (collim-info (collimator-info (machine bm)))
+ (xmax (leaf-open-limit collim-info))
+ (xmin (- xmax))
+ (edge-list (edge-list collim-info))
+ (angle (collimator-angle bm))
+ (leaf-pairs (mapcar
+ #'(lambda (yu yl x-pair)
+ (let ((left-leaf (pixel-contour
+ (poly:rotate-vertices
+ (counter-clockwise-rectangle
+ xmin yu (first x-pair) yl)
+ angle)
+ scale x0 y0))
+ (right-leaf (pixel-contour
+ (poly:rotate-vertices
+ (counter-clockwise-rectangle
+ (second x-pair) yu xmax yl)
+ angle)
+ scale x0 y0)))
+ (list (nconc left-leaf
+ (list (first left-leaf)
+ (second left-leaf)))
+ (nconc right-leaf
+ (list (first right-leaf)
+ (second right-leaf))))))
+ (butlast edge-list) (rest edge-list)
+ (leaf-settings mlc-pan))))
+ ;; maybe should also draw blocks of omitted beam?
+ (bev-draw-all bev (plan-of mlc-pan) (patient-of mlc-pan) bm)
+ ;; draw leaves
+ (setf (name coll) "MLC Leaves") ;; to appear in declutter menu
+ (unless prim
+ (setq prim (make-lines-prim nil color :object coll))
+ (push prim (foreground bev)))
+ (setf (color prim) color
+ (points prim) (apply #'append leaf-pairs))
+ (display-view bev)) ;; redraw the primitives into the pixmap
+ (display-planar-editor (ce mlc-pan)))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((mp mlc-panel) &rest initargs)
+
+ "Initializes the mlc panel gui."
+
+ (let* ((bm (beam-of mp))
+ (bev-size 768) ; Size of the bev
+ (btw 130) ; Width of leaf textlines
+ (left-x 5)
+ (ctl-btw (- btw (* 2 left-x))) ; Width of control buttons
+ (right-x (+ left-x btw bev-size))
+ (bth 25) ;; this and following are magic numbers - see planar-editor
+ (top-y 5)
+ (frm-height (+ bth 10 bev-size))
+ (frm (apply #'sl:make-frame (+ (* 2 btw) bev-size) frm-height
+ :title (format nil "Leaf and Portal Editor for ~A"
+ (name bm))
+ initargs))
+ (frm-win (sl:window frm))
+ (font (symbol-value *small-font*)))
+ (setf (fr mp) frm)
+ (setf (bev mp)
+ (make-view bev-size bev-size 'beams-eye-view :beam-for bm
+ :display-func #'(lambda (vw)
+ (setf (image-cache vw) nil)
+ (draw (image (image-mediator mp)) vw)
+ (display-view vw)
+ (display-planar-editor (ce mp)))))
+ (setf (ce mp) (apply #'make-planar-editor
+ :vertices (get-mlc-vertices bm)
+ :parent (sl:window (fr mp))
+ :background (sl:pixmap (picture (bev mp)))
+ :x-origin (round (/ bev-size 2))
+ :y-origin (round (/ bev-size 2))
+ :scale (scale (bev mp))
+ :digitizer-mag (/ (filmdist mp) (isodist bm))
+ :color (sl:color-gc (display-color bm))
+ :ulc-x btw :ulc-y 0
+ initargs))
+ (update-mlc-editor mp)
+ (setf (delete-b mp) (apply #'sl:make-button ctl-btw bth
+ :button-type :momentary
+ :font font :label "Delete Panel"
+ :parent frm-win
+ :ulc-x left-x :ulc-y top-y
+ initargs))
+ (setf (set-leaves-btn mp) (apply #'sl:make-button ctl-btw bth
+ :button-type :momentary
+ :font font :label "Set Leaves"
+ :parent frm-win
+ :ulc-x left-x
+ :ulc-y (bp-y top-y bth 1)
+ initargs))
+ (setf (set-contour-btn mp) (apply #'sl:make-button ctl-btw bth
+ :button-type :momentary
+ :font font :label "Set Contour"
+ :parent frm-win
+ :ulc-x left-x
+ :ulc-y (bp-y top-y bth 2)
+ initargs))
+ (setf (rotate-mode-btn mp) (apply #'sl:make-button ctl-btw bth
+ :font font :label "Auto Leaf"
+ :parent frm-win
+ :ulc-x left-x
+ :ulc-y (bp-y top-y bth 3)
+ initargs))
+ (setf (fg-button mp) (apply #'sl:make-button ctl-btw bth
+ :font font :label "Objects"
+ :parent frm-win
+ :ulc-x left-x
+ :ulc-y (bp-y top-y bth 4)
+ initargs))
+ (setf (image-button mp) (apply #'sl:make-button ctl-btw bth
+ :font font :label "Image"
+ :parent frm-win
+ :ulc-x right-x
+ :ulc-y top-y
+ initargs))
+ (setf (window-control mp)
+ (apply #'sl:make-sliderbox ctl-btw bth 1.0 2047.0 9999.0
+ :parent frm-win :font font :label "Win: "
+ :ulc-x (- right-x left-x) :ulc-y (bp-y top-y bth 1)
+ :border-width 0 :display-limits nil
+ initargs))
+ (setf (level-control mp)
+ (apply #'sl:make-sliderbox ctl-btw bth 1.0 4095.0 9999.0
+ :parent frm-win :font font :label "Lev: "
+ :ulc-x (- right-x left-x) :ulc-y (bp-y top-y bth 3)
+ :border-width 0 :display-limits nil
+ initargs))
+ ;; create and fill leaf textlines
+ (do* ((collim-info (collimator-info (machine (beam-of mp))))
+ (column-len (1- (length (edge-list collim-info))))
+ (height (truncate (/ (- frm-height (bp-y top-y bth 5))
+ column-len)))
+ (leaf-pairs (leaf-pair-map collim-info) (rest leaf-pairs))
+ (xl 0)
+ (xr (+ btw bev-size))
+ (y (bp-y top-y bth 5) (+ y height))
+ (i 0 (1+ i)))
+ ((= i column-len))
+ (push
+ (sl:make-textline btw height
+ :font font :parent frm-win
+ :ulc-x xl :ulc-y y
+ :numeric t
+ :lower-limit (- (leaf-open-limit collim-info))
+ :upper-limit (leaf-overcenter-limit collim-info)
+ :volatile-width 4
+ :label (format nil "LEAF ~2 at a: "
+ (first (first leaf-pairs))))
+ (left-leaf-tlns mp))
+ (push
+ (sl:make-textline btw height
+ :font font :parent frm-win
+ :ulc-x xr :ulc-y y
+ :numeric t
+ :lower-limit (- (leaf-overcenter-limit collim-info))
+ :upper-limit (leaf-open-limit collim-info)
+ :volatile-width 4
+ :label (format nil "LEAF ~2 at a: "
+ (second (first leaf-pairs))))
+ (right-leaf-tlns mp)))
+ (setf (left-leaf-tlns mp) (reverse (left-leaf-tlns mp)))
+ (setf (right-leaf-tlns mp) (reverse (right-leaf-tlns mp)))
+ (ev:add-notify mp (new-scale (ce mp))
+ #'(lambda (pan ed new-sc)
+ (declare (ignore ed))
+ (let ((bev (bev pan)))
+ (setf (scale bev) new-sc)
+ (update-mlc-editor pan))))
+ (ev:add-notify mp (new-origin (ce mp))
+ #'(lambda (pan ed new-org)
+ (declare (ignore ed))
+ (let ((bev (bev pan)))
+ (setf (origin bev) new-org)
+ (update-mlc-editor pan))))
+ (ev:add-notify mp (new-coll-angle bm)
+ #'(lambda (pan bem new-ang)
+ (declare (ignore bem new-ang))
+ ;; in manual mode we just rotate, but
+ ;; in auto mode we adjust the leaves too.
+ (if (sl:on (rotate-mode-btn pan))
+ (update-leaf-settings-from-portal pan))
+ (update-mlc-editor pan)))
+ (ev:add-notify mp (sl:button-on (delete-b mp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (destroy pan)))
+ (ev:add-notify mp (sl:button-on (set-leaves-btn mp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (update-leaf-settings-from-portal pan)
+ (update-mlc-editor pan)))
+ (ev:add-notify mp (sl:button-on (set-contour-btn mp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (update-mlc-contour-from-leaves pan)
+ (update-mlc-editor pan)))
+ (setf (image-button (bev mp)) (image-button mp))
+ (setf (drr-state (bev mp)) (drr-state (bev mp))) ;; to init the button
+ (ev:add-notify mp (sl:button-on (image-button mp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (bev pan)) t)
+ (update-mlc-editor pan)
+ (setf (busy pan) nil))))
+ (ev:add-notify mp (sl:button-off (image-button mp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (bev pan)) nil)
+ (update-mlc-editor pan)
+ (setf (busy pan) nil))))
+ (ev:add-notify mp (sl:button-2-on (image-button mp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (case (drr-state (bev pan))
+ ;;'stopped is a noop
+ ('running
+ (setf (drr-state (bev pan)) 'paused))
+ ('paused
+ (setf (drr-state (bev pan)) 'running)
+ (drr-bg (bev pan))))
+ (setf (busy pan) nil))))
+ (ev:add-notify mp (bg-toggled (bev mp))
+ #'(lambda (pan vw)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:on (image-button pan))
+ (background-displayed vw))
+ (setf (busy pan) nil))))
+ (ev:add-notify mp (sl:button-on (fg-button mp))
+ #'(lambda (pan bt)
+ (setf (viewlist-panel pan)
+ (make-instance 'viewlist-panel
+ :refresh-fn #'(lambda (vw)
+ (display-view vw)
+ (display-planar-editor
+ (ce pan)))
+ :view (bev pan)))
+ (ev:add-notify mp (deleted (viewlist-panel mp))
+ #'(lambda (pnl vlpnl)
+ (declare (ignore vlpnl))
+ (setf (viewlist-panel pnl) nil)
+ (when (not (busy pnl))
+ (setf (busy pnl) t)
+ (setf (sl:on bt) nil)
+ (setf (busy pnl) nil))))))
+ (ev:add-notify mp (sl:button-off (fg-button mp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (viewlist-panel pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify mp (new-vertices (ce mp))
+ #'(lambda (pan ed verts)
+ (declare (ignore ed))
+ (unless (busy pan)
+ (setf (busy pan) t)
+ (set-mlc-vertices (beam-of pan) verts)
+ (update-mlc-editor pan)
+ (setf (busy pan) nil))))
+ (ev:add-notify mp (new-coll-set (collimator bm))
+ #'(lambda (cp coll)
+ (declare (ignore coll))
+ (unless (busy cp)
+ (setf (busy cp) t)
+ (setf (vertices (ce cp))
+ (get-mlc-vertices bm))
+ (update-mlc-editor cp)
+ (setf (busy cp) nil))))
+ ;; leaf setting textlines
+ (do ((left-tlns (left-leaf-tlns mp) (rest left-tlns))
+ (right-tlns (right-leaf-tlns mp) (rest right-tlns)))
+ ((null left-tlns))
+ ;; the info from the textline is a STRING!
+ (ev:add-notify mp (sl:new-info (first left-tlns))
+ #'(lambda (pan tln info)
+ (let ((pos (position tln (left-leaf-tlns pan)))
+ (float-info (float (read-from-string info))))
+ (setf (sl:info tln)
+ (format nil "~5,1F" float-info))
+ (setf (first (nth pos (leaf-settings pan)))
+ float-info))
+ (update-mlc-editor pan)))
+ (ev:add-notify mp (sl:new-info (first right-tlns))
+ #'(lambda (pan tln info)
+ (let ((pos (position tln (right-leaf-tlns pan)))
+ (float-info (float (read-from-string info))))
+ (setf (sl:info tln)
+ (format nil "~5,1F" float-info))
+ (setf (second (nth pos (leaf-settings pan)))
+ float-info))
+ (update-mlc-editor pan))))
+ (setf (sl:setting (window-control mp))
+ (coerce (window (bev mp)) 'single-float))
+ (ev:add-notify mp (sl:value-changed (window-control mp))
+ #'(lambda (pan wc win)
+ (declare (ignore wc))
+ (setf (window (bev pan)) (round win))
+ (if (background-displayed (bev pan))
+ (display-planar-editor (ce pan)))))
+ (setf (sl:setting (level-control mp))
+ (coerce (level (bev mp)) 'single-float))
+ (ev:add-notify mp (sl:value-changed (level-control mp))
+ #'(lambda (pan lc lev)
+ (declare (ignore lc))
+ (setf (level (bev pan)) (round lev))
+ (if (background-displayed (bev pan))
+ (display-planar-editor (ce pan)))))
+ (if (image-set (patient-of mp))
+ (setf (image-mediator mp)
+ (make-image-view-mediator (image-set (patient-of mp)) (bev mp))))
+ ;; this is an abbreviated beam-view mediator for this view only
+ (ev:add-notify (bev mp) (new-gantry-angle bm) #'refresh-bev)
+ (ev:add-notify (bev mp) (new-couch-angle bm) #'refresh-bev)
+ (ev:add-notify (bev mp) (new-couch-lat bm) #'refresh-bev)
+ (ev:add-notify (bev mp) (new-couch-ht bm) #'refresh-bev)
+ (ev:add-notify (bev mp) (new-couch-long bm) #'refresh-bev)
+ (ev:add-notify (bev mp) (new-machine bm) #'refresh-bev)
+ (update-leaf-settings-from-portal mp)
+ (update-mlc-editor mp)))
+
+;;;---------------------------------------------
+
+(defun set-mlc-vertices (bm verts)
+
+ "set-mlc-vertices bm verts
+
+For beams with a collimator of type multileaf-coll, assigns the verts
+parameter to the collimator's vertices attribute. For beams with a
+collimator of type cnts-coll, calls compute-vj-block to get new
+collimator settings and a C-shaped block, then sets the collimator
+jaws to the returned collim settings and and replaces any blocks with
+the C-shaped block. Does nothing for any other type of collimator."
+
+ (let ((coll (collimator bm)))
+ (typecase coll
+ (multileaf-coll (setf (vertices coll) verts))
+ (cnts-coll
+ (let* ((col-blk (compute-vj-block
+ (poly:rotate-vertices
+ verts (- (collimator-angle bm)))))
+ (new-coll (first col-blk))
+ (new-blk (make-beam-block "Computed C block"
+ :vertices (second col-blk))))
+ (setf (x-inf coll) (x-inf new-coll)
+ (y-inf coll) (y-inf new-coll)
+ (x-sup coll) (x-sup new-coll)
+ (y-sup coll) (y-sup new-coll))
+ (dolist (old-blk (coll:elements (blocks bm)))
+ (coll:delete-element old-blk (blocks bm)))
+ (coll:insert-element new-blk (blocks bm))))
+ (t nil))))
+
+;;;---------------------------------------------
+
+(defun update-mlc-contour-from-leaves (mp)
+
+ "update-mlc-contour-from-leaves mp
+
+Updates the contour of the mlc panel from the panel's leaf-settings."
+
+ (let ((b (beam-of mp)))
+ ;;
+ ;; Need to do something here (or rewiring of leaf editor) so that
+ ;; if compute-mlc-vertices returns nil (a degenerate contour) we
+ ;; don't propagate that bad data throughout system.
+ ;;
+ ;; At minimum, don't setf vertices to bad data.
+ ;; Probably also warn user and turn button back on too.
+ ;;
+ (setf (vertices (ce mp))
+ (compute-mlc-vertices (collimator-angle b)
+ (leaf-settings mp)
+ (edge-list (collimator-info (machine b)))))
+ (unless (sl:on (accept-btn (ce mp)))
+ (setf (sl:on (accept-btn (ce mp))) t))))
+
+;;;---------------------------------------------
+
+(defun update-leaf-settings-from-portal (mp)
+
+ "update-leaf-settings-from-portal mp
+
+Updates the leaf settings and textlines using the collimator portal
+vertices."
+
+ (let* ((b (beam-of mp)))
+ (setf (leaf-settings mp)
+ (compute-mlc (collimator-angle b)
+ (vertices (ce mp))
+ (edge-list (collimator-info (machine b)))))
+ ;; update the leaf textlines
+ (mapc #'(lambda (pair l-tln r-tln)
+ (setf (sl:info l-tln) (format nil "~5,1F" (first pair)))
+ (setf (sl:info r-tln) (format nil "~5,1F" (second pair))))
+ (leaf-settings mp)
+ (left-leaf-tlns mp)
+ (right-leaf-tlns mp))))
+
+;;;---------------------------------------------
+
+(defun make-mlc-panel (&rest initargs)
+
+ "make-mlc-panel &rest initargs
+
+Creates and returns a leaf panel with the specified initialization args."
+
+ (apply #'make-instance 'mlc-panel initargs))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((mp mlc-panel))
+
+ "Unmap the panel's frame and unregisters w/ external events."
+
+ (let ((vw (bev mp))
+ (bm (beam-of mp)))
+ ;; ensure that there are not any lingering
+ ;; background jobs for this view-panel
+ (remove-bg-drr vw)
+ (when (eq 'running (drr-state vw))
+ (setf (drr-state vw) 'paused))
+ (setf (image-button vw) nil)
+ (ev:remove-notify vw (new-gantry-angle bm))
+ (ev:remove-notify vw (new-couch-angle bm))
+ (ev:remove-notify vw (new-couch-lat bm))
+ (ev:remove-notify vw (new-couch-ht bm))
+ (ev:remove-notify vw (new-couch-long bm))
+ (ev:remove-notify vw (new-machine bm))
+ (ev:remove-notify mp (new-coll-angle bm))
+ (ev:remove-notify mp (new-coll-set (collimator bm)))
+ (if (image-mediator mp) (destroy (image-mediator mp)))
+ (destroy vw))
+ (destroy (ce mp))
+ (sl:destroy (delete-b mp))
+ (sl:destroy (set-leaves-btn mp))
+ (sl:destroy (set-contour-btn mp))
+ (sl:destroy (rotate-mode-btn mp))
+ (sl:destroy (image-button mp))
+ (sl:destroy (window-control mp))
+ (sl:destroy (level-control mp))
+ (if (sl:on (fg-button mp)) (setf (sl:on (fg-button mp)) nil))
+ (sl:destroy (fg-button mp))
+ (dolist (tl (left-leaf-tlns mp)) (sl:destroy tl))
+ (dolist (tl (right-leaf-tlns mp)) (sl:destroy tl))
+ (sl:destroy (fr mp)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/mlc.cl b/prism/src/mlc.cl
new file mode 100644
index 0000000..70a96a0
--- /dev/null
+++ b/prism/src/mlc.cl
@@ -0,0 +1,386 @@
+;;;
+;;; mlc.cl
+;;;
+;;; Functions for working with multileaf collimators
+;;;
+;;; 22-Jul-1994 J. Jacky Complete compute-mlc, compute-mlc-vertices + support
+;;; 26-Jul-1994 J. Unger modify set-leaf-pair slightly to avoid wierd bug.
+;;; 27-Jul-1994 J. Jacky Complete compute-vj-block-vertices
+;;; 29-Jul-1994 J. Jacky Complete compute-vj-block, fiddle with coincidences
+;;; 1-Aug-1994 J. Jacky compute-mlc-vertices: strip closed leaves,
+;;; redund pts
+;;; 07-Aug-1994 J. Unger change name of remove-repeats (now in poly pkg and
+;;; is called remove-adjacent-redundant-vertices). Also add postprocessing
+;;; to compute-vj-block-vertices and compute-vj-block to clean up returned
+;;; vertex lists some.
+;;; 12-Aug-1994 J. Jacky fix compute-step-ys for 0, 1 or 2 open leaf pairs
+;;; 15-Aug-1994 J. Jacky fix error computing last leaf step in
+;;; compute-step-ys
+;;; 23-Aug-1994 J. Jacky delete hopeless compute-step-ys, add find-centers
+;;; replace centerline-list with edge-list throughout
+;;; 28-Oct-1994 J. Unger add some contour cleanup code to compute-mlc-verts
+;;; 15-Nov-1994 J. Jacky Fix bug where it back-computed portal contour
+;;; did not match leaf settings typed in by user, due to make-notch
+;;; placing notch at interior side of concave portal (for example
+;;; against a midline block). make-notch now chooses shallowest
+;;; connector of all -- changed make-notch and most. Fortuitously
+;;; this change also helps prevent leaves assigned by system from
+;;; "creeping" 1 mm from values typed in by user *even without*
+;;; contemplated decrease of dj,dn in compute-vj-block.
+;;; 17-Nov-1994 J. Jacky ...but not always. Today in compute-vj-block
+;;; change dj, dn from 0.1, 0.05 to 0.03, 0.01
+;;; 24-Jan-1997 I. Kalet portal function now returns just the
+;;; vertices.
+;;; 1-Mar-1997 I. Kalet update calls to nearly- functions
+;;; 03-Jul-1997 BobGian updated nearly-xxx -> poly:nearly-xxx .
+;;; 07-Jul-1997 BobGian mlc-post-process -> poly:canonical-contour
+;;; (same functionality, but is a utility in polygons system).
+;;; 09-Jul-1997 BobGian added commentary about results of processing
+;;; degenerate (zero-area) contours.
+;;; 2-Oct-1997 BobGian tighten coding of compute-mlc-vertices. Sprinkle
+;;; debugging code around. Bug fixed, debug code removed 7-Oct-1997.
+;;; 14-Oct-1997 BobGian comment vertex-list-difference's assumptions about
+;;; orientation guarantees on its input contours [namely, none].
+;;; 5-Sep-1999 I. Kalet move get-mlc-vertices here from mlc-panels,
+;;; formerly leaf-panels. Used in charts and write-neutron also.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defun get-mlc-vertices (bm)
+
+ "get-mlc-vertices bm
+
+For beams with a collimator of type multileaf-coll, returns the
+vertices attribute of the collimator. For beams with a collimator of
+type cnts-coll, calls compute-vj-block-vertices to get a collimator
+outline computed from the collim jaws minus the blocks. Returns nil
+for any other type of collimator."
+
+ (let ((coll (collimator bm)))
+ (typecase coll
+ (multileaf-coll (vertices coll))
+ (cnts-coll (poly:rotate-vertices
+ (compute-vj-block-vertices
+ coll (coll:elements (blocks bm)))
+ (collimator-angle bm)))
+ (t nil))))
+
+;;;--------------------------------------------------
+
+(defun compute-mlc (collimator-angle vertices edge-list)
+
+ "compute-mlc collimator-angle vertices edge-list
+
+Returns leaf-settings for leaves defined by edge-list that match
+portal shape (in gantry system) defined by vertices when collimator is
+rotated to collimator-angle."
+
+ (let ((centerline-list (find-centers edge-list))
+ (r-vertices (poly:rotate-vertices vertices (- collimator-angle))))
+ (mapcar #'(lambda (centerline) (set-leaf-pair centerline r-vertices))
+ centerline-list)))
+
+;;;------------------------------
+
+(defun find-centers (edge-list)
+
+ "find-centers edge-list
+
+Return list of n centers defined by n+1 edges in edge-list"
+
+ (let ((lower-edge-list (rest edge-list)))
+ (mapcar #'(lambda (yu yl) (/ (+ yu yl) 2.0))
+ edge-list lower-edge-list)))
+
+;;;------------------------------
+
+(defun set-leaf-pair (y vertices)
+
+ "set-leaf-pair y vertices
+
+Returns list of two x-coords: lower, upper leaf settings at y coord
+that touch opposite sides of polygon defined by vertices."
+
+;; NOTE: If the (list 0.0 0.0) below is replaced with '(0.0 0.0), then
+;; strange results sometimes occur when the function is evaluated.
+;; In particular, the function seems to return the wrong clause of
+;; the 'if' form if xs is nil.
+
+ (let ((xs (crossings y vertices)))
+ (if (null xs) (list 0.0 0.0)
+ (list (apply #'min xs) (apply #'max xs)))))
+
+;;;------------------------------
+
+(defun crossings (y vertices)
+
+ "crossings y vertices
+
+Returns list of x-coords where polygon defined by vertices crosses y
+coord."
+
+ ;; Tried mapcan but got only NIL back, so did (remove nil ...)
+ ;; instead
+ (remove nil (mapcar #'(lambda (seg) (cross-x y seg))
+ (segments vertices))))
+
+;;;------------------------------
+
+(defun segments (vertices)
+
+ "segments vertices
+
+For list of (xi yi) vertices, returns list of ((xi yi) (xi+1 yi+1))
+segments."
+
+ ;; cons because we have to make a special case of the closing segment
+ (cons (list (car (last vertices)) ; (last xs) is (x) not x
+ (first vertices))
+ (mapcar #'(lambda (x y) (list x y)) vertices (cdr vertices))))
+
+;;;------------------------------
+
+(defun cross-x (y seg)
+
+ "cross-x y seg
+
+Returns x coordinate where y crosses seg ((x1 y1) (x2 y2)), or NIL if
+no crossing."
+
+ ;; handling this special case here is easier than using stuff in
+ ;; polys
+
+ (let* ((seg1 (first seg)) (seg2 (second seg))
+ (y1 (second seg1)) (y2 (second seg2)))
+ (if (or (<= y1 y y2) (>= y1 y y2)) ; crossing found
+ (let ((x1 (first seg1)) (x2 (first seg2))
+ (fr (if (poly:nearly-equal y1 y2)
+ 0.0
+ (/ (- y y1) (- y2 y1)))))
+ (+ x1 (* fr (- x2 x1)))) ; linear interpolation
+ nil)))
+
+;;;------------------------------
+
+(defun compute-mlc-vertices (collimator-angle leaf-settings edge-list)
+
+ "compute-mlc-vertices collimator-angle leaf-settings edge-list
+
+Returns vertices of portal shape (in gantry system) formed by
+leaf-settings and edge-list rotated to collimator-angle.
+Returns nil for degenerate (zero-area) portal contour."
+
+ (let* ((open-field (remove-closed-ends leaf-settings edge-list))
+ (open-leaves (first open-field))
+ (open-edges (second open-field)))
+ (poly:rotate-vertices
+ ;; strip out any duplicate vertices at adjacent leaf corners
+ (poly:canonical-contour ; trace down lower X side, then up
+ (append
+ (compute-steps (mapcar #'first open-leaves) open-edges)
+ (reverse (compute-steps (mapcar #'second open-leaves) open-edges))))
+ collimator-angle)))
+
+;;;--------------------------------
+
+(defun remove-closed-ends (leaf-settings edge-list)
+
+ "remove-closed-ends leaf-settings edge-list
+
+Returns a list of two lists: new leaf-settings and edge-list. They
+are like the input except without the entries for leaves at the +y and
+-y ends of the field that leaf-settings indicates are closed. Entries
+remain for any interior closed leaves, like midline blocks."
+
+ (let ((frontless (remove-closed-front leaf-settings edge-list)))
+ (mapcar #'reverse
+ (apply #'remove-closed-front
+ (mapcar #'reverse frontless)))))
+
+;;;--------------------------------
+
+(defun remove-closed-front (leaf-settings edge-list)
+
+ "remove-closed-front leaf-settings edge-list
+
+Half of remove-closed-ends --- remove closed leaves from front of
+list."
+
+ (let* ((first-leaf-pair (first leaf-settings))
+ (xl (first first-leaf-pair)) ; lower leaf setting
+ (xu (second first-leaf-pair))) ; upper leaf setting
+ (if (< xl xu) ; if first leaf pair is open,
+ (list leaf-settings edge-list) ; return
+ (remove-closed-front (rest leaf-settings) (rest edge-list)))))
+
+;;;----------------------------------
+
+(defun compute-steps (xs edge-ys)
+
+ "compute-steps xs ys
+
+Return stepped polyline defined by list of x-coords xs and y-coords
+edge-ys."
+
+ (let* ((l-edge-ys (rest edge-ys)) ; edge-ys must have one more
+ ; elt than xs
+ (steps (mapcar #'(lambda (x yu yl)
+ (list (list x yu) (list x yl)))
+ xs edge-ys l-edge-ys))) ; each step has 1 x
+ ; but 2 y's
+ (apply #'append steps))) ; flatten out top level of lists
+
+;;;----------------------------------
+
+(defun compute-vj-block-vertices (vj-coll blocks)
+
+ "compute-vj-block-vertices vj-coll blocks
+
+Returns vertices of the portal shape in the collimator system formed
+by the four independent jaws of vj-coll and the list (not collection)
+of blocks (instances of beam-block)."
+
+ (let ((portal-vs (portal vj-coll)))
+ ;; Subtract all block contours, and then post process
+ ;; NB: Returns nil if portal-vs contains a degenerate portal
+ ;; contour (zero area) - this should never happen.
+ (dolist (blk blocks (poly:canonical-contour portal-vs))
+ ;; vertex-list-difference returns a list of lists. It also makes
+ ;; NO assumptions about orientation of input contours, by virtue
+ ;; of non-supplied optional 4th argument.
+ (setq portal-vs
+ (first (poly:vertex-list-difference portal-vs
+ (vertices blk)))))))
+
+;;;------------------------------------
+
+(defun compute-vj-block (c-vertices)
+
+ "compute-vj-block c-vertices
+
+Returns a list of two items: first, a variable-jaw-coll, and second, a
+list of vertices that define the shape of a single C-shaped block,
+that together match the interior portal shape defined by c-vertices."
+
+ ;; Adjusting the collimator settings and notch cutout by dj and dn
+ ;; are *essential* parts of this routine! They are necessary because
+ ;; the vertex-list-difference routine *cannot* handle situations
+ ;; where vertices or segments in the two contours are coincident
+ ;; (vertices coincide, or pieces of segments coincide, or a vertex
+ ;; from one one lands exactly on a segment from the other). If
+ ;; coincidences are present, the routine sometimes crashes, hangs, or
+ ;; returns garbage --- either here in compute-vj-block, or later when
+ ;; we pass the results of this routine to compute-vj-block-vertices.
+ ;; Our inelegant solution is to simply perturb the computed contours
+ ;; by dj and dn to ensure they will not coincide. It is essential
+ ;; that dj and dn be *different* from each other. Initially I chose
+ ;; dj=0.1 (1 mm) and dn=0.05; smaller numbers might work as well.
+
+ (let* ((box (poly:bounding-box c-vertices))
+ (llc (first box)) (llc-x (first llc)) (llc-y (second llc))
+ (urc (second box)) (urc-x (first urc)) (urc-y (second urc))
+ (dj 0.03) ; expand jaws to avoid coincidences
+ (dn 0.01) ; expand notch, but different amount
+ (margin 1.0) ; width of C-block
+ (vj-coll (make-instance 'variable-jaw-coll
+ :x-inf (- (- llc-x dj))
+ :y-inf (- (- llc-y dj))
+ :x-sup (+ urc-x dj)
+ :y-sup (+ urc-y dj)))
+ (c-blk (let* ((vj-portal (list (list llc-x llc-y)
+ (list llc-x urc-y)
+ (list urc-x urc-y)
+ (list urc-x llc-y)))
+ (border (poly:ortho-expand-contour vj-portal margin))
+ ;; Make our own notch because cut annulus calc'ed
+ ;; by vertex-list-difference not quite right
+ ;; and crashes.
+ (notch (make-notch border c-vertices))
+ ;; If we don't expand notch in both directions,
+ ;; vertex-list-difference returns nil.
+ (bigger-notch (poly:ortho-expand-contour notch dn))
+ (notched-border (first (poly:vertex-list-difference
+ border bigger-notch))))
+ (first (poly:vertex-list-difference notched-border
+ c-vertices)))))
+ ;; Note that vertex-list-difference in both usages above makes no
+ ;; assumptions about orientation of its input contours [due to optional
+ ;; fourth argument defaulting to nil].
+ ;; NB: poly:canonical-contour returns nil if c-blk contains a
+ ;; degenerate portal contour (zero area) - this should never happen.
+ (list vj-coll (poly:canonical-contour c-blk))))
+
+;;;--------------------------------------
+
+(defun make-notch (border interior)
+
+ "make-notch border interior
+
+Given two vertex lists, where border is a rectangle parallel to the
+axes that completely encloses interior, return the vertex list of the
+shallowest quadrilateral notch connecting an entire interior segment
+with the border."
+
+ (let* ((connectors ; list of lists of connectors
+ (mapcar #'(lambda (seg) ; outer level is one list per
+ ; interior seg
+ (mapcar #'(lambda (side)
+ (make-connector seg side))
+ (segments border))) ; inner level is one
+ (segments interior))) ; connector per border seg
+ (shallow-connectors (mapcar #'(lambda (side) (most '< side))
+ connectors))) ; return list of
+ ; shallow connectors
+ (caddr (most '< shallow-connectors)))) ; dig out shallowest
+ ; connector from list created
+ ; by make-connector
+
+;;;-----------------------------------------
+
+(defun most (r ls)
+
+ "most r ls
+
+Return element of list-of-lists ls whose car is ``most'' according to
+binary relation predicate r. For example If r is <, most is
+smallest."
+
+ ;; very un-functional - is there a Lisp-ier way?
+ (let ((er (first ls)))
+ (dolist (e (rest ls) er)
+ (if (funcall r (first e) (first er))
+ (setq er e)))))
+
+;;;-----------------------------------------
+
+(defun make-connector (shortseg longseg)
+
+ "make-connector shortseg longseg
+
+Make trapezoidal vertex list where one side is shortseg and the
+opposide side is the projection of shortseg on longseg. Longseg must
+be parallel to one of the coordinate axes and shortseg's projection
+must fit within longseg."
+
+;;; Returns a list: first element is depth of connector, second is its
+;;; length, third and last element is connector itself. It's easiest
+;;; to do all this boring brute force arithmetic in one place.
+
+ (let* ((s1 (first shortseg)) (s1x (first s1)) (s1y (second s1))
+ (s2 (second shortseg)) (s2x (first s2)) (s2y (second s2))
+ (l1 (first longseg)) (l1x (first l1)) (l1y (second l1))
+ (l2 (second longseg)) (l2y (second l2))) ; l2x never needed
+ (if (poly:nearly-equal l1y l2y 0.01)
+ ;; longseg parallel to x-axis
+ (list (max (abs (- s1y l1y)) (abs (- s2y l1y))) ; depth
+ (abs (- s1x s2x)) ; length
+ (list s1 (list s1x l1y) (list s2x l1y) s2)) ; connector itself
+ ;; longseg parallel to y-axis
+ (list (max (abs (- s1x l1x)) (abs (- s2x l1x))) ; depth
+ (abs (- s1y s2y)) ; length
+ (list s1 (list l1x s1y) (list l1x s2y) s2))))) ; connector itself
+
+;;;------------------------------
diff --git a/prism/src/object-manager.cl b/prism/src/object-manager.cl
new file mode 100644
index 0000000..84f0c7e
--- /dev/null
+++ b/prism/src/object-manager.cl
@@ -0,0 +1,239 @@
+;;;
+;;; object-manager
+;;;
+;;; This is the code that supports the maintenance of consistency
+;;; between objects and the views they appear in, while the object
+;;; attributes change, the view parameters change, and objects and
+;;; views are created and destroyed.
+;;;
+;;; To use this you must provide a mediator definition, and a mediator
+;;; constructor function. The constructor function takes exactly two
+;;; parameters, an object and a view. It returns a mediator for that
+;;; pair. The mediator must have a function named object that returns
+;;; the object for the mediator, and a function named view that
+;;; returns the view for that mediator.
+;;;
+;;; 20-Oct-1992 I. Kalet created from paper sketch
+;;; 02-Dec-1992 J. Unger modify object-refresh to pass params down to
+;;; draw and to always get both object and view from mediator. Also
+;;; add flush output to object-refresh.
+;;; 13-Dec-1992 J. Unger remove (sl:flush-output) from object-refresh.
+;;; 31-Dec-1992 I. Kalet reorganize order of forms
+;;; 11-Apr-1993 I. Kalet make object-refresh a lambda - not needed
+;;; elsewhere. Also add remove-notify to complement add-notify
+;;; 15-Apr-1993 I. Kalet make update-view use the object in the
+;;; mediator, not the object making the announcement.
+;;; 23-Jul-1993 I. Kalet add code to object-view-manager initialize
+;;; method so that views appear with graphics already displayed.
+;;; 18-Oct-1993 I. Kalet add code to object-view-mediator destroy
+;;; method to remove graphic primitive of deleted object.
+;;; 12-Jan-1995 I. Kalet destroy view when deleted from view set. Do
+;;; it here rather than in plans because it is the mediator's job
+;;; since the mediator can control the order of things (destroy the
+;;; mediator before destroying the view).
+;;; 5-Mar-1995 I. Kalet add destroy method for object-view-manager.
+;;; Move display-view call from mediator destroy method to action
+;;; function for object deleted. Don't call it for view deleted.
+;;; This then allows the view to be destroyed when it is deleted.
+;;; 25-Jul-1995 I. Kalet almost right, but not quite. The beam's eye
+;;; view mediator deletes the beam's eye view, so cannot call
+;;; display-view. So check if it is still in the view set before
+;;; calling display-view, on object deleted.
+;;; 8-Oct-1996 I. Kalet change calls to draw to conform to new
+;;; signature without keywords or &rest and change update-view to
+;;; generic function.
+;;;
+
+(in-package :prism)
+
+;;;-------------------------------------
+
+(defclass object-view-mediator ()
+
+ ((object :reader object
+ :initarg :object
+ :documentation "The object this mediator manages views
+for.")
+
+ (view :reader view
+ :initarg :view
+ :documentation "The view in which this object may appear.")
+
+ )
+
+ (:documentation "This is the generic object-view-mediator class")
+
+ )
+
+;;;-------------------------------------
+
+(defmethod initialize-instance :after ((ovm object-view-mediator)
+ &rest initargs)
+
+ "Initially draws the object in the view, and registers to regenerate
+the graphic primitives of the object in the view when refresh-fg is
+announced. This might be supplemented and/or replaced in some more
+specialized mediators."
+
+ (declare (ignore initargs))
+ (ev:add-notify ovm (refresh-fg (view ovm))
+ #'(lambda (med vw) (draw (object med) vw)))
+ (draw (object ovm) (view ovm))
+ )
+
+;;;-------------------------------------
+
+(defmethod destroy ((ovm object-view-mediator))
+
+ (let ((obj (object ovm))
+ (vw (view ovm)))
+ (ev:remove-notify ovm (refresh-fg vw))
+ (setf (foreground vw) (remove obj (foreground vw) :key #'object))
+ ))
+
+;;;-------------------------------------
+
+(defclass object-view-manager ()
+
+ ((object-set :accessor object-set
+ :initarg :object-set
+ :initform (coll:make-collection)
+ :documentation "The set of objects that are to appear
+in the views. Usually provided by initialization arguments, as it is
+already part of some container object, e.g., the organ set is a part
+of a patient, a set of beams is a part of a plan, etc.")
+
+ (view-set :accessor view-set
+ :initarg :view-set
+ :initform (coll:make-collection)
+ :documentation "The set of views for some plan. Usually
+provided by an initialization argument when a plan is created.")
+
+ (mediator-set :accessor mediator-set
+ :initform (coll:make-collection)
+ :documentation "The set of object-view mediators.
+Each one handles updates of a particular view for a particular object.
+They are created when either an object or a view is created and added
+to the above sets. They are deleted when an object or view is
+deleted.")
+
+ )
+
+ (:documentation "This is the object that creates and deletes the
+mediators for any given set of objects to appear in a given set of
+views.")
+
+ )
+
+;;;-------------------------------------
+
+(defmethod initialize-instance :after ((m object-view-manager)
+ &key mediator-fn
+ &allow-other-keys)
+
+ "Fills the mediator set by iterating over objects and views, and
+creates the links to dynamically create and delete mediators as
+necessary when objects and views are created and deleted."
+
+ (let ((os (object-set m))
+ (vs (view-set m))
+ )
+ (dolist (obj (coll:elements os))
+ (dolist (v (coll:elements vs))
+ (coll:insert-element (funcall mediator-fn obj v)
+ (mediator-set m))))
+ (ev:add-notify m (coll:inserted os)
+ #'(lambda (md obj-set obj)
+ (declare (ignore obj-set))
+ (dolist (v (coll:elements (view-set md)))
+ (coll:insert-element (funcall mediator-fn obj v)
+ (mediator-set md))
+ (display-view v))))
+ (ev:add-notify m (coll:inserted vs)
+ #'(lambda (md obj-set v)
+ (declare (ignore obj-set))
+ (dolist (obj (coll:elements (object-set md)))
+ (coll:insert-element
+ (funcall mediator-fn obj v)
+ (mediator-set md)))
+ (display-view v)
+ ))
+ (ev:add-notify m (coll:deleted os)
+ #'(lambda (md obj-set obj)
+ (declare (ignore obj-set))
+ (let ((med-set (mediator-set md)))
+ (dolist (med (coll:elements med-set))
+ (when (eq (object med) obj)
+ (let ((vw (view med)))
+ (coll:delete-element med med-set)
+ (destroy med)
+ (when (coll:collection-member vw vs)
+ (display-view vw)))
+ ))
+ )))
+ (ev:add-notify m (coll:deleted vs)
+ #'(lambda (md obj-set v)
+ (declare (ignore obj-set))
+ (let ((med-set (mediator-set md)))
+ (dolist (med (coll:elements med-set))
+ (when (eq (view med) v)
+ (coll:delete-element med med-set)
+ (destroy med)
+ ))
+ )))
+ ))
+
+;;;-------------------------------------
+
+(defun make-object-view-manager (object-set view-set
+ mediator-function)
+
+ "MAKE-OBJECT-VIEW-MANAGER object-set view-set mediator-function
+
+returns an instance of an object-view-manager, a mediator between a
+set of objects and a set of views they appear in. The mediator
+function is a function that creates a mediator between an object and a
+view, given the object and the view."
+
+ (make-instance 'object-view-manager :object-set object-set
+ :view-set view-set :mediator-fn mediator-function)
+ )
+
+;;;-------------------------------------
+
+(defmethod destroy ((ovm object-view-manager))
+
+ (let ((os (object-set ovm))
+ (vs (view-set ovm))
+ )
+ (dolist (med (coll:elements (mediator-set ovm))) (destroy med))
+ (ev:remove-notify ovm (coll:inserted os))
+ (ev:remove-notify ovm (coll:inserted vs))
+ (ev:remove-notify ovm (coll:deleted os))
+ (ev:remove-notify ovm (coll:deleted vs))
+ ))
+
+;;;-------------------------------------
+
+(defmethod update-view ((med object-view-mediator) obj &rest pars)
+
+ "produces a new graphic primitive for the object and view connected
+by object-view-mediator med. Used to redraw a single object that has
+changed."
+
+ (declare (ignore obj pars))
+ (draw (object med) (view med)))
+
+;;;-------------------------------------
+
+(defmethod update-view :around ((med object-view-mediator) obj
+ &rest pars)
+
+ "displays the view after the primary method and all the before and
+after methods are called."
+
+ (declare (ignore obj pars))
+ (call-next-method)
+ (display-view (view med)))
+
+;;;-------------------------------------
diff --git a/prism/src/output-factors.cl b/prism/src/output-factors.cl
new file mode 100644
index 0000000..c0a6691
--- /dev/null
+++ b/prism/src/output-factors.cl
@@ -0,0 +1,404 @@
+;;;
+;;; output-factors
+;;;
+;;; Contains functions related to output-factor and its inverse lookup.
+;;;
+;;; 13-Mar-1998 BobGian created from excess material in beam-dose.
+;;; 22-May-1998 BobGian inline inverse outputfactor lookup using
+;;; binary/linear search in INV-OUTPUTFACTOR (MULTILEAF-COLL method).
+;;; 11-Jun-1998 BobGian Bug fix - raise threshold for degenerate sector
+;;; in MLC output factor sector integration.
+;;; 26-Jun-1998 BobGian tighten code in INV-OUTPUTFACTOR method for
+;;; MULTILEAF-COLL (improves binary and sequential search).
+;;; 03-Feb-2000 BobGian cosmetic fixes (case regularization).
+;;; 08-Feb-2000 BobGian more cosmetic cleanup.
+;;; 02-Mar-2000 BobGian add declarations in OUTPUTFACTOR-COL (for MLC).
+;;; 29-Jun-2000 BobGian cosmetics - comments, whitespace.
+;;; 30-Aug-2000 BobGian MYATAN -> FAST-ATAN.
+;;; 30-May-2001 BobGian (part of upgrade to electron dosecalc):
+;;; Wrap generic arithmetic with THE-declared types.
+;;; Change a few local var names to not conflict with generic fcn names.
+;;; Cleaner return from sector-integration routine in MLC outputfactor.
+;;; 03-Jan-2003 BobGian:
+;;; Flush macro FAST-ATAN - not accurate enough.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 31-Jan-2005 AMSimms - corrected use of Allegro specific coercions, now
+;;; using coerce explicitly.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defmethod outputfactor-col ((coll collimator) wc dosedata)
+
+ "The RECTANGULAR collimator method for Output-Factor."
+
+ (declare (type single-float wc))
+
+ (the single-float
+ (1d-lookup (outputfactor-vector dosedata) ;Outputfactor Lookup.
+ wc
+ (outputfactor-fieldsizes dosedata)
+ (outputfactor-fss-mapper dosedata)
+ (outputfactor-table dosedata))))
+
+;;;-------------------------------------------------------------
+
+(defmethod outputfactor-col ((coll multileaf-coll) wc dosedata)
+
+ "The MULTILEAF collimator method for Output-Factor."
+
+ ;; NB: ALL computations done in this method are done as projected onto
+ ;; the ISOCENTER plane. Area computation and sector integration are
+ ;; orientation-independent - CW or CCW both OK.
+ (declare (type single-float wc)
+ (ignore wc))
+
+ (let ((vert-list (vertices coll))
+ (area-component 0.0) ;Accumulating area
+ (integrated-component 0.0) ;Clarkson-like integration result
+ (outputfactor-min-diam (of-min-diam dosedata))
+ (portal-coeff (portal-area-coeff dosedata))
+ (of-vector (outputfactor-vector dosedata))
+ (of-fssmap (outputfactor-fss-mapper dosedata))
+ (outfactor-fieldsizes (outputfactor-fieldsizes dosedata))
+ (outfactor-table (outputfactor-table dosedata)))
+
+ ;; AREA-COMPONENT will provide [after accumulating portal area]
+ ;; Output-Factor component due to portal area.
+ ;;
+ ;; INTEGRATED-COMPONENT is Output-Factor computed from Clarkson-like
+ ;; sector-integration of portal [summed over all sectors]. This value
+ ;; is clamped above a minimum value as determined by OUTPUTFACTOR-MIN-DIAM.
+ ;;
+ ;; SECTOR-COMPONENT is portion of integral due to single sector before
+ ;; being scaled by sector angle and accumulated into INTEGRATED-COMPONENT.
+ (declare (type (simple-array t 1) of-fssmap)
+ (type (simple-array single-float (3)) of-vector)
+ (type (simple-array single-float 1)
+ outfactor-fieldsizes outfactor-table)
+ (type single-float area-component integrated-component
+ outputfactor-min-diam portal-coeff))
+
+ ;; Compute area of collimator portal by the equivalent of inlining
+ ;; poly:AREA-OF-POLYGON. Requires portal to have at least 3 vertices.
+ (let* ((p0 (first vert-list)) ;First vertex - fixed, all triangles
+ (x0c (first p0)) ;Its X coord - fixed
+ (y0c (second p0)) ;Its Y coord - fixed
+ (p1 (second vert-list)) ;Second vertex - rotates around portal
+ (x1c (first p1)) ;Its X coord - rotates
+ (y1c (second p1)) ;Its Y coord - rotates
+ (p2) (x2c 0.0) (y2c 0.0) ;Third vertex - rotates around portal
+ (ps (cddr vert-list))) ;List whose CAR is 3rd vertex
+
+ (declare (type single-float x0c y0c x1c y1c x2c y2c))
+
+ (loop
+ (setq p2 (car ps) ;Compute 3rd vertex as it rotates
+ x2c (first p2)
+ y2c (second p2))
+
+ ;; This computes twice the area of a triangle whose vertices are
+ ;; (x0c y0c), (x1c y1c), (x2c y2c). Result is positive if triangle
+ ;; vertices are traversed CCW, negative if traversed CW.
+ (incf area-component (- (+ (* x0c y1c)
+ (* y0c x2c)
+ (* x1c y2c))
+ (+ (* y0c x1c)
+ (* x0c y2c)
+ (* x2c y1c))))
+ (cond ((consp (setq ps (cdr ps)))
+ ;; If more vertices, pass 3rd to 2nd and loop; otherwise done.
+ (setq x1c x2c y1c y2c))
+ (t (return)))))
+
+ ;; Accumulated area was twice actual - so multiply by 0.5 here.
+ ;; Also inline ABS here - AREA-COMPONENT is always non-negative.
+ (setq area-component (* 0.5 (if (>= area-component 0.0)
+ area-component
+ (- area-component))))
+
+ ;; Clarkson-like sector integration coming up for INTEGRATED-COMPONENT.
+ (do ((v1-nodes vert-list (cdr v1-nodes))
+ (v1-node) (v2-nodes) (v2-node)
+ (len-v1 0.0) (len-v2 0.0) (num-sectors 0)
+ (v1x 0.0) (v1y 0.0) (v2x 0.0) (v2y 0.0) (vjx 0.0) (vjy 0.0)
+ (v1-cross-vj 0.0) (len-vj 0.0) (perp-distance 0.0)
+ (theta-j 0.0) (theta-per-sector 0.0))
+ ((null v1-nodes))
+
+ (declare (type single-float v1x v1y v2x v2y len-v1 len-v2 vjx vjy
+ theta-per-sector v1-cross-vj perp-distance len-vj theta-j)
+ (type fixnum num-sectors))
+
+ ;; Vectors V1 and V2 [equivalently, nodes V1-NODE and V2-NODE] are
+ ;; vertices of portal as we successively CDR down portal vertex list.
+ ;; V1-NODE and V2-NODE are (X Y) coord pairs of the vertex at head of
+ ;; V1 and V2 vectors, respectively. V1X, V1Y, V2X, V2Y are X and Y
+ ;; coordinates of vectors V1 and V2 from isocenter to portal vertices
+ ;; V1-NODE and V2-NODE [projected onto isocenter plane]. VJ [variable
+ ;; not used] is vector from V1-NODE [vertex at tail] to V2-NODE [vertex
+ ;; at head]. VJX and VJY are its X and Y coordinates, respectively.
+ (cond
+ ((eq v1-nodes vert-list)
+ ;; First time around must compute everything. On each
+ ;; successive iteration we can pass V2-values back to V1.
+ (setq v1-node (car v1-nodes)
+ v1x (first v1-node)
+ v1y (second v1-node)
+ len-v1 (sqrt (the (single-float 0.0 *)
+ (+ (the (single-float 0.0 *) (* v1x v1x))
+ (the (single-float 0.0 *) (* v1y v1y)))))))
+ (t (setq v1x v2x
+ v1y v2y
+ len-v1 len-v2)))
+
+ (setq v2-nodes (or (cdr v1-nodes) vert-list)
+ v2-node (car v2-nodes)
+ v2x (first v2-node)
+ v2y (second v2-node))
+
+ (setq len-v2 (sqrt (the (single-float 0.0 *)
+ (+ (the (single-float 0.0 *) (* v2x v2x))
+ (the (single-float 0.0 *) (* v2y v2y)))))
+ vjx (- v2x v1x)
+ vjy (- v2y v1y)
+ len-vj (sqrt (the (single-float 0.0 *)
+ (+ (the (single-float 0.0 *) (* vjx vjx))
+ (the (single-float 0.0 *) (* vjy vjy)))))
+ v1-cross-vj (- (* v1x vjy)
+ (* v1y vjx)))
+
+ (setq perp-distance (cond ((< len-vj 1.0e-5) len-v1)
+ ((< v1-cross-vj 0.0)
+ (/ (- v1-cross-vj) len-vj))
+ (t (/ v1-cross-vj len-vj))))
+
+ ;; THETA-J and THETA-PER-SECTOR are always POSITIVE.
+ (setq theta-j (the single-float
+ (abs (the single-float
+ (atan (- (* v1x v2y) ;V1-CROSS-V2
+ (* v1y v2x))
+ (+ (* v1x v2x) ;V1-DOT-V2
+ (* v1y v2y)))))))
+
+ ;; If segment is degenerate, the contribution of this contour segment
+ ;; to the sector integral is zero. Thresholds are experimental.
+ (unless (or (< len-v1 1.0e-5) ;V1 tip touches isocenter
+ (< len-v2 1.0e-5) ;V2 tip touches isocenter
+ (< len-vj 1.0e-5) ;Degenerate segment
+ (< theta-j 1.0e-6) ;Degenerate segment
+ (< perp-distance 1.0e-5)) ;Degenerate segment
+
+ ;; Experiment with the 1 and 10.0 here. We are currently using a
+ ;; minimum of 1 sector per segment, each at most 10.0 degrees
+ ;; pie-width angle.
+ (setq num-sectors (the fixnum
+ (ceiling theta-j
+ #.(coerce (* pi (/ 10.0d0 180.0d0))
+ 'single-float)))
+ theta-per-sector (/ theta-j (coerce num-sectors 'single-float)))
+
+ (do ((psi (+ (- #.(coerce pi 'single-float)
+ (the single-float
+ (abs (the single-float
+ (atan v1-cross-vj
+ (+ (* v1x vjx) ;V1-DOT-VJ
+ (* v1y vjy)))))))
+ (* 0.5 theta-per-sector))
+ (+ psi theta-per-sector))
+ (sector-component 0.0)
+ (cnt num-sectors (the fixnum (1- cnt))))
+ ((= cnt 0)
+ ;; SECTOR-COMPONENT is always non-negative; thus
+ ;; INTEGRATED-COMPONENT should be INCREMENTED for CCW
+ ;; integration and DECREMENTED for CW integration.
+ ;; Done by reversing sign of THETA-PER-SECTOR.
+ (when (< v1-cross-vj 0.0)
+ (setq theta-per-sector (- theta-per-sector)))
+ (incf integrated-component (* sector-component theta-per-sector)))
+
+ (declare (type single-float psi sector-component)
+ (type fixnum cnt))
+
+ ;; PSI is always 0.0 < PSI < PI.
+ ;;
+ ;; Increment SECTOR-COMPONENT by Output-Factor for square field
+ ;; with same average radius. 1.782214 is ratio of side of square
+ ;; to radius of circle such that the square has same average radius
+ ;; as does the circle. OutputFactor Lookup.
+ ;;
+ ;; The SIN calculation here is in innermost loop. Investigate
+ ;; whether replacing it by pre-tabulated lookup helps speedup.
+ (incf sector-component
+ (the single-float
+ (1d-lookup of-vector ;OutputFactor Lookup.
+ (* 1.782214
+ (/ perp-distance
+ (sin (the (single-float 0.0 *) psi))))
+ outfactor-fieldsizes
+ of-fssmap
+ outfactor-table))))))
+
+ ;; Integrated component must be normalized by 1/2*PI since integral of
+ ;; sector angle around circle gives 2*PI. Also inline ABS, since
+ ;; INTEGRATED-COMPONENT will be computed to wrong sign if sector
+ ;; integration happens to traverse portal in CW rather than CCW direc.
+ (setq integrated-component
+ (* #.(coerce (/ 1.0d0 (* 2.0d0 pi)) 'single-float)
+ (if (>= integrated-component 0.0)
+ integrated-component
+ (- integrated-component))))
+
+ ;; If the portal area is at least that of a circle of diameter
+ ;; OUTPUTFACTOR-MIN-DIAM, then the Output-Factor is not allowed to go
+ ;; below that which a square portal would have whose area is that
+ ;; of such a circular portal.
+ (unless (< area-component ;Area of actual portal
+ ;;Area of circle of diameter OUTPUTFACTOR-MIN-DIAM.
+ (* #.(coerce (* 0.25d0 pi) 'single-float)
+ outputfactor-min-diam
+ outputfactor-min-diam))
+
+ (let ((min-integ-component
+ ;; Get Output-Factor for square field whose size is such that
+ ;; it has same area as circle of diameter OUTPUTFACTOR-MIN-DIAM.
+ ;; The factor 0.891107 is ratio of side of square to diameter
+ ;; of circle where square has same average radius as circle.
+ (1d-lookup of-vector ;OutputFactor Lookup.
+ (* 0.891107 outputfactor-min-diam)
+ outfactor-fieldsizes of-fssmap outfactor-table)))
+
+ (declare (type single-float min-integ-component))
+
+ (when (< integrated-component min-integ-component)
+ ;; Clamp INTEGRATED-COMPONENT so it goes no lower than
+ ;; MIN-INTEG-COMPONENT.
+ (setq integrated-component min-integ-component))))
+
+ ;; Area component is derived from portal area. Compute Output-Factor
+ ;; for equivalent square field whose side is square root of portal area.
+ (setq area-component
+ (1d-lookup of-vector ;OutputFactor Lookup.
+ (sqrt (the (single-float 0.0 *) area-component))
+ outfactor-fieldsizes of-fssmap outfactor-table))
+
+ ;; Weight AREA-COMPONENT by PORTAL-COEFF [0.0 <= value <= 1.0]
+ ;; and INTEGRATED-COMPONENT by one minus that value.
+ (+ (* portal-coeff area-component)
+ (* (- 1.0 portal-coeff) integrated-component))))
+
+;;;-------------------------------------------------------------
+
+(defmethod inv-outputfactor ((coll collimator) wc outputfactor dosedata)
+
+ "inv-outputfactor (coll collimator) wc outputfactor dosedata
+
+Returns WC, the fieldsize which would produce Output-Factor
+OUTPUTFACTOR for all but MLCs."
+
+ (declare (type single-float wc outputfactor)
+ (ignore outputfactor dosedata))
+ wc)
+
+;;;-------------------------------------------------------------
+
+(defmethod inv-outputfactor ((coll multileaf-coll) wc outputfactor dosedata)
+
+ "inv-outputfactor (coll multileaf-coll) wc outputfactor dosedata
+
+For MLCs, returns the fieldsize which would produce Output-Factor
+OUTPUTFACTOR, computed by inverting the FieldSize/Output-Factor relation."
+
+ (declare (type single-float wc outputfactor)
+ (ignore wc))
+
+ ;; Inverse OutputFactor Lookup using Binary/Linear Search.
+ (let ((input-table (outputfactor-table dosedata))
+ (output-table (outputfactor-fieldsizes dosedata))
+ (index- 0) (index+ 0) (lo-limit 0)
+ (input-lowerbound 0.0)
+ (input-upperbound 0.0))
+
+ ;; Values in INPUT-TABLE array must be monotonic increasing.
+ ;; INPUT-TABLE must have at least 3 slots for binary search to work.
+ (declare (type (simple-array single-float 1) input-table output-table)
+ (type single-float input-lowerbound input-upperbound)
+ (type fixnum index- index+ lo-limit))
+
+ (let* ((hi-limit (the fixnum (1- (array-total-size input-table))))
+ (idx (the fixnum (ceiling hi-limit 2))))
+
+ (declare (type fixnum hi-limit idx))
+
+ (cond
+ ((> hi-limit 8)
+ (loop
+ (setq input-lowerbound (aref input-table (the fixnum (1- idx)))
+ input-upperbound (aref input-table idx))
+
+ (cond
+ ((<= outputfactor input-lowerbound)
+ (setq hi-limit idx
+ idx (the fixnum
+ (+ lo-limit
+ (floor (the fixnum (- hi-limit lo-limit)) 2))))
+ (when (= idx lo-limit)
+ (setq index- (setq index+ lo-limit))
+ (return)))
+ ((< outputfactor input-upperbound)
+ (setq index- (the fixnum (1- idx))
+ index+ idx)
+ (return))
+ ((= outputfactor input-upperbound)
+ (setq index- (setq index+ idx))
+ (return))
+ ((< idx hi-limit)
+ (setq lo-limit idx
+ idx (the fixnum
+ (+ lo-limit
+ (the fixnum
+ (ceiling (the fixnum
+ (- hi-limit lo-limit)) 2))))))
+ (t (setq index- (setq index+ hi-limit))
+ (return)))))
+
+ ;; INPUT-TABLE is too small for binary search. Use sequential.
+ (t (do ((idx 0 (the fixnum (1+ idx)))
+ (old-input-value 0.0 new-input-value)
+ (new-input-value 0.0))
+ ((> idx hi-limit)
+ ;; Ran off end - return highest IDX.
+ (setq index- (setq index+ hi-limit)))
+
+ (declare (type single-float old-input-value new-input-value)
+ (type fixnum idx))
+
+ (when (<= outputfactor
+ (setq new-input-value (aref input-table idx)))
+ (cond ((or (= idx 0)
+ (= outputfactor new-input-value))
+ ;; If first iteration [input < first entry] or exact
+ ;; match, return index of exact [or first] value.
+ (setq index- (setq index+ idx)))
+ ;; Otherwise, interpolate output between values
+ ;; corresponding to input values fcn arg straddles.
+ (t (setq index- (the fixnum (1- idx))
+ index+ idx
+ input-lowerbound old-input-value
+ input-upperbound new-input-value)))
+ (return))))))
+
+ (the single-float
+ (cond ((= index- index+)
+ (aref output-table index-))
+ (t (interpolate-delta input-lowerbound
+ outputfactor
+ input-upperbound
+ (aref output-table index-)
+ (aref output-table index+)))))))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/patdb-panels.cl b/prism/src/patdb-panels.cl
new file mode 100644
index 0000000..254629f
--- /dev/null
+++ b/prism/src/patdb-panels.cl
@@ -0,0 +1,496 @@
+;;;
+;;; patdb-panels
+;;;
+;;; The Prism patient database management panel
+;;;
+;;; 29-Jun-1997 I. Kalet created, from dbmgr
+;;; 14-Aug-1997 I. Kalet for case and plan deletion from checkpoint
+;;; directory, generate patient list from case.index there, not
+;;; patient.index in archive.
+;;; 25-Aug-1997 I. Kalet add capability to delete cases from irreg
+;;; database as well as archive and checkpoint.
+;;; 9-Nov-1997 I. Kalet always use *patient-database* with
+;;; get-patient-entry because that is where patient.index is. Use
+;;; new optional parameter to select-case to suppress NEW CASE in
+;;; delete operations.
+;;; 28-Dec-1997 I. Kalet add delete patient button for easier cleanup
+;;; of checkpoint directory, move duplicated code to new function
+;;; select-patient-from-case-list and put in prism-db module.
+;;; 31-Dec-2001 I. Kalet allow selection of multiple cases to delete
+;;; in delete-old-case, and use match string for patient name and
+;;; number for checkpoint as well as archive.
+;;; 31-Oct-2003 I. Kalet allow selection of multiple image studies for
+;;; deletion in delete-old-image, also multiple patients in
+;;; delete-old-patient
+;;; 2-Jul-2004 I. Kalet allow selection of shared db for delete
+;;; operations as well as local checkpt and archive. Remove IRREG
+;;; support.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------
+
+(defclass patdb-panel (generic-panel)
+
+ ((frame :accessor frame
+ :documentation "The panel frame")
+
+ (pat-id :accessor pat-id
+ :initarg :pat-id
+ :documentation "The patient ID of the currently selected
+patient in this panel.")
+
+ (pat-name :accessor pat-name
+ :initarg :pat-name
+ :documentation "The string patient name of the currently
+selected patient in this panel.")
+
+ (hosp-id :accessor hosp-id
+ :initarg :hosp-id
+ :documentation "The hospital ID of the patient currently
+selected in this panel.")
+
+ (new-flag :accessor new-flag
+ :initform nil
+ :documentation "This flag is set when the user presses
+the Add button to get the next Prism ID number for adding a new
+patient entry.")
+
+ (database :accessor database
+ :initarg :database
+ :documentation "The database to use for add, update or
+delete operations.")
+
+ (delete-panel-btn :accessor delete-panel-btn
+ :documentation "The Delete Panel button.")
+
+ (add-pat-btn :accessor add-pat-btn
+ :documentation "The button for adding a new patient
+entry.")
+
+ (prism-num-rdt :accessor prism-num-rdt
+ :documentation "The readout displaying the Prism
+assigned ID number of the current patient. It is not editable.")
+
+ (name-tln :accessor name-tln
+ :documentation "The textline showing the patient name.")
+
+ (hosp-id-tln :accessor hosp-id-tln
+ :documentation "The textline showing the patient
+hospital ID.")
+
+ (select-pat-btn :accessor select-pat-btn
+ :documentation "The button for selecting the
+patient for updating the basic patient info.")
+
+ (update-btn :accessor update-btn
+ :documentation "The button to press to update the
+patient list with new information.")
+
+ (db-select-btn :accessor db-select-btn
+ :documentation "The button to select either the
+archive, IRREG, or checkpoint database for delete operations.")
+
+ (delete-case-btn :accessor delete-case-btn
+ :documentation "The button to press to select a
+single case of a specific patient, for deletion.")
+
+ (delete-plan-btn :accessor delete-plan-btn
+ :documentation "The button to press to select a
+single plan of a specific case of a specific patient, for deletion.")
+
+ (delete-pat-btn :accessor delete-pat-btn
+ :documentation "The button to press to select a
+patient from the checkpoint directory, for deletion of all that
+patient's cases in the user's checkpoint directory.")
+
+ (delete-img-stdy-btn :accessor delete-img-stdy-btn
+ :documentation "The button to press to select
+an image study for deletion, not necessarily associated with the
+current patient.")
+
+ )
+
+ (:default-initargs :pat-id 0 :pat-name "" :hosp-id ""
+ :database *patient-database*)
+
+ (:documentation "The patdb-panel provides the functions for adding a
+new patient to the patient list, editing the patient name or hospital
+id if it was entered wrong earlier, and for deleting cases and plans
+and image studies that are no longer needed, from either the archive
+or the checkpoint database.")
+
+ )
+
+;;;---------------------------------------
+
+(defun update-db-panel (pan)
+
+ "UPDATE-DB-PANEL pan
+
+puts the current patient information into the textlines and readout."
+
+ (setf (sl:info (prism-num-rdt pan)) (pat-id pan)
+ (sl:info (name-tln pan)) (pat-name pan)
+ (sl:info (hosp-id-tln pan)) (hosp-id pan)
+ (sl:border-color (name-tln pan)) 'sl:white
+ (sl:border-color (hosp-id-tln pan)) 'sl:white
+ (sl:border-width (name-tln pan)) 1
+ (sl:border-width (hosp-id-tln pan)) 1))
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((db-panel patdb-panel)
+ &rest initargs)
+
+ (let* ((btw 150)
+ (bth 30)
+ (dx 5) ;; position of left side buttons etc.
+ (dx2 (+ (* 2 dx) btw)) ;; position of middle buttons
+ (dx3 (+ dx2 btw dx)) ;; position of right side buttons etc.
+ (top-y 5)
+ (delta 20) ;; space between patient list stuff and deletion stuff
+ (frm (apply #'sl:make-frame
+ (+ dx (* 3 (+ btw dx)))
+ (+ top-y (* 5 (+ bth top-y)) delta)
+ :title "Prism Patient Database Manager"
+ initargs))
+ (frm-win (sl:window frm))
+ (del-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y top-y
+ :label "Del. Panel"
+ :parent frm-win
+ :button-type :momentary
+ initargs))
+ (add-b (apply #'sl:make-button btw bth
+ :ulc-x dx2 :ulc-y top-y
+ :label "Next Prism ID"
+ :parent frm-win
+ :button-type :momentary
+ initargs))
+ (id-r (apply #'sl:make-readout btw bth
+ :ulc-x dx3 :ulc-y top-y
+ :label "PID: "
+ :parent frm-win
+ initargs))
+ (name-t (apply #'sl:make-textline (+ (* 2 btw) dx) bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 1)
+ :parent frm-win
+ initargs))
+ (hosp-t (apply #'sl:make-textline btw bth
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 1)
+ :parent frm-win
+ initargs))
+ (sel-pat-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 2)
+ :label "Select Patient"
+ :parent frm-win
+ :button-type :momentary
+ initargs))
+ (update-b (apply #'sl:make-button btw bth
+ :ulc-x dx3 :ulc-y (bp-y top-y bth 2)
+ :label "Update patient"
+ :parent frm-win
+ initargs))
+ (db-sel-b (apply #'sl:make-button btw bth
+ :ulc-x dx
+ :ulc-y (+ (bp-y top-y bth 3) delta)
+ :label "DB: Archive"
+ :parent frm-win
+ :button-type :momentary
+ initargs))
+ (del-case-b (apply #'sl:make-button btw bth
+ :ulc-x dx2
+ :ulc-y (+ (bp-y top-y bth 3) delta)
+ :label "Delete case"
+ :parent frm-win
+ :button-type :momentary
+ initargs))
+ (del-plan-b (apply #'sl:make-button btw bth
+ :ulc-x dx3
+ :ulc-y (+ (bp-y top-y bth 3) delta)
+ :label "Delete plan"
+ :parent frm-win
+ :button-type :momentary
+ initargs))
+ (del-pat-b (apply #'sl:make-button btw bth
+ :ulc-x (+ dx (/ btw 2))
+ :ulc-y (+ (bp-y top-y bth 4) delta)
+ :label "Delete patient"
+ :parent frm-win
+ :button-type :momentary
+ initargs))
+ (del-img-stdy-b (apply #'sl:make-button btw bth
+ :ulc-x (+ dx2 (/ btw 2))
+ :ulc-y (+ (bp-y top-y bth 4) delta)
+ :label "Delete images"
+ :parent frm-win
+ :button-type :momentary
+ initargs)))
+ (setf (frame db-panel) frm
+ (delete-panel-btn db-panel) del-b
+ (add-pat-btn db-panel) add-b
+ (prism-num-rdt db-panel) id-r
+ (name-tln db-panel) name-t
+ (hosp-id-tln db-panel) hosp-t
+ (select-pat-btn db-panel) sel-pat-b
+ (update-btn db-panel) update-b
+ (db-select-btn db-panel) db-sel-b
+ (delete-case-btn db-panel) del-case-b
+ (delete-plan-btn db-panel) del-plan-b
+ (delete-pat-btn db-panel) del-pat-b
+ (delete-img-stdy-btn db-panel) del-img-stdy-b)
+ (update-db-panel db-panel) ;; initializes the contents of the display
+ (ev:add-notify db-panel (sl:button-on del-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (destroy pan)))
+ (ev:add-notify db-panel (sl:button-on add-b)
+ #'(lambda (pan bt)
+ (let* ((pat-list ;; always from/to archive
+ (get-patient-list *patient-database*))
+ (next-num
+ (if pat-list
+ (1+ (apply #'max
+ (mapcar #'first pat-list)))
+ (sl:acknowledge
+ "Patient index is inaccessible"))))
+ (if next-num
+ (progn
+ (setf (new-flag pan) t)
+ (setf (pat-id pan) next-num
+ (pat-name pan) ""
+ (hosp-id pan) "")
+ (update-db-panel pan))
+ (setf (sl:on bt) nil)))))
+ (ev:add-notify db-panel (sl:new-info name-t)
+ #'(lambda (pan tln info)
+ (declare (ignore tln))
+ (setf (sl:on (update-btn pan)) t)
+ (setf (pat-name pan) info)))
+ (ev:add-notify db-panel (sl:new-info hosp-t)
+ #'(lambda (pan tln info)
+ (declare (ignore tln))
+ (setf (sl:on (update-btn pan)) t)
+ (setf (hosp-id pan) info)))
+ (ev:add-notify db-panel (sl:button-on sel-pat-b)
+ #'(lambda (pan bt)
+ (let* ((id (select-patient
+ *patient-database*
+ (or (sl:popup-textline
+ "" 300
+ :label "Match with: "
+ :title "Patient search string")
+ "")))
+ (pat-rec (if id (get-patient-entry
+ id *patient-database*))))
+ (when pat-rec
+ (setf (new-flag pan) nil)
+ (setf (pat-id pan) (first pat-rec)
+ (pat-name pan) (second pat-rec)
+ (hosp-id pan) (third pat-rec))
+ (update-db-panel pan))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify db-panel (sl:button-off update-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt)) ;; always use archive
+ (if (new-flag pan)
+ (progn (setf (new-flag pan) nil)
+ (add-patient (pat-id pan)
+ (pat-name pan)
+ (hosp-id pan)
+ *patient-database*))
+ (edit-patient (pat-id pan)
+ (pat-name pan)
+ (hosp-id pan)
+ *patient-database*))))
+ (ev:add-notify db-panel (sl:button-on db-sel-b) ;; menu of dbs
+ #'(lambda (pan bt)
+ (let ((dbsel (sl:popup-menu '("Archive"
+ "Checkpoint"
+ "Shared temp"))))
+ (if dbsel
+ (case dbsel
+ (0 (progn (setf (database pan)
+ *patient-database*)
+ (setf (sl:label bt)
+ "DB: Archive")))
+ (1 (progn (setf (database pan)
+ *local-database*)
+ (setf (sl:label bt)
+ "DB: Local")))
+ (2 (progn (setf (database pan)
+ *shared-database*)
+ (setf (sl:label bt)
+ "DB: Shared"))))))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify db-panel (sl:button-on del-case-b)
+ #'(lambda (pan bt)
+ (delete-old-case (database pan))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify db-panel (sl:button-on del-plan-b)
+ #'(lambda (pan bt)
+ (delete-old-plan (database pan))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify db-panel (sl:button-on del-pat-b)
+ #'(lambda (pan bt)
+ (if (eql (database pan) *patient-database*)
+ (sl:acknowledge '("Cannot delete patients"
+ "from Archives"))
+ (delete-old-patient (database pan)))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify db-panel (sl:button-on del-img-stdy-b)
+ #'(lambda (pan bt)
+ (declare (ignore pan))
+ (delete-old-image-study *image-database*)
+ (setf (sl:on bt) nil)))))
+
+;;;---------------------------------------
+
+(defun make-patdb-panel (&rest initargs)
+
+ "MAKE-PATDB-PANEL &rest initargs
+
+returns an instance of a patdb-panel with the specified initargs."
+
+ (apply #'make-instance 'patdb-panel initargs))
+
+;;;---------------------------------------
+
+(defmethod destroy :before ((dbpan patdb-panel))
+
+ (sl:destroy (delete-panel-btn dbpan))
+ (sl:destroy (add-pat-btn dbpan))
+ (sl:destroy (prism-num-rdt dbpan))
+ (sl:destroy (name-tln dbpan))
+ (sl:destroy (hosp-id-tln dbpan))
+ (sl:destroy (select-pat-btn dbpan))
+ (sl:destroy (update-btn dbpan))
+ (sl:destroy (db-select-btn dbpan))
+ (sl:destroy (delete-case-btn dbpan))
+ (sl:destroy (delete-plan-btn dbpan))
+ (sl:destroy (delete-pat-btn dbpan))
+ (sl:destroy (delete-img-stdy-btn dbpan))
+ (sl:destroy (frame dbpan)))
+
+;;;---------------------------------------
+
+(defun delete-old-case (db)
+
+ (let* ((match-string (or (sl:popup-textline
+ "" 300
+ :label "Match with: "
+ :title "Patient search string")
+ ""))
+ (pat-num (if (equal db *patient-database*)
+ (select-patient *patient-database* match-string)
+ (select-patient-from-case-list *patient-database*
+ db match-string)))
+ (case-nums (when (and pat-num (not (zerop pat-num)))
+ (select-cases pat-num db))))
+ (dolist (case-num case-nums)
+ (let ((case-entry (find case-num (get-case-list pat-num db)
+ :key #'first)))
+ (when (sl:confirm
+ (list "Are you SURE you want to delete"
+ ""
+ (format nil "Case: ~a" (second case-entry))
+ (format nil "Date: ~a" (third case-entry))
+ (format nil "Database: ~a" db)))
+ (unless (delete-case pat-num case-num db)
+ (sl:acknowledge (list "Can't delete"
+ (format nil "patient ~a case ~a"
+ pat-num case-num)
+ "from case list")))
+ (unless (delete-case-file pat-num case-num db)
+ (sl:acknowledge (list "Can't find data file for"
+ (format nil "patient ~a case ~a"
+ pat-num case-num)))))))))
+
+;;;---------------------------------------
+
+(defun delete-old-plan (db)
+
+ (let* ((match-string (or (sl:popup-textline
+ "" 300
+ :label "Match with: "
+ :title "Patient search string")
+ ""))
+ (pat-num (if (equal db *patient-database*)
+ (select-patient *patient-database* match-string)
+ (select-patient-from-case-list *patient-database*
+ db match-string)))
+ (case-num (when (and pat-num (not (zerop pat-num)))
+ (select-case pat-num db nil)))
+ (case-data (when case-num
+ (get-case-data pat-num case-num db)))
+ (plans (when case-data (coll:elements (plans case-data))))
+ (plan-num (when plans (sl:popup-scroll-menu
+ (mapcar
+ #'(lambda (pln)
+ (format nil "~30a ~20a ~20a"
+ (name pln) (plan-by pln)
+ (time-stamp pln)))
+ plans)
+ 600 300
+ :title "Select a plan to DELETE")))
+ (plan (when plan-num (nth plan-num plans))))
+ (when (and plan-num
+ (sl:confirm
+ (list "Are you SURE you want to delete"
+ ""
+ (format nil "Plan: ~a" (name plan))
+ (format nil "By: ~a" (plan-by plan))
+ (format nil "Date: ~a" (time-stamp plan))
+ (format nil "Database: ~a" db))))
+ (unless (delete-plan-from-case pat-num case-num plan db)
+ (sl:acknowledge
+ (format nil "Can't delete patient ~a case ~a plan name ~a"
+ pat-num case-num (name plan)))))))
+
+;;;---------------------------------------
+
+(defun delete-old-patient (db)
+
+ (let ((patnums (select-patients-from-case-list *patient-database*
+ db)))
+ (dolist (patnum patnums)
+ (when (and patnum
+ (sl:confirm (list "Are you SURE you want to delete"
+ (format nil "Patient: ~a" patnum)
+ (format nil "from database ~a?" db))))
+ (mapcar #'(lambda (casenum)
+ (delete-case-file patnum casenum db)
+ (delete-case patnum casenum db))
+ (mapcar #'first (get-case-list patnum db)))))))
+
+;;;---------------------------------------
+
+(defun delete-old-image-study (db)
+
+ (let ((img-entries (select-full-image-sets
+ db
+ :title "Select image studies to DELETE:")))
+ (dolist (img-entry img-entries)
+ (let* ((pat-id (first img-entry))
+ (img-id (second img-entry))
+ (pat-name (second (get-patient-entry
+ pat-id *patient-database*))))
+ (when (and img-entry
+ (sl:confirm
+ (list "Are you SURE you want to delete this image study?"
+ ""
+ (format nil "~5 at A ~A ~4 at A ~50A"
+ pat-id pat-name img-id (third img-entry)))))
+ (unless (delete-image-set pat-id img-id db)
+ (sl:acknowledge
+ (format nil "Can't delete image study ~a." img-id)))
+ (unless (delete-image-files pat-id img-id db)
+ (sl:acknowledge
+ (format nil
+ "Can't find data files for patient ~a image study ~a"
+ pat-id img-id))))))))
+
+;;;---------------------------------------
+;;; End.
diff --git a/prism/src/pathlength.cl b/prism/src/pathlength.cl
new file mode 100644
index 0000000..c9c0dbd
--- /dev/null
+++ b/prism/src/pathlength.cl
@@ -0,0 +1,817 @@
+;;;
+;;; pathlength
+;;;
+;;; Provides the pathlength ray-tracing function that finds the
+;;; density-weighted path from point A to point B through a bunch of
+;;; PSTRUCTs. The prism construction functions are here, along with
+;;; the actual PATHLENGTH function.
+;;;
+;;; 16-Jan-1997 I. Kalet started implementation (stub so far).
+;;; 23-Jun-1997 BobGian merged with Gavin Young's work (real thing).
+;;; 03-Sep-1997 BobGian reworking code to interface with Prism.
+;;; 07-Sep-1997 BobGian moved clipping code here from beam-dose. This file
+;;; serves as a utilities file for beam-dose, which depends on pathlength
+;;; but not conversely.
+;;; 7-Oct-1997 BobGian move CONTOUR-ENCLOSES-P to POLYGONS package.
+;;; 10-Nov-1997 BobGian incorporate bug fixes from Gavin, inline crossproduct.
+;;; 22-Jan-1998 BobGian update with new faster version [array-type decls,
+;;; array-access and arithmetic inlining, argument-vector usage]. Also,
+;;; move all polygon clipping code to separate file: clipper.cl.
+;;; 09-Mar-1998 BobGian modest upgrade of dose-calc code.
+;;; 22-May-1998 BobGian major overhaul of PATHLENGTH function:
+;;; - DEFCONSTANTS naming slots in Arg-Vec moved to new file
+;;; "dosecomp-decls", which also contains macros used here.
+;;; - Arg-Vec: making calling conventions more consistent, also
+;;; allowing sharing of this technique [and same vector] for calls
+;;; between functions in "beam-dose.cl" and "clipper.cl".
+;;; - Restructuring data flows to decrease use of MAPCAR and SORT.
+;;; Processing data sequentially rather than building large structures
+;;; to be passed in functional style through various stages.
+;;; Building structures incrementally in sorted order rather than
+;;; sorting after entire structure built. These optimizations alone
+;;; account for a factor of 3 speedup.
+;;; - Inlining: ASSEMBLE-L, ASSEMBLE-LI, ASSEMBLE-LI-HAT,
+;;; INTERSECT-ALPHAS, ROTATE-IF-NECESSARY.
+;;; - Converting from tail-recursive [structure-recursive argument-
+;;; copying] to iterative [argument copying only when necessary]
+;;; in REPLACE-CONSEC-VRTS and REMOVE-DUPLICATES-BY-PAIRS.
+;;; - New version of contour-encloses-point algorithm included here.
+;;; 01-Jun-1998 BobGian fix mistake in ENCLOSES? (contour-encloses-pt)
+;;; function - missing expression in collinearity test; also now
+;;; returns T if point is on boundary (simplifies calling code slightly).
+;;; 08-Jun-1998 BobGian optimization update: all mapping functions replaced
+;;; by in-line iteration, bug-fix in preserving stack order of structure
+;;; tags when sorting identically-valued ray alpha coordinates.
+;;; 26-Jun-1998 BobGian further optimization: pass ORGAN-DENSITY-ARRAY as
+;;; array rather than list, condense redundant sorting, avoid redundant
+;;; consing, compress redundant temp variables.
+;;; 17-Jul-1998 BobGian modify order of arguments to PATHLENGTH to make
+;;; consistent with new function BUILD-PATIENT-STRUCTURES, which is added
+;;; to factor beam-independent portion of PATHLENGTH setup out of
+;;; COMPUTE-BEAM-DOSE so it can be called once per dosecalc, for all beams.
+;;; 20-Jul-1998 BobGian optimize a few more array declarations and accessors.
+;;; 13-Aug-1998 BobGian make PATHLENGTH return "dosepoint-inside-patient-p"
+;;; flag (numerical value returned via Arg-Vec) so COMPUTE-BEAM-DOSE
+;;; can set dose outside patient to zero.
+;;; 03-Feb-2000 BobGian cosmetic fixes (case regularization).
+;;; 02-Mar-2000 BobGian add declarations in PATHLENGTH, REPLACE-CONSEC-VRTS.
+;;; 24-Mar-2000 BobGian add check for empty contours in preprocessor function
+;;; BUILD-PATIENT-STRUCTURES - otherwise PATHLENGTH can crash.
+;;; 27-Jun-2000 BobGian correct comment above about comments of this file.
+;;; 02-Nov-2000 BobGian replace old ENCLOSES? (based on winding angle) with
+;;; new function based on faster ray/contour-intersection algorithm.
+;;; Minor variable-name changes in PATHLENGTH preparatory to new version
+;;; being developed for electron code.
+;;; 30-May-2001 BobGian - major restructuring of pathlength computation:
+;;; Separate raytracing from line integration so that redundant computation
+;;; can be factored out (PATHLENGTH-RAYTRACE called once to build structure
+;;; that can be queried by PATHLENGTH-INTEGRATE multiple times).
+;;; Change all calling points in Electron and Photon dose calc.
+;;; Wrap generic arithmetic with THE-declared types.
+;;; 03-Jun-2001 BobGian fix PATHLENGTH-INTEGRATE to report whether target
+;;; point is inside or outside body.
+;;; 15-Mar-2002 BobGian PATHLENGTH-RAYTRACE used for "ray out-of-body"
+;;; detection rather than PATHLENGTH-INTEGRATE, which just returns zero
+;;; rather than an "out-of-body" flag in this case. Normally it will
+;;; never be called in this case, the condition having been detected
+;;; earlier by PATHLENGTH-RAYTRACE.
+;;; Also BUILD-PATIENT-STRUCTURES checks all organ densities and returns
+;;; a flag indicating whether none are present [dosecalc can't proceed then]
+;;; or some are out of range [dosecalc can proceed but user is warned first].
+;;; 29-Apr-2002 BobGian PATHLENGTH-RAYTRACE cannot be used alone for
+;;; "ray out-of-body" detection, since it traces full length of normalizing
+;;; distance. Must also integrate to dosepoint for correct test.
+;;; 20-Sep-2002 BobGian BUILD-PATIENT-STRUCTURES checks organs for presence
+;;; of contours as well as checking contours for presence of vertices.
+;;; 03-Jan-2003 BobGian:
+;;; REPLACE-CONSEC-VERTS inlined in PATHLENGTH-RAYTRACE. Two slot formerly
+;;; used in argument vector to pass args to it now flushed.
+;;; PATHLENGTH-RAYTRACE and -INTEGRATE now use CONS cells rather than 2-elem
+;;; lists for internal data structures [X/Y coordinate pairs].
+;;; PATHLENGTH-INTEGRATE can calculate both density-weighted pathlength and
+;;; homogeneous pathlength at same time, returning either or both, as
+;;; controlled by last argument, in pair of slots in argument vector.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 31-Jan-2005 AMSimms - corrected use of Allegro specific coercions, now
+;;; using coerce explicitly.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defun build-patient-structures (patient-anatomy &aux organ-vertices-list
+ organ-zvals-list organ-density-list
+ the-density density-flag)
+
+ "build-patient-structures patient-anatomy
+
+returns three stuctures [two lists and one array] representing the patient's
+anatomy in a form suitable for PATHLENGTH-RAYTRACE.
+
+Returns: Organ-Vertices-List Organ-Z-Extents Organ-Density-Array Density-Flag"
+
+ ;; PATIENT-ANATOMY is the value of the PATIENT object's ANATOMY slot, which
+ ;; is a COLLECTION object. From this we build three lists representing
+ ;; patient anatomy in a form suitable for passing to PATHLENGTH-RAYTRACE.
+
+ ;; We represent each organ [including the outer body contour] by three
+ ;; items, a Density [a single flonum], a ZValue-List [list of Z coordinates
+ ;; associated with each contour], and a Vertices-List [list of Vertices
+ ;; associated with each contour]. The ZValue-List and Vertices-List must
+ ;; correspond element-by-element with each other: the first ZValue is
+ ;; associated with the first Vertex-List [sublist in the Vertices-List],
+ ;; and so on. Both lists are ordered by increasing ZValue. Therefore, the
+ ;; ZValue-List itself will be a linearly-ordered increasing sequence of
+ ;; flonums, and the Vertices-List will be a list of the Vertex-Lists of the
+ ;; corresponding contours. Vertices and Z-Values are sorted by increasing
+ ;; Z within an organ, but organs are not ordered with respect to each other.
+
+ ;; Contours as stored in the PATIENT-ANATOMY passed in are not guaranteed
+ ;; to be so ordered. Therefore, we must build the sorted data structure
+ ;; here before passing anything to PATHLENGTH-RAYTRACE, which assumes such
+ ;; ordering. PATHLENGTH-RAYTRACE also takes its arguments in this parallel
+ ;; list format rather than as a list of ORGAN objects, so we also destructure
+ ;; ORGAN objects while building the sorted lists.
+
+ ;; ORGAN-ZVALS-LIST is a LIST of the ZValue-Lists, one element per organ.
+ ;; ORGAN-VERTICES-LIST is a LIST of the Vertices-Lists, one per organ.
+ ;; ORGAN-DENSITY-LIST is a LIST of the organ densities [single flonum value
+ ;; representing the radiological density for each organ]. NB: each item
+ ;; represents a LIST of organs, not a single organ.
+
+ ;; Corresponding elements [by order] of these lists represent the same organ.
+ ;; Then we CONS a single 0.0 to the front of ORGAN-DENSITY-LIST to represent
+ ;; the zero density of the "contour at infinity" [ie, the air outside the
+ ;; patient's body], for the convenience of PATHLENGTH-RAYTRACE's internals.
+ ;; From this point on, the three lists correspond but ORGAN-DENSITY-LIST is
+ ;; longer by one than the others, and its organ-by-organ correspondence is
+ ;; shifted rearward by one element with respect to the other two.
+ ;; ORGAN-DENSITY-LIST is returned as an array [second return value]
+ ;; for easy random access.
+
+ ;; We build these structures once before starting the dose calculation
+ ;; loop, because these structures are invariant over an entire calculation.
+
+ (declare (type list organ-vertices-list organ-zvals-list organ-density-list)
+ (type (or null float) the-density)
+ (type (member nil :Too-Large) density-flag))
+
+ (dolist (organ-obj (coll:elements patient-anatomy))
+
+ (when (setq the-density (density organ-obj))
+ ;; Organ density of NIL -> ignore this organ in pathlength computation.
+ (setq the-density (coerce the-density 'single-float)) ;Just in case ...
+ (let ((organ-contour-objects (contours organ-obj)))
+ (declare (type list organ-contour-objects))
+ ;; Check that organ has contours.
+ (when (consp organ-contour-objects)
+ (let* ((first-contour-obj (first organ-contour-objects))
+ ;; Initialize accumulators to first of each input list.
+ ;; Then insert rest of elements in sorted order.
+ (organ-zvals (list (z first-contour-obj)))
+ (organ-vertices (list (vertices first-contour-obj))))
+ (declare (type list organ-zvals organ-vertices))
+ (do ((contour-objects (cdr organ-contour-objects)
+ (cdr contour-objects))
+ (the-object) (the-vertices))
+ ((null contour-objects)
+ ;; Done with organ - push each component onto output list.
+ (push organ-zvals organ-zvals-list)
+ (push organ-vertices organ-vertices-list)
+ (when (> the-density #.Tissue-Maximum-Density)
+ (setq density-flag :Too-Large))
+ (push the-density organ-density-list))
+ (declare (type list contour-objects the-vertices))
+ (setq the-object (car contour-objects)) ;Item being inserted
+ ;; Check that contours are legit. If an empty one has slipped
+ ;; through, pass over it. Otherwise PATHLENGTH-RAYTRACE crashes.
+ (when (consp (setq the-vertices (vertices the-object)))
+ (do ((the-z (z the-object)) ;Its Z value - sort key
+ ;; Insertion-location pointers for ZValue.
+ (zvals-headptr organ-zvals (cdr zvals-headptr))
+ (zvals-tailptr nil zvals-headptr)
+ ;; Insertion-location pointers for Vertices-List
+ (verts-headptr organ-vertices (cdr verts-headptr))
+ (verts-tailptr nil verts-headptr))
+ ((null zvals-headptr)
+ ;; Didn't find insertion spot - append to ends of lists.
+ (setf (cdr zvals-tailptr) (list the-z))
+ (setf (cdr verts-tailptr) (list the-vertices)))
+ (declare (type single-float the-z))
+ ;; Scan for insertion point.
+ (when (< the-z (the single-float (car zvals-headptr)))
+ ;; Insert new element at this point and return.
+ (cond ((null zvals-tailptr) ;Insertion is at front of list.
+ (push the-z organ-zvals)
+ (push the-vertices organ-vertices))
+ (t (setf (cdr zvals-tailptr)
+ (cons the-z zvals-headptr))
+ (setf (cdr verts-tailptr)
+ (cons the-vertices verts-headptr))))
+ (return))))))))))
+
+ (values organ-vertices-list
+
+ ;; ORGAN-Z-EXTENTS, which has contours-like format,
+ ;; but has prism ceiling and floor Z values.
+ ;; (((s1c1z- s1c1z+) (s1c2z- s1c2z+) (s1c3z- s1c3z+))
+ ;; ((s2c1z- s2c1z+) (s2c2z- s2c2z+))
+ ;; ((s3c1z- s3c1z+) (s3c2z- s3c2z+)))
+ (mapcar #'(lambda (a-strctr-zs a-strctr-zdiffs)
+ (mapcar #'(lambda (zval zval-m zval-p)
+ (declare (type single-float zval
+ zval-m zval-p))
+ (list (- zval zval-m) (+ zval zval-p)))
+ a-strctr-zs
+ (cons 0.0 a-strctr-zdiffs)
+ (nconc a-strctr-zdiffs (list 0.0))))
+
+ organ-zvals-list
+
+ ;; A-STRCTR-ZDIFFS has same format as ORGAN-ZVALS-LIST but with
+ ;; one fewer elements per structure. For each organ, it is a list
+ ;; of the half-widths [in Z-value] of the consecutive segments in
+ ;; ORGAN-ZVALS-LIST.
+ (mapcar
+ #'(lambda (a-strctr-zs)
+ (mapcar
+ #'(lambda (z-cntr1 z-cntr2)
+ (declare (type single-float z-cntr1 z-cntr2))
+ (* 0.5 (- z-cntr2 z-cntr1)))
+ a-strctr-zs (cdr a-strctr-zs)))
+ organ-zvals-list))
+
+ ;; ORGAN-DENSITY-ARRAY.
+ (make-array (the fixnum (1+ (length organ-density-list)))
+ :element-type 'single-float
+ :initial-contents (cons 0.0 organ-density-list))
+
+ ;; Flag indicating that no densities are present
+ ;; or that some organ density is out of range.
+ (if (null organ-density-list) :Missing density-flag)))
+
+;;;=============================================================
+;;; Main functions for computing radiological equivalent pathlength.
+;;; This set of functions was written by Gavin Young as an implementation
+;;; of his Master's thesis.
+
+(defun pathlength-raytrace (arg-vec organ-vertices-list organ-z-extents
+ &aux (dp-x 0.0) (dp-y 0.0) (dp-z 0.0) (src-x 0.0)
+ (src-y 0.0) (src-z 0.0) (dx 0.0) (dy 0.0) (dz 0.0)
+ templist-1 templist-2)
+
+ "pathlength-raytrace arg-vec organ-vertices-list organ-z-extents
+
+returns a descriptor (list of prisms/densities) from which to compute
+tissue-equivalent-pathlength from source (SRC-X, SRC-Y, SRC-Z)
+to dose-point (DP-X, DP-Y, DP-Z), through anatomy represented by
+ORGAN-VERTICES-LIST and ORGAN-Z-EXTENTS. Args are stored in
+ARG-VEC in slots named Argv-Src-X, Argv-Src-Y, Argv-Src-Z, Argv-Dp-X,
+Argv-Dp-Y, and Argv-Dp-Z."
+
+ (declare (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type list organ-vertices-list organ-z-extents
+ templist-1 templist-2)
+ (type single-float src-x src-y src-z dp-x dp-y dp-z dx dy dz))
+
+ ;; Dereference 6 SINGLE-FLOAT arguments from argument vector. These are
+ ;; in place from original call to PATHLENGTH-RAYTRACE. Load the two
+ ;; "difference" locals for convenient passage to callees.
+ (setq dp-x (aref arg-vec #.Argv-Dp-X)
+ dp-y (aref arg-vec #.Argv-Dp-Y)
+ dp-z (aref arg-vec #.Argv-Dp-Z)
+ src-x (aref arg-vec #.Argv-Src-X)
+ src-y (aref arg-vec #.Argv-Src-Y)
+ src-z (aref arg-vec #.Argv-Src-Z)
+ dx (- dp-x src-x)
+ dy (- dp-y src-y)
+ dz (- dp-z src-z))
+
+ ;; Load args for ENCLOSES? - these args are fixed
+ ;; for extent of this function call.
+ (setf (aref arg-vec #.Argv-Enc-X) dp-x)
+ (setf (aref arg-vec #.Argv-Enc-Y) dp-y)
+
+ ;; Next expression has the ALPHAs for each prism's ceiling and floor
+ ;; [ordered by decreasing alpha, irrespective of ceiling/floor Z-values]
+ ;; and in same format as ORGAN-Z-EXTENTS.
+ (dolist (strctr-z-extent organ-z-extents)
+ (let ((tmp3 '()))
+ (dolist (cntr-ze strctr-z-extent)
+ (push (cond ((= dz 0.0)
+ (cons nil nil))
+ (t (let ((tmp1 (/ (- (the single-float (second cntr-ze))
+ src-z)
+ dz))
+ (tmp2 (/ (- (the single-float (first cntr-ze))
+ src-z)
+ dz)))
+ (cond ((> tmp1 tmp2)
+ (cons tmp1 tmp2))
+ (t (cons tmp2 tmp1))))))
+ tmp3))
+ (push (nreverse tmp3) templist-1)))
+
+ (do ((szes organ-z-extents (cdr szes))
+ (svs organ-vertices-list (cdr svs))
+ (sacfs (nreverse templist-1) (cdr sacfs))
+ (templist-3 nil nil))
+ ((null szes))
+ (declare (type list szes svs sacfs templist-3))
+ ;; List1: List of ( prism-floor-Z prism-ceil-Z ) for each organ.
+ ;; List2: List of vertex-lists for each organ.
+ ;; List3: ( >-prism-alpha . <-prism-alpha ) for each organ.
+ (do ((list1 (car szes) (cdr list1))
+ (list2 (car svs) (cdr list2))
+ (list3 (car sacfs) (cdr list3))
+ (prsm-z-e) (cntr) (prsm-alpha-c-f)
+ (z-minus 0.0) (z-plus 0.0))
+ ((null list1))
+ (declare (type list prsm-z-e cntr prsm-alpha-c-f)
+ (type single-float z-minus z-plus))
+ (setq prsm-z-e (car list1)
+ cntr (car list2)
+ prsm-alpha-c-f (car list3)
+ z-minus (first prsm-z-e)
+ z-plus (second prsm-z-e))
+ (cond
+ ((or (and (< src-z z-minus) ;SRC and DP both below prism floor.
+ (< dp-z z-minus))
+ (and (>= src-z z-plus) ;SRC and DP both above prism ceiling.
+ (>= dp-z z-plus))))
+
+ ((and (= dp-x src-x) ;SRC->DP ray parallel to Z axis.
+ (= dp-y src-y))
+ (when (encloses? cntr arg-vec) ;Ray intersects prism.
+ (setq templist-3 (nconc templist-3
+ (list (car prsm-alpha-c-f)
+ (cdr prsm-alpha-c-f))))))
+
+ ;; Otherwise, find all alphas for intersection of polygon described
+ ;; by CNTR and ray described by SRC and DP where alpha(SRC)=0 and
+ ;; alpha(DP)=1. Assumes CNTR is legal [at least three points, no
+ ;; adjacent triples which are collinear, and non-self-intersecting].
+ ;; Rotate the vertices in CNTR until first and last are NOT on SRC->DP
+ ;; ray. As long as CNTR has no collinear triples, we can do this
+ ;; in at most a single rotation.
+ (t (setq templist-1 nil)
+ (let ((first-elem (first cntr))
+ (last-elem (car (last cntr))))
+ (let ((fex (first first-elem))
+ (fey (second first-elem))
+ (lex (first last-elem))
+ (ley (second last-elem)))
+ (declare (type single-float fex fey lex ley))
+ (when (and
+ ;; ZEROP First-Elem->SRC cross First-Elem->DP.
+ (= (* (- src-x fex)
+ (- dp-y fey))
+ (* (- src-y fey)
+ (- dp-x fex)))
+ ;; ZEROP Last-Elem->SRC cross Last-Elem->DP.
+ (= (* (- src-x lex)
+ (- dp-y ley))
+ (* (- src-y ley)
+ (- dp-x lex))))
+ (setq cntr (cons last-elem (butlast cntr))))))
+
+ ;; Replace consecutive vertices that lie exactly on the SRC->DP ray
+ ;; with one vertex at the midpoint of the line from one vertex to
+ ;; the other. Does NOT link last vertex to first, so make sure
+ ;; (first, last) are NOT on SRC->DP ray.
+ (do ((cntr-tail cntr (cdr cntr-tail))
+ (copy? t))
+ ((null (cdr cntr-tail)))
+ (declare (type list cntr-tail)
+ (type (member nil t) copy?))
+ (let ((v1 (first cntr-tail))
+ (v2 (second cntr-tail)))
+ (let ((v1x (first v1))
+ (v1y (second v1))
+ (v2x (first v2))
+ (v2y (second v2)))
+ (declare (type single-float v1x v1y v2x v2y))
+ (when (and
+ ;; ZEROP SRC->V1 cross SRC->DP
+ (= (* (- v1x src-x) dy)
+ (* (- v1y src-y) dx))
+ ;; ZEROP SRC->V2 cross SRC->DP
+ (= (* (- v2x src-x) dy)
+ (* (- v2y src-y) dx)))
+ (let ((new-vertex
+ (list (* 0.5 (+ v1x v2x)) (* 0.5 (+ v1y v2y)))))
+ (cond
+ ((eq cntr cntr-tail)
+ (setq cntr-tail
+ (setq cntr (cons new-vertex (cddr cntr)))))
+ (copy?
+ ;; Found a pair of vertices to merge. Must copy the
+ ;; entire chain so as to avoid damaging shared list
+ ;; structure. From then on we can make all changes
+ ;; destructively to this new copy, returning it when
+ ;; done as final value of the function.
+ ;;
+ ;; Duplicate chain from start to split point [up to
+ ;; but not including first vertex of pair to be
+ ;; merged]. Leave CNTR-TAIL pointing to last CONS
+ ;; of this chain, so that its successive CDRs can be
+ ;; changed if new vertices need to be spliced into the
+ ;; chain. After appending the new collapsed vertex
+ ;; we must copy the rest of the chain, in case any
+ ;; further modifications are necessary [if not, we
+ ;; have wasted a few CONS cells that could have been
+ ;; shared, but we have save considerable complexity
+ ;; - and this case should arise extremely rarely].
+ (do ((accum '())
+ (head cntr (cdr head)))
+ ((eq head cntr-tail)
+ (setq cntr-tail accum)
+ (setq cntr (nreverse accum))
+ ;; After NREVERSE, CNTR-TAIL points to last CONS
+ ;; of chain in list which is new value of CNTR.
+ ;; Splice in new vertex followed by copied tail
+ ;; of original list.
+ (setf (cdr cntr-tail)
+ (setq cntr-tail
+ (cons new-vertex
+ (copy-list (cddr cntr-tail)))))
+ (setq copy? nil))
+ (push (car head) accum)))
+ ;;
+ ;; In case just above and that to follow, we end with
+ ;; CNTR-TAIL pointing at the CONS cell whose CAR is the
+ ;; new collapsed vertex. On next iteration we examine
+ ;; the next two vertices AFTER collapsed one. We know
+ ;; that those two cannot be collinear with the collapsed
+ ;; one or else all three uncollapsed vertices would have
+ ;; been collinear beforehand - and we checked for that
+ ;; before starting PATHLENGTH-RAYTRACE.
+ ;;
+ ;; List already copied. Since we can make changes
+ ;; destructively, we can reuse the current CONS cell
+ ;; [one pointed to by CNTR-TAIL, whose CAR is first
+ ;; vertex of pair to be merged] to contain instead
+ ;; [set its CAR to point to] the new collapsed vertex
+ ;; and set its CDR to point to rest of list just beyond
+ ;; the merged pair. This avoids necessity of keeping
+ ;; a pointer to one cell back in the list for appending
+ ;; to it the new vertex. Splice in collapsed vertex.
+ (t (setf (car cntr-tail) new-vertex)
+ ;; Skip over second of pair.
+ (setf (cdr cntr-tail) (cddr cntr-tail)))))))))
+
+ (prog ((vs-pre) (vs-nxt) (tmpvert) (vrtx-cur) (vrtx-nxt)
+ (cp-prev 0.0) (cp-curr 0.0) (cp-next 0.0))
+ (declare (type single-float cp-prev cp-curr cp-next))
+ (setq vs-pre cntr
+ tmpvert (car vs-pre)
+ cp-prev (- (* (- (the single-float (first tmpvert)) src-x)
+ dy)
+ (* (- (the single-float (second tmpvert)) src-y)
+ dx))
+ tmpvert (cdr vs-pre)
+ vrtx-cur (car tmpvert)
+ cp-curr (- (* (- (the single-float (first vrtx-cur)) src-x)
+ dy)
+ (* (- (the single-float (second vrtx-cur)) src-y)
+ dx))
+ vs-nxt (cdr tmpvert)
+ vrtx-nxt (car vs-nxt)
+ cp-next (- (* (- (the single-float (first vrtx-nxt)) src-x)
+ dy)
+ (* (- (the single-float (second vrtx-nxt)) src-y)
+ dx)))
+
+ LOOP1
+ (when (or (and (> cp-curr 0.0) (< cp-next 0.0))
+ (and (< cp-curr 0.0) (> cp-next 0.0))
+ (and (= cp-curr 0.0) (> cp-next 0.0) (< cp-prev 0.0))
+ (and (= cp-curr 0.0) (< cp-next 0.0) (> cp-prev 0.0)))
+ ;; / first arg is SRC->VRTX-CUR cross SRC->VRTX-NXT.
+ (push (/ (- (* (- (the single-float (first vrtx-cur)) src-x)
+ (- (the single-float (second vrtx-nxt)) src-y))
+ (* (- (the single-float (second vrtx-cur)) src-y)
+ (- (the single-float (first vrtx-nxt)) src-x)))
+ (- cp-curr cp-next))
+ templist-1))
+ (cond
+ ((null (setq vs-pre (cdr vs-pre))))
+ (t (setq vs-nxt (or (cdr vs-nxt) cntr)
+ vrtx-cur vrtx-nxt
+ vrtx-nxt (car vs-nxt)
+ cp-prev cp-curr
+ cp-curr cp-next
+ cp-next (- (* (- (the single-float (first vrtx-nxt))
+ src-x)
+ dy)
+ (* (- (the single-float (second vrtx-nxt))
+ src-y)
+ dx)))
+ (go LOOP1))))
+
+ (unless (= dp-z src-z) ;Compute line intersections.
+ (do ((alphas templist-1 (cdr alphas))
+ (p-a-c-f-1 (car prsm-alpha-c-f))
+ (p-a-c-f-2 (cdr prsm-alpha-c-f))
+ (alpha 0.0))
+ ((null alphas))
+ (declare (type single-float alpha p-a-c-f-1 p-a-c-f-2))
+ (setq alpha (car alphas))
+ (cond ((> alpha p-a-c-f-1)
+ (setf (car alphas) p-a-c-f-1))
+ ((< alpha p-a-c-f-2)
+ (setf (car alphas) p-a-c-f-2)))))
+
+ (setq templist-3
+ (nconc templist-3
+ (remove-duplicates-by-pairs (sort templist-1 #'<)))))))
+
+ (push (remove-duplicates-by-pairs (sort templist-3 #'<)) templist-2))
+
+ (setq templist-1 nil)
+ (do ((strctr-list templist-2 (cdr strctr-list))
+ (strctr-tag (length templist-2) (the fixnum (1- strctr-tag))))
+ ((null strctr-list))
+ (declare (type fixnum strctr-tag))
+ (do ((alphas (car strctr-list) (cdr alphas))
+ (alpha 0.0))
+ ((null alphas))
+ (declare (type single-float alpha))
+ (setq alpha (car alphas))
+ (cond ((< alpha 0.0)
+ (push (cons 0.0 strctr-tag) templist-1))
+ ((< alpha 1.0)
+ ;; Pushing ALPHAs normalized to fixed ray length of
+ ;; Pathlength-Ray-Maxlength (400.0) centimeters.
+ (push (cons (* #.Pathlength-Ray-Maxlength alpha) strctr-tag)
+ templist-1)))))
+
+ (when (consp (cdr templist-1))
+ (setq templist-1 (sort templist-1 #'< :key #'car))
+ (prog ((items1 templist-1) items2 items3 item1 item2 item3)
+ (setq items2 (cdr items1))
+ (unless (consp (setq items3 (cdr items2)))
+ (return))
+ (setq item1 (car items1)
+ item2 (car items2)
+ item3 (car items3))
+ LOOP2
+ (cond ((and (= (the single-float (car item2))
+ (the single-float (car item3)))
+ (= (the fixnum (cdr item1))
+ (the fixnum (cdr item3))))
+ ;; Possible mistake here.
+ (setf (cdr items1)
+ (setq items1 (list* item3 item2
+ (setq items3 (cdr items3)))))
+ (setq items2 (cdr items1))
+ (when (consp items3)
+ (setq item1 item3 item3 (car items3))
+ (go LOOP2)))
+ (t (setq items1 items2 items2 items3)
+ (when (consp (setq items3 (cdr items3)))
+ (setq item1 item2 item2 item3 item3 (car items3))
+ (go LOOP2))))))
+
+ templist-1)
+
+;;;-------------------------------------------------------------
+;;; PATHLENGTH-INTEGRATE is only called if RAY-ALPHALIST is a non-NIL list,
+;;; meaning that the ray passes through the patient. If called on null ray,
+;;; it returns an effective pathlength of zero. Function return value is
+;;; flag indicating whether dosepoint is inside body or not.
+
+(defun pathlength-integrate (arg-vec ray-alphalist organ-density-array
+ homogeneity-mode
+ &aux (ray-length (aref arg-vec #.Argv-Raylen))
+ homogeneous? heterogeneous?)
+
+ "pathlength-integrate arg-vec ray-alphalist organ-density-array
+ homogeneity-mode
+
+computes tissue-equivalent-pathlength from source to dose-point (given this
+distance as the Argv-Raylen slot of ARG-VEC) from descriptor generated by
+PATHLENGTH-RAYTRACE. If HOMOGENEITY-MODE is :Heterogeneous, the function
+includes densities in the anatomic structures; if :Homogeneous, assumes them
+to be 1.0, giving Euclidean distance from patient surface to dose-point along
+the beam; and if :Both it does both calculations. Returns effective pathlength
+whether ray intersects patient or not [zero if not]; returns homogeneous result
+in ARG-VEC Argv-Return-0 and density-corrected result in slot Argv-Return-1.
+Function returns T or NIL indicating whether dosepoint is inside body or not."
+
+ (declare (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type (simple-array single-float 1) organ-density-array)
+ (type list ray-alphalist)
+ (type (member :Homogeneous :Heterogeneous :Both) homogeneity-mode)
+ (type (member nil t) homogeneous? heterogeneous?)
+ (type single-float ray-length))
+
+ (cond ((eq homogeneity-mode :Heterogeneous)
+ (setq heterogeneous? t))
+ ((eq homogeneity-mode :Both)
+ (setq homogeneous? t heterogeneous? t))
+ (t (setq homogeneous? t)))
+
+ (do ((last-alpha 0.0 current-alpha)
+ (strctr-stack (list 0))
+ (alpha-pairlist ray-alphalist (cdr alpha-pairlist))
+ (alpha-item) (homogeneous-sum 0.0) (heterogeneous-sum 0.0)
+ (current-alpha 0.0) (strctr-tag 0) (strctr-tag-pop 0))
+ ((null alpha-pairlist)
+ (setf (aref arg-vec #.Argv-Return-0) homogeneous-sum)
+ (setf (aref arg-vec #.Argv-Return-1) heterogeneous-sum)
+ nil) ;Dosepoint outside patient.
+
+ (declare (type list strctr-stack alpha-pairlist alpha-item)
+ (type single-float last-alpha current-alpha
+ homogeneous-sum heterogeneous-sum)
+ (type fixnum strctr-tag strctr-tag-pop))
+
+ (setq alpha-item (car alpha-pairlist)
+ current-alpha (car alpha-item)
+ strctr-tag (cdr alpha-item)
+ strctr-tag-pop (car strctr-stack))
+
+ (cond ((< current-alpha ray-length)
+ (cond ((= strctr-tag strctr-tag-pop)
+ (setq strctr-stack (cdr strctr-stack)))
+ (t (push strctr-tag strctr-stack))))
+
+ ((cdr strctr-stack) ;Dosepoint inside patient.
+ (when homogeneous?
+ (incf homogeneous-sum (the single-float
+ (* (- ray-length last-alpha)
+ (if (= strctr-tag-pop 0) 0.0 1.0)))))
+ (when heterogeneous?
+ (incf heterogeneous-sum
+ (the single-float
+ (* (- ray-length last-alpha)
+ (the single-float
+ (aref organ-density-array strctr-tag-pop))))))
+ (setf (aref arg-vec #.Argv-Return-0) homogeneous-sum)
+ (setf (aref arg-vec #.Argv-Return-1) heterogeneous-sum)
+ (return t))
+
+ ;; Done - dosepoint outside patient, but ray may or may not
+ ;; have passed through patient.
+ (t (setf (aref arg-vec #.Argv-Return-0) homogeneous-sum)
+ (setf (aref arg-vec #.Argv-Return-1) heterogeneous-sum)
+ (return nil)))
+
+ (when homogeneous?
+ (incf homogeneous-sum (the single-float
+ (* (- current-alpha last-alpha)
+ (if (= strctr-tag-pop 0) 0.0 1.0)))))
+ (when heterogeneous?
+ (incf heterogeneous-sum
+ (the single-float
+ (* (- current-alpha last-alpha)
+ (the single-float
+ (aref organ-density-array strctr-tag-pop))))))))
+
+;;;-------------------------------------------------------------
+
+(defun remove-duplicates-by-pairs (intersec-list)
+
+ ;; Remove [destructively] duplicate entries from the sorted INTERSEC-LIST
+ ;; by pairs - two at a time.
+ (do ((prev-cons nil) ;CONS one back - for splicing its CDR
+ (test-cons intersec-list) ;CONS containing first element of comparison.
+ ;; CONS containing second element of comparison.
+ (next-cons (cdr intersec-list)))
+ ((null next-cons)
+ intersec-list)
+ (cond ((= (the single-float (car test-cons))
+ (the single-float (car next-cons)))
+ (cond ((consp prev-cons)
+ (setf (cdr prev-cons) (setq test-cons (cdr next-cons))))
+ (t (setq intersec-list (cdr next-cons)
+ test-cons intersec-list)))
+ (setq next-cons (cdr test-cons)))
+ (t (setq prev-cons test-cons
+ test-cons next-cons
+ next-cons (cdr next-cons))))))
+
+;;;=============================================================
+;;; Ray-edge crossing-counter algorithm.
+;;; Fast version - calculates only one ray.
+
+(defun encloses? (vlist arg-vec &aux (px (aref arg-vec #.Argv-Enc-X))
+ (py (aref arg-vec #.Argv-Enc-Y)))
+
+ ;; As VLIST is an open list representing a closed contour, there is an
+ ;; implied edge present from last to first vertex. Traversal can be in
+ ;; either direction, CW or CCW.
+
+ (declare (type list vlist)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type single-float px py))
+
+ (do ((verts vlist (or (cdr verts) vlist))
+ (endmarker (cdr vlist))
+ (vert) ;Actual Vertex
+ (bx 0.0) (by 0.0) ;Coords of BACK point
+ (mx 0.0) (my 0.0) ;Coords of CURRENT point
+ (fx 0.0) (fy 0.0) ;Coords of FWD point
+ (mxby 0.0) (bxmy 0.0) ;Cross-terms
+ (back-point nil) ;Status flag
+ ;; Axis-ray crosser - known which half - parity counts:
+ (x+ nil))
+ ((and (eq back-point :Done)
+ (eq verts endmarker))
+ x+)
+
+ (declare (type list verts vert endmarker)
+ (type (member nil :Set :Done) back-point)
+ (type (member nil t) x+)
+ (type single-float bx by mx my fx fy mxby bxmy))
+
+ (when (eq back-point :Set)
+ (setq back-point :Done))
+
+ (setq vert (car verts)
+ mx (- (the single-float (first vert)) px)
+ my (- (the single-float (second vert)) py))
+
+ (cond ((and (= mx 0.0) (= my 0.0))
+ ;; If any vertex matches test point, return T.
+ (return t))
+
+ ;; If test point is on test ray, then if vertex before and vertex
+ ;; after current are on same side of ray, pull current vertex an "
+ ;; infinitessimal" distance away in same direction. Otherwise [
+ ;; contour crosses test ray at current vertex] push current vertex
+ ;; an "infinitessimal" distance in other direction. Thus MX and
+ ;; therefore BX never are exactly zero in decision tree to follow.
+ ((= mx 0.0)
+ (setq vert (or (second verts) (first vlist))
+ fx (- (the single-float (first vert)) px))
+ (cond ((> bx 0.0)
+ (cond ((>= fx 0.0)
+ (incf mx 1.0e-8))
+ (t (decf mx 1.0e-8))))
+ ((<= fx 0.0)
+ (decf mx 1.0e-8))
+ (t (incf mx 1.0e-8))))
+
+ ;; Exactly equivalent logic but interchanging X and Y axes.
+ ((= my 0.0)
+ (setq vert (or (second verts) (first vlist))
+ fy (- (the single-float (first vert)) py))
+ (cond ((> by 0.0)
+ (cond ((>= fy 0.0)
+ (incf my 1.0e-8))
+ (t (decf my 1.0e-8))))
+ ((<= fy 0.0)
+ (decf my 1.0e-8))
+ (t (incf my 1.0e-8)))))
+
+ (cond ((null back-point)
+ ;; Preset BX, BY on first iter only - will never = 0.0 exactly.
+ (setq bx mx by my back-point :Set))
+
+ ;; Decision tree testing contour-segment/test-ray crossings.
+ ((> mx 0.0)
+ (cond ((> my 0.0)
+ (cond ((< by 0.0)
+ (cond ((> bx 0.0)
+ (setq x+ (not x+)))
+ ((= (setq mxby (* mx by))
+ (setq bxmy (* bx my)))
+ (return t))
+ ((< mxby bxmy)
+ (setq x+ (not x+)))))))
+ ((> by 0.0)
+ (cond ((> bx 0.0)
+ (setq x+ (not x+)))
+ ((= (setq mxby (* mx by))
+ (setq bxmy (* bx my)))
+ (return t))
+ ((> mxby bxmy)
+ (setq x+ (not x+))))))
+ (setq bx mx by my))
+
+ ((> my 0.0)
+ (cond ((< by 0.0)
+ (cond ((< bx 0.0))
+ ((= (setq mxby (* mx by))
+ (setq bxmy (* bx my)))
+ (return t))
+ ((< mxby bxmy)
+ (setq x+ (not x+))))))
+ (setq bx mx by my))
+
+ ((> by 0.0)
+ (cond ((< bx 0.0))
+ ((= (setq mxby (* mx by))
+ (setq bxmy (* bx my)))
+ (return t))
+ ((> mxby bxmy)
+ (setq x+ (not x+))))
+ (setq bx mx by my))
+
+ (t (setq bx mx by my)))))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/patient-panels.cl b/prism/src/patient-panels.cl
new file mode 100644
index 0000000..dbf44bd
--- /dev/null
+++ b/prism/src/patient-panels.cl
@@ -0,0 +1,664 @@
+;;;
+;;; patient-panels
+;;;
+;;; The Prism patient-panel class and associated functions.
+;;;
+;;; 27-Feb-1993 I. Kalet created from patients module, add new case
+;;; selection, rearrange init. to facilitate switch to new case
+;;; without destroying panel and making a new one.
+;;; 4-Aug-1993 I. Kalet add comments textline, change name, hospital
+;;; id to readouts, add date-entered readout, checkpoint database buttons.
+;;; 26-Oct-1993 I. Kalet pass new cached mini-image-set to easel
+;;; 01-Nov-1993 J. Unger add references to *save-plan-dose* to checkpoint fn
+;;; 13-Dec-1993 M. Phillips and J. Unger Changed tools-panel to
+;;; tools-panel-action and changed the arguments of tools-panel from
+;;; pan to (the-patient pan).
+;;; 27-Apr-1994 J. Unger enhance target selector panel button to give
+;;; 3-way choice over creation of new targets.
+;;; 8-Jun-1994 J. Unger add *current-patient* global variable,
+;;; eliminate *save-plan-dose* mechanism for saving dose info, do not
+;;; provide lin-expand/ptvt choices when creating a target if no
+;;; tumors exist or none has more than 2 contours.
+;;; 12-Mar-1995 I. Kalet pass patient to plan panel. Eliminate
+;;; vestigial exiting event. Delete plans in replace-patient-case
+;;; to free up X resources in old plan views. Keep
+;;; patient-plan-manager here, not in patient.
+;;; 27-Apr-1995 I. Kalet add patient number to patient name display,
+;;; make timestamp border change to red when set, back to white when
+;;; case is archived or checkpointed.
+;;; 5-Jun-1995 I. Kalet destroy and recreate grid-view manager for
+;;; new case here, after reading in from case file, since initially
+;;; plan connects views with a default grid, and reading the file
+;;; replaces it. Same for pointers to dose-grid in the dose surfaces.
+;;; 25-Jul-1995 I. Kalet implement confirm box for replacing patient
+;;; case, per spec.
+;;; 3-May-1997 I. Kalet always use *patient-database* for patient
+;;; list, regardless of archive or checkpoint, provide option of
+;;; entering a patient name string or number to restrict the patient
+;;; menu, and prevent storage of patient 0, provide option of an
+;;; alternate checkpoint database directory for retrieve, change call
+;;; to make-plan-panel to conform to new signature.
+;;; 25-Jun-1997 I. Kalet move organs, tumors and targets selector
+;;; panels to the volume editor, register with new-immob-dev to
+;;; update the copy in the volume editor when it changes, fix bug in
+;;; connect-pat-panel on timestamp border color, take out patient-plan
+;;; mgr, this is now incorporated back into the patient case itself.
+;;; 28-Jun-1997 I. Kalet add call to panel fns. for pat db and irreg
+;;; 7-Sep-1997 I. Kalet in replace-patient-case for other than main
+;;; patient database, list only patients with cases present.
+;;; 9-Nov-1997 I. Kalet always use *patient-database* with
+;;; get-patient-entry because that is where patient.index is.
+;;; 28-Apr-1998 I. Kalet set patient name and hospital ID from patient
+;;; index here, not in get-case-data, because need *patient-database*
+;;; 17-Jun-1998 I. Kalet force global gc after reading in new case,
+;;; cosmetic changes, after checking consistency of mediator
+;;; registrations and cleanups.
+;;; 3-Nov-1998 C. Wilcox added DVH button.
+;;; 25-Feb-1999 I. Kalet if no patient selected don't ask if ok to
+;;; select new one, just do it. Also clean up dvh panels on exit.
+;;; 11-May-1999 I. Kalet when retrieving from checkpoint db, if user
+;;; presses cancel in the checkpoint db textline, really cancel, don't
+;;; use the default checkpoint db.
+;;; 6-Apr-2000 I. Kalet connect initial patient case to
+;;; *current-patient* in make-patient-panel, don't wait for first setf.
+;;; Add more informative messages for failure to archive or checkpoint.
+;;; Add source table mgr button here instead of brachy source entry panel.
+;;; 30-May-2000 I. Kalet change background to gray, add shaded raised
+;;; buttons and lowered textbox.
+;;; 29-Jun-2000 I. Kalet change "RTPT Tools" to "Other Tools" - there
+;;; has not been any RTPT stuff here for a while.
+;;; 26-Nov-2000 I. Kalet default background is now gray and defaults
+;;; for widgets are already appropriate, so remove from here.
+;;; 31-Dec-2001 I. Kalet use match string for Retrieve as well as Select
+;;; 4-Jan-2002 I. Kalet make comments textbox slightly higher to
+;;; accomodate the bottom line.
+;;; 21-Jun-2004 I. Kalet make panel title include Prism version
+;;; number, parametrize choice of checkpoint directory for retrieve,
+;;; allowing for a shared checkpoint directory and a list of
+;;; alternates in addition to user's own, remove IRREG button, IRREG
+;;; is no longer supported.
+;;; 25-Oct-2004 I. Kalet remove POINTS button - points panel merged
+;;; with volume editor.
+;;; 1-Jun-2009 I. kalet remove ref to mini-images. Filmstrip uses
+;;; original images, not precomputed mini-images.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defvar *current-patient* nil "A reference to the current patient, to be
+used strictly for debugging purposes.")
+
+;;;---------------------------------------------
+
+(defclass patient-panel (generic-panel)
+
+ ((the-patient :initarg :the-patient
+ :accessor the-patient
+ :documentation "The patient that this panel edits.")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame containing all the
+panel stuff.")
+
+ (exit-b :accessor exit-b
+ :documentation "The Exit button.")
+
+ (select-b :accessor select-b
+ :documentation "The new patient selection button.")
+
+ (archive-b :accessor archive-b
+ :documentation "The archive button.")
+
+ (retrieve-b :accessor retrieve-b
+ :documentation "The patient selection button for the
+checkpoint database.")
+
+ (ckpt-b :accessor ckpt-b
+ :documentation "The checkpoint database button.")
+
+ (image-b :accessor image-b
+ :documentation "The image study selection/load button.")
+
+ (immob-b :accessor immob-b
+ :documentation "The Immob. Device button")
+
+ (tools-b :accessor tools-b
+ :documentation "The RTPT software tools button")
+
+ (dbmgr-b :accessor dbmgr-b
+ :documentation "The database manager panel button")
+
+ (srctable-b :accessor srctable-b
+ :documentation "The brachytherapy source table manager
+panel button")
+
+ (dvh-b :accessor dvh-b
+ :documentation "The DVH Panel button")
+
+ (anatomy-b :accessor anatomy-b
+ :documentation "The button that brings up a volume
+editor for organs, tumors, targets and points for this patient.")
+
+ (name-box :accessor name-box
+ :documentation "The readout for the patient name and
+hospital ID. They are not changed via the patient panel.")
+
+ (timestamp-box :accessor timestamp-box
+ :documentation "The readout for the date-entered
+timestamp.")
+
+ (comments-box :accessor comments-box
+ :documentation "The textbox containing the comments
+text for this patient case.")
+
+ (comments-btn :accessor comments-btn
+ :documentation "The Accept button for accepting the
+text in the comments box, i.e., making an update to the patient
+comments slot.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "The mediator busy bit for updates to
+textlines.")
+
+ (plan-selector :accessor plan-selector
+ :documentation "The selector panel listing the plans
+for this patient.")
+
+ (volume-editor-pan :accessor volume-editor-pan
+ :documentation "The volume-editor panel created
+from this panel.")
+
+ (point-editor-pan :accessor point-editor-pan
+ :documentation "The 3d-point-editor panel created
+from this panel.")
+
+ (db-pan :accessor db-pan
+ :documentation "The patient database manager panel")
+
+ (dvh-pans :accessor dvh-pans
+ :documentation "A list of currently open DVH panels.")
+
+ )
+
+ )
+
+;;;---------------------------------------
+
+(defmethod (setf the-patient) :after (pat (pp patient-panel))
+
+ "Sets the current patient to a global variable, for debugging only."
+
+ (setq *current-patient* pat))
+
+;;;---------------------------------------
+
+(defun connect-pat-panel (pp)
+
+ "connect-pat-panel pp
+
+initializes the textlines and other patient specific stuff so a new
+case is set up in the patient panel pp."
+
+ (let* ((pan-fr (panel-frame pp))
+ (pp-win (sl:window pan-fr))
+ (width (sl:width pan-fr))
+ (height (sl:height pan-fr))
+ (sp-width 150) ;; width of plans selector panel
+ (sp-height 205) ;; height of " " - not the same everywhere
+ (p (the-patient pp)))
+ (setf (sl:info (name-box pp)) (concatenate 'string
+ (format nil "~A" (patient-id p))
+ " " (name p) " " (hospital-id p))
+ (sl:info (timestamp-box pp)) (date-entered p)
+ (sl:border-color (timestamp-box pp)) 'sl:white
+ (sl:info (comments-box pp)) (comments p)
+ ;; the immob device string labels the corresp. button
+ (sl:label (immob-b pp)) (first (find (immob-device p)
+ *immob-devices*
+ :key #'second)))
+ (ev:add-notify pp (new-date p)
+ #'(lambda (pan pt info)
+ (declare (ignore pt))
+ (setf (sl:info (timestamp-box pan)) info)
+ (setf (sl:border-color (timestamp-box pan))
+ 'sl:red)))
+ (ev:add-notify pp (new-comments p)
+ #'(lambda (pan pt info)
+ (declare (ignore pt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (comments-box pan)) info)
+ (setf (busy pan) nil))))
+ (setf (plan-selector pp)
+ (make-selector-panel sp-width sp-height
+ "Add a plan" (plans p)
+ #'make-plan
+ #'(lambda (pln) (make-plan-panel pln p))
+ :parent pp-win
+ :ulc-x (- width 10 sp-width)
+ :ulc-y (- height 10 sp-height)))))
+
+;;;---------------------------------------
+
+(defun replace-patient-case (pan &optional (database
+ *patient-database*))
+
+ "replace-patient-case pan &optional (database *patient-database*)
+
+replaces the patient in the patient panel pan with a new case selected
+from the available ones in the specified database. If no new patient
+or case is selected the function makes no change in the panel. If a
+new case is selected the old case is discarded, and the panel is
+reinitialized with the new case. The patient list is either from
+*patient-database* or generated based on the patients with entries in
+the case index of the specified database. The value of database
+determines the source for the case data and case list."
+
+ (when (or (/= (case-id (the-patient pan)) 0)
+ (= (patient-id (the-patient pan)) 0)
+ (sl:confirm ;; if case-id is 0, case not archived so warn
+ '("Current case not archived or checkpointed"
+ "Selecting a new case will destroy current data")))
+ (let* ((match-string (or (sl:popup-textline
+ "" 300
+ :label "Match with: "
+ :title "Patient search string")
+ ""))
+ (pat-id (if (equal database *patient-database*)
+ (select-patient database match-string)
+ (select-patient-from-case-list *patient-database*
+ database match-string)))
+ (case-id (if pat-id (select-case pat-id database)))
+ (new-case (if case-id (get-case-data pat-id case-id
+ database))))
+ (when new-case ;; this includes case-id = 0, but not "Cancel"
+ (let ((patient-entry (get-patient-entry pat-id
+ *patient-database*)))
+ ;; use name, ids from patient index
+ (setf (name new-case) (second patient-entry)
+ (hospital-id new-case) (third patient-entry)))
+ (setf (sl:info (name-box pan)) "")
+ (setf (sl:info (timestamp-box pan)) "")
+ (setf (sl:info (comments-box pan)) '(""))
+ (if (sl:on (anatomy-b pan)) (setf (sl:on (anatomy-b pan)) nil))
+
+ ;; free X resources for the dvh-panels before removing the
+ ;; elements in the plan-set to avoid doing a refresh of the
+ ;; dvh plots for each plan that is removed
+ (dolist (dvhp (dvh-pans pan))
+ (destroy dvhp))
+ (setf (dvh-pans pan) nil)
+
+ (let ((plan-set (plans (the-patient pan))))
+ (dolist (pln (coll:elements plan-set)) ;; frees X resources
+ (coll:delete-element pln plan-set))) ;; of any views
+ (destroy (plan-selector pan))
+ (setf (the-patient pan) new-case)
+ (connect-pat-panel pan)
+ #+allegro (excl:gc t)
+ ))))
+
+;;;---------------------------------------
+
+(defun make-patient-panel (pat &rest initargs)
+
+ "make-patient-panel pat &rest initargs
+
+returns an instance of a patient panel for the patient pat."
+
+ (setq *current-patient* pat)
+ (apply #'make-instance 'patient-panel :the-patient pat initargs))
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((pp patient-panel)
+ &rest initargs)
+
+ (let* ((box-width 440) ;; width of comments box, pat. name textline
+ (box-height 85) ;; height of comments box
+ (bth 30) ;; button and textline height
+ (btw 135) ;; button width
+ (dx 10) ;; left margin
+ (dx2 (+ dx btw 5)) ;; comments box and 2nd button column
+ (top-y 10) ;; y position of top readout, textline or button
+ ;; buttons other than EXIT are at mid-y
+ (mid-y (+ top-y (* 2 bth) box-height 20))
+ (pan-fr (apply #'sl:make-frame (+ box-width 20) 390 ;; 425
+ :title (format nil "Prism RTP System ~A"
+ *prism-version-string*)
+ initargs))
+ (pp-win (sl:window pan-fr))
+ ;; bp-y function defined in prism-objects - button-placement-y
+ (ex-b (apply #'sl:make-exit-button btw bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 1)
+ :label "EXIT PRISM"
+ :confirm-exit "EXIT your Prism session?"
+ :parent pp-win initargs))
+ ;; buttons in the first column
+ (sel-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y mid-y
+ :label "Select"
+ :parent pp-win initargs))
+ (arc-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 1)
+ :label "Archive"
+ :parent pp-win initargs))
+ (ret-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 2)
+ :label "Retrieve"
+ :parent pp-win initargs))
+ (ckp-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 3)
+ :label "Checkpt"
+ :parent pp-win initargs))
+ (db-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 4)
+ :label "Pat DB mgr"
+ :parent pp-win initargs))
+ (src-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y mid-y bth 5)
+ :fg-color 'sl:red
+ :label "Brachy src mgr"
+ :parent pp-win initargs))
+ ;; buttons in second column
+ (cmt-b (apply #'sl:make-button btw bth
+ :ulc-x dx2 :ulc-y mid-y
+ :label "Accept cmts"
+ :parent pp-win initargs))
+ (im-b (apply #'sl:make-button btw bth
+ :ulc-x dx2 :ulc-y (bp-y mid-y bth 1)
+ :label "Image study"
+ :button-type :momentary
+ :parent pp-win initargs))
+ (vols-b (apply #'sl:make-button btw bth
+ :ulc-x dx2 :ulc-y (bp-y mid-y bth 2)
+ :label "Anatomy/points"
+ :parent pp-win initargs))
+ (dvhist-b (apply #'sl:make-button btw bth
+ :ulc-x dx2 :ulc-y (bp-y mid-y bth 3)
+ :label "DVH"
+ :button-type :momentary
+ :parent pp-win initargs))
+ (immob-b (apply #'sl:make-button btw bth
+ :ulc-x dx2 :ulc-y (bp-y mid-y bth 4)
+ :parent pp-win initargs))
+ (tls-b (apply #'sl:make-button btw bth
+ :ulc-x dx2 :ulc-y (bp-y mid-y bth 5)
+ :label "Other Tools"
+ :parent pp-win initargs))
+ ;; readouts and textlines
+ (name-r (apply #'sl:make-readout box-width bth
+ :ulc-x dx :ulc-y top-y
+ :parent pp-win initargs))
+ (date-r (apply #'sl:make-readout 200 bth
+ :ulc-x 250 :ulc-y (bp-y top-y bth 1)
+ :parent pp-win initargs))
+ (comments-t (apply #'sl:make-textbox box-width box-height
+ :ulc-x dx :ulc-y (bp-y top-y bth 2)
+ :parent pp-win initargs)))
+ (setf (panel-frame pp) pan-fr ;; put all the widgets in the slots
+ (name-box pp) name-r
+ (exit-b pp) ex-b
+ (timestamp-box pp) date-r
+ (comments-box pp) comments-t
+ (select-b pp) sel-b
+ (archive-b pp) arc-b
+ (retrieve-b pp) ret-b
+ (ckpt-b pp) ckp-b
+ (dbmgr-b pp) db-b
+ (srctable-b pp) src-b
+ (dvh-b pp) dvhist-b
+ (dvh-pans pp) nil
+ (comments-btn pp) cmt-b
+ (image-b pp) im-b
+ (anatomy-b pp) vols-b
+ (immob-b pp) immob-b
+ (tools-b pp) tls-b)
+ (ev:add-notify pp (sl:new-info comments-t)
+ #'(lambda (pan tb)
+ (declare (ignore tb))
+ (unless (sl:on (comments-btn pan))
+ (setf (sl:on (comments-btn pan)) t))))
+ (ev:add-notify pp (sl:button-on sel-b)
+ #'(lambda (panel button)
+ (replace-patient-case panel *patient-database*)
+ (setf (sl:on button) nil)))
+ (ev:add-notify pp (sl:button-on arc-b)
+ #'(lambda (pan button)
+ (let ((pat (the-patient pan)))
+ (if (= (patient-id pat) 0)
+ (sl:acknowledge
+ '("No patient selected yet in this session"
+ "You must first select a patient case"))
+ (if (put-case-data pat *patient-database*)
+ (progn (sl:acknowledge
+ "Case saved in archive")
+ (setf (sl:border-color
+ (timestamp-box pan))
+ 'sl:white))
+ (sl:acknowledge
+ '("Archive not possible"
+ "No changes made to this case"
+ "since last archive or checkpoint")))))
+ (setf (sl:on button) nil)))
+ (ev:add-notify pp (sl:button-on ret-b)
+ #'(lambda (panel button)
+ ;; retrieve from anywhere: own, shared or others
+ (let* ((items (cons (list "My own storage"
+ *local-database*)
+ (cons (list "Shared storage"
+ *shared-database*)
+ *other-databases*)))
+ (sel (sl:popup-menu
+ (mapcar #'first items)
+ :default 0 ;; first item
+ :title "Checkpoint database")))
+ (when sel
+ (replace-patient-case panel
+ (second (nth sel items)))))
+ (setf (sl:on button) nil)))
+ (ev:add-notify pp (sl:button-on ckp-b)
+ #'(lambda (pan button)
+ (let ((pat (the-patient pan)))
+ (if (= (patient-id pat) 0)
+ (sl:acknowledge
+ '("No patient selected yet in this session"
+ "You must first select a patient case"))
+ ;; checkpoint only to own or shared, not others
+ (let* ((items (list (list "My own storage"
+ *local-database*)
+ (list "Shared storage"
+ *shared-database*)))
+ (sel (sl:popup-menu
+ (mapcar #'first items)
+ :default 0 ;; first item
+ :title "Checkpoint database")))
+ (when sel
+ (if (put-case-data pat (second (nth sel items)))
+ (progn
+ (sl:acknowledge
+ "Case saved in checkpoint area")
+ (setf (sl:border-color
+ (timestamp-box pan))
+ 'sl:white))
+ (sl:acknowledge
+ '("Checkpoint not possible"
+ "No changes made to this case"
+ "since last archive or checkpoint")))))))
+ (setf (sl:on button) nil)))
+ (ev:add-notify pp (sl:button-on db-b)
+ #'(lambda (pan btn)
+ (let ((dbp (make-patdb-panel)))
+ (setf (db-pan pan) dbp)
+ (ev:add-notify pan (deleted dbp)
+ #'(lambda (pn dp)
+ (ev:remove-notify pn
+ (deleted dp))
+ (setf (db-pan pn) nil)
+ (when (not (busy pn))
+ (setf (busy pn) t)
+ (setf (sl:on btn) nil)
+ (setf (busy pn) nil)))))))
+ (ev:add-notify pp (sl:button-off db-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (db-pan pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (sl:button-on src-b)
+ #'(lambda (pan bt)
+ (declare (ignore pan))
+ (brachy-table-manager)
+ (setf (sl:on bt) nil)))
+ (ev:add-notify pp (sl:button-off cmt-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (setf (comments (the-patient pan))
+ (sl:info (comments-box pan)))))
+ (ev:add-notify pp (sl:button-on im-b)
+ #'(lambda (pan btn)
+ (let* ((pat (the-patient pan))
+ (im-id (image-set-id pat))
+ (pat-id (patient-id pat)))
+ (if (> im-id 0) ;; image set was already selected
+ (if (not (image-set pat)) ;; so load it
+ (setf (image-set pat)
+ (get-image-set pat-id im-id
+ *image-database*)))
+ ;; otherwise list studies and select one
+ (let ((new-im-id (select-image-set
+ pat-id
+ *image-database*)))
+ (when new-im-id
+ (setf (image-set-id pat) new-im-id)
+ (setf (image-set pat)
+ (get-image-set pat-id
+ new-im-id
+ *image-database*))))))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify pp (sl:button-on dvhist-b)
+ #'(lambda (pan btn)
+ (if (= (patient-id (the-patient pan)) 0)
+ (sl:acknowledge
+ '("No patient selected yet in this session"
+ "You must first select a patient case"))
+ ;;if there is an active patient...
+ (let* ((curpat (the-patient pan))
+ (oblist (append
+ (coll:elements (anatomy curpat))
+ (coll:elements (targets curpat))
+ (coll:elements (findings curpat))))
+ (selection (sl:popup-menu
+ (mapcar #'name oblist))))
+ (when selection
+ (let ((newpan (make-instance 'dvh-panel
+ :object (nth selection oblist)
+ :plan-coll (plans curpat)
+ :the-patient curpat)))
+ (push newpan (dvh-pans pan))
+ (ev:add-notify
+ pan (sl:button-on (del-pan-b newpan))
+ #'(lambda (pp btn)
+ (declare (ignore btn))
+ (format t "remove panel...~%")
+ (format t "length dvh-pans = ~s~%"
+ (length (dvh-pans pp)))
+ (setf (dvh-pans pp)
+ (remove newpan
+ (dvh-pans pp)))
+ (format t "length dvh-pans = ~s~%"
+ (length (dvh-pans pp)))))
+ (format t "dvh-pans = ~s~%" (dvh-pans pan))
+ ))))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify pp (sl:button-on vols-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (let* ((pat (the-patient pan))
+ (ved (make-volume-editor
+ :width (+ *easel-size* 320)
+ :images (image-set pat)
+ :immob-dev (immob-device pat)
+ :organ-coll (anatomy pat)
+ :tumor-coll (findings pat)
+ :target-coll (targets pat)
+ :point-coll (points pat))))
+ (setf (volume-editor-pan pan) ved)
+ (ev:add-notify ved (new-immob-dev pat)
+ #'(lambda (ve pat new-immob)
+ (declare (ignore pat))
+ (setf (immob-dev ve)
+ new-immob)))
+ (ev:add-notify pan (deleted ved)
+ #'(lambda (pn ve)
+ (ev:remove-notify
+ ve (new-immob-dev
+ (the-patient pn)))
+ (ev:remove-notify pn
+ (deleted ve))
+ (setf (volume-editor-pan pn)
+ nil)
+ (when (not (busy pn))
+ (setf (busy pn) t)
+ (setf (sl:on (anatomy-b pn))
+ nil)
+ (setf (busy pn) nil)))))))
+ (ev:add-notify pp (sl:button-off vols-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (volume-editor-pan pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (sl:button-on immob-b)
+ #'(lambda (pan btn)
+ (let* ((items (mapcar #'first *immob-devices*))
+ (item-no (sl:popup-menu items)))
+ (if item-no ;; could be nil - no selection
+ (let ((selection (nth item-no
+ *immob-devices*)))
+ (setf (immob-device (the-patient pan))
+ (second selection))
+ (setf (sl:label btn) (first selection))))
+ (setf (sl:on btn) nil))))
+ (ev:add-notify pp (sl:button-on tls-b)
+ #'(lambda (pan btn)
+ (tools-panel (the-patient pan))
+ (setf (sl:on btn) nil)))
+ (connect-pat-panel pp)))
+
+;;;-----------------------------------------
+
+(defmethod destroy :before ((pp patient-panel))
+
+ "releases X resources used by this panel and its children."
+
+ (dolist (dvhp (dvh-pans pp))
+ (destroy dvhp))
+ (sl:destroy (dvh-b pp))
+ (sl:destroy (exit-b pp))
+ (sl:destroy (select-b pp))
+ (sl:destroy (archive-b pp))
+ (sl:destroy (retrieve-b pp))
+ (sl:destroy (ckpt-b pp))
+ (sl:destroy (image-b pp))
+ (sl:destroy (immob-b pp))
+ (sl:destroy (tools-b pp))
+ (if (sl:on (anatomy-b pp)) (setf (sl:on (anatomy-b pp)) nil))
+ (sl:destroy (anatomy-b pp))
+ (sl:destroy (name-box pp))
+ (sl:destroy (timestamp-box pp))
+ (sl:destroy (comments-box pp))
+ (sl:destroy (comments-btn pp))
+ (destroy (plan-selector pp))
+ (sl:destroy (panel-frame pp))
+ (let ((pat (the-patient pp)))
+ (ev:remove-notify pp (new-date pat))
+ (ev:remove-notify pp (new-comments pat))
+ (ev:remove-notify pp (new-immob-dev pat))))
+
+;;;-----------------------------------------
diff --git a/prism/src/patients.cl b/prism/src/patients.cl
new file mode 100644
index 0000000..abca338
--- /dev/null
+++ b/prism/src/patients.cl
@@ -0,0 +1,466 @@
+;;;
+;;; patients
+;;;
+;;; The Prism patient class and associated functions.
+;;;
+;;; 1-Aug-1992 I. Kalet created from rtp-objects
+;;; 30-Nov-1992 I. Kalet cache table-position in plan when created,
+;;; update plans when t-p is updated, set llc-anatomy and urc-anatomy
+;;; to 0.0's if there is no anatomy.
+;;; 16-Dec-1992 I.Kalet/J. Unger pass anatomy, tumors and targets sets
+;;; to plans when they are created so the stuff can be displayed in
+;;; views, also add images to plans when creating.
+;;; 31-Dec-1992 I. Kalet let plan create image-view-manager, add
+;;; action function to create anatomy managers when plan added to
+;;; plans set.
+;;; 1-Mar-1993 I. Kalet split off patient-panels separate module,
+;;; delete history pertaining to panels.
+;;; 11-Apr-1993 I. Kalet create new image-managers here when adding
+;;; plans to plan set. No organ sets etc. in plans so don't forward
+;;; 3-Aug-1993 I. Kalet eliminate new-hospid, because hospid not
+;;; editable in Prism patient panel. Add auto update of date-entered
+;;; when contours etc. change. Don't save name, hospital id since
+;;; they are gotten from patient index file. Add new-date event.
+;;; 18-Oct-1993 J. Unger cache organs and marks in plan when created.
+;;; 20-Oct-1993 J. Unger initialize a plan's dose specification
+;;; manager when plan is added to patient's plan collection.
+;;; 26-Oct-1993 I. Kalet add mini-image-set cache for performance.
+;;; 29-Oct-1993 J. Unger set dose-grid, result, and name attributes of
+;;; each of a plan's dose surfaces to the plan's dose-grid, the plan's
+;;; sum-dose, and the dose surface's threshold respectively, when the
+;;; plan is inserted into the patient's collection of plans.
+;;; 05-Nov-1993 J. Unger add code to set a plan's patient-id and
+;;; case-id attributes when it is added to the patient's collection of
+;;; plans. Also add patient-id and case-id to patient's not-saved
+;;; method, and add a setf :after method for case-id to set the
+;;; case-id of each plan when patient's case-id changes.
+;;; 3-Jan-1994 I. Kalet plans and beams now have back-pointers, so
+;;; don't forward stuff to plans, just set back-pointer to patient.
+;;; 27-May-1994 J. Unger set default immob dev from *immob-device* list
+;;; 02-Jun-1994 J. Unger update case when points change, comments, or
+;;; the name of the case changes.
+;;; 21-Jun-1994 I. Kalet declare date-entered to be slot type
+;;; :timestamp and remove setf method for name.
+;;; 30-Jun-1994 I. Kalet always set a new table-position to the origin.
+;;; 29-Aug-1994 J. Unger minor adj to patient class def to fix bug
+;;; involving 'old' info in comments box when new patient is selected.
+;;; 07-Sep-1994 J. Unger add registration for points' new-name and
+;;; new-loc events so patient timestamp can update.
+;;; 12-Mar-1995 I. Kalet modify for patient-plan-mediators, add
+;;; new-image-set event (back-pointers eliminated somewhere in here).
+;;; 21-Jan-1997 I. Kalet eliminate table-position, urc-anat and
+;;; llc-anat attributes and methods, leave latter two as functions.
+;;; Also eliminate refs. to geometry package. Use vector accessor
+;;; macros from misc.
+;;; 25-Jun-1997 I. Kalet merge patient-plan-mediators back into this
+;;; module, keep the set here, not in a "manager" in patient panel.
+;;; 3-Oct-1997 BobGian inline-expand LO-HI-COMPARE and fix result in
+;;; LLC-ANAT and URC-ANAT to make it cleaner, safer, and faster.
+;;; 03-Feb-2000 BobGian cosmetic fixes (case regularization).
+;;; 1-Jun-2009 I. Kalet remove mini-images and resize-image call, not
+;;; precomputing these any more.
+;;;
+
+(in-package :prism)
+
+;;;------------------------------------------
+
+(defclass patient (generic-prism-object)
+
+ ((patient-id :type fixnum
+ :initarg :patient-id
+ :accessor patient-id
+ :documentation "The system assigned patient id number.
+Note that several cases may belong to the same patient, so there may
+be several cases with the same patient id.")
+
+ (case-id :type fixnum
+ :initarg :case-id
+ :accessor case-id
+ :documentation "A case id is also assigned by the system,
+one case id per set of anatomy.")
+
+ (hospital-id :type string
+ :initarg :hospital-id
+ :accessor hospital-id)
+
+ (comments :type list
+ :initarg :comments
+ :accessor comments)
+
+ (new-comments :type ev:event
+ :initform (ev:make-event)
+ :accessor new-comments
+ :documentation "Announced when the comments are updated.")
+
+ (date-entered :type string
+ :initform (date-time-string)
+ :accessor date-entered
+ :documentation "The date entered is updated when a case
+is modified, i.e., contours are changed or added, organs added, etc.")
+
+ (new-date :type ev:event
+ :initform (ev:make-event)
+ :accessor new-date
+ :documentation "Announced when date-entered is updated.")
+
+ (immob-device :type symbol
+ :initarg :immob-device
+ :accessor immob-device
+ :documentation "The immobilization device or method
+used for this case, if any.")
+
+ (new-immob-dev :type ev:event
+ :initform (ev:make-event)
+ :accessor new-immob-dev
+ :documentation "Announced when the immob. device is
+changed.")
+
+ (anatomy :accessor anatomy
+ :initform (coll:make-collection)
+ :documentation "A set of organs.")
+
+ (findings :accessor findings
+ :initform (coll:make-collection)
+ :documentation "A set of tumor instances for now.")
+
+ (targets :accessor targets
+ :initform (coll:make-collection)
+ :documentation "A set of planning target volumes.")
+
+ (points :accessor points
+ :initform (coll:make-collection)
+ :documentation "A set of marks in the patient volume.")
+
+ (plans :accessor plans
+ :initform (coll:make-collection)
+ :documentation "A set of plans for this patient case. There may
+be (and usually are) more than one plan for a given patient and anatomy.")
+
+ (image-set-id :type fixnum
+ :initarg :image-set-id
+ :accessor image-set-id
+ :documentation "The identifier for the data
+describing the CT-scans. Not a filename. Assigned by the system.")
+
+ (image-set :initarg :image-set
+ :accessor image-set
+ :documentation "The set of CT-scans from which the
+anatomy was drawn, if any.")
+
+ (new-image-set :type ev:event
+ :initform (ev:make-event)
+ :accessor new-image-set
+ :documentation "Announced when an image set is read
+in or set from somewhere.")
+
+ (pat-plan-mediator-set :accessor pat-plan-mediator-set
+ :initform (coll:make-collection)
+ :documentation "The set of patient-plan mediators")
+
+ )
+
+ (:default-initargs :name "" :patient-id 0 :case-id 0 :hospital-id ""
+ :comments (list "")
+ :immob-device (second (first *immob-devices*))
+ :image-set nil :image-set-id 0)
+
+ (:documentation "This is the information that describes the
+patient's condition and anatomy, separately from the treatment plan,
+which is the method of treating the condition. Also, there may be
+more than one instance of a patient object for a particular patient,
+because the anatomy and prescription may change, thus rtp computations
+will be different.")
+
+ )
+
+;;;------------------------------------------
+
+(defmethod slot-type ((object patient) slotname)
+
+ (case slotname
+ ((anatomy findings targets points plans) :collection)
+ (date-entered :timestamp)
+ ((table-position urc-anat llc-anat) :ignore)
+ (otherwise :simple)))
+
+;;;------------------------------------------
+
+(defmethod not-saved ((object patient))
+
+ (append (call-next-method)
+ '(name hospital-id
+ new-date new-comments new-immob-dev
+ patient-id case-id
+ image-set new-image-set
+ pat-plan-mediator-set)))
+
+;;;------------------------------------------
+
+(defun reset-case-id (pat &rest ignored)
+
+ "reset-case-id pat &rest ignored
+
+sets case-id to 0 and updates the date entered attribute."
+
+ (declare (ignore ignored))
+ (setf (case-id pat) 0)
+ (setf (date-entered pat) (date-time-string)))
+
+;;;----------------------------------
+
+(defclass patient-plan-mediator ()
+
+ ((the-patient :accessor the-patient
+ :initarg :the-patient
+ :documentation "The patient case this mediator connects to.")
+
+ (the-plan :accessor the-plan
+ :initarg :the-plan
+ :documentation "The plan this mediator connects to.")
+
+ (org-vm :accessor org-vm
+ :documentation "The organs-views-manager.")
+
+ (tum-vm :accessor tum-vm
+ :documentation "The tumors-views-manager.")
+
+ (tar-vm :accessor tar-vm
+ :documentation "The targets-views-manager.")
+
+ (pts-vm :accessor pts-vm
+ :documentation "The points-views-manager.")
+
+ (im-vm :accessor im-vm
+ :documentation "The image-view manager")
+
+ (dsm :accessor dsm
+ :documentation "The plan's dose-specification manager.")
+
+ ))
+
+;;;----------------------------------
+
+(defmethod initialize-instance :after ((ppm patient-plan-mediator)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (let ((pat (the-patient ppm))
+ (pln (the-plan ppm)))
+ (setf (im-vm ppm) ;; nil if no image set yet
+ (if (image-set pat) (make-image-view-manager
+ (image-set pat) (plan-views pln))))
+ (setf (pts-vm ppm) (make-object-view-manager
+ (points pat) (plan-views pln)
+ #'make-point-view-mediator))
+ (setf (org-vm ppm) (make-object-view-manager
+ (anatomy pat) (plan-views pln)
+ #'make-pstruct-view-mediator))
+ (setf (tum-vm ppm) (make-object-view-manager
+ (findings pat) (plan-views pln)
+ #'make-pstruct-view-mediator))
+ (setf (tar-vm ppm) (make-object-view-manager
+ (targets pat) (plan-views pln)
+ #'make-pstruct-view-mediator))
+ (setf (dsm ppm) (make-dose-specification-manager
+ :organs (anatomy pat)
+ :grid (dose-grid pln)
+ :beams (beams pln)
+ :seeds (seeds pln)
+ :line-sources (line-sources pln)
+ :points (points pat)))
+ (ev:add-notify ppm (new-image-set pat)
+ #'(lambda (med pt)
+ (setf (im-vm med)
+ (make-image-view-manager
+ (image-set pt)
+ (plan-views (the-plan med))))))))
+
+;;;--------------------------------------
+
+(defmethod destroy ((ppm patient-plan-mediator))
+
+ "destroys the individual mediator managers."
+
+ (ev:remove-notify ppm (new-image-set (the-patient ppm)))
+ (destroy (org-vm ppm))
+ (destroy (tum-vm ppm))
+ (destroy (tar-vm ppm))
+ (destroy (dsm ppm)))
+
+;;;------------------------------------------
+
+(defmethod initialize-instance :after ((p patient) &rest initargs)
+
+ "Arranges for the patient's case-id (and date-entered attrib) to get
+updated when a significant change to one of the lists of pstructs or points
+occurs. Also creates the patient-plan-manager."
+
+ (declare (ignore initargs))
+ (ev:add-notify p (coll:inserted (anatomy p))
+ #'(lambda (pat ann org)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ (ev:add-notify pat (update-case org)
+ #'reset-case-id)))
+ (ev:add-notify p (coll:deleted (anatomy p))
+ #'(lambda (pat ann org)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ (ev:remove-notify pat (update-case org))))
+ (ev:add-notify p (coll:inserted (findings p))
+ #'(lambda (pat ann tum)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ (ev:add-notify pat (update-case tum)
+ #'reset-case-id)))
+ (ev:add-notify p (coll:deleted (findings p))
+ #'(lambda (pat ann tum)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ (ev:remove-notify pat (update-case tum))))
+ (ev:add-notify p (coll:inserted (targets p))
+ #'(lambda (pat ann targ)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ (ev:add-notify pat (update-case targ)
+ #'reset-case-id)))
+ (ev:add-notify p (coll:deleted (targets p))
+ #'(lambda (pat ann targ)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ (ev:remove-notify pat (update-case targ))))
+ (ev:add-notify p (coll:inserted (points p))
+ #'(lambda (pat ann pt)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ ;; register with this point's new-loc & new-name events
+ (ev:add-notify pat (new-name pt)
+ #'(lambda (pat ann nm)
+ (declare (ignore ann nm))
+ (reset-case-id pat)))
+ (ev:add-notify pat (new-loc pt)
+ #'(lambda (pat ann nm)
+ (declare (ignore ann nm))
+ (reset-case-id pat)))))
+ (ev:add-notify p (coll:deleted (points p))
+ #'(lambda (pat ann pt)
+ (declare (ignore ann))
+ (reset-case-id pat)
+ (ev:remove-notify pat (new-name pt))
+ (ev:remove-notify pat (new-loc pt))))
+ (dolist (pl (coll:elements (plans p)))
+ (coll:insert-element (make-instance 'patient-plan-mediator
+ :the-patient p
+ :the-plan pl)
+ (pat-plan-mediator-set p)))
+ (ev:add-notify p (coll:inserted (plans p))
+ #'(lambda (pat pln-set pln)
+ (declare (ignore pln-set))
+ (coll:insert-element (make-instance
+ 'patient-plan-mediator
+ :the-patient pat
+ :the-plan pln)
+ (pat-plan-mediator-set pat))))
+ (ev:add-notify p (coll:deleted (plans p))
+ #'(lambda (pat pln-set pln)
+ (declare (ignore pln-set))
+ (let* ((ppm-set (pat-plan-mediator-set pat))
+ (ppm (find pln (coll:elements ppm-set)
+ :key #'the-plan)))
+ (coll:delete-element ppm ppm-set)
+ (destroy ppm)
+ (destroy pln)))))
+
+;;;------------------------------------------
+
+(defmethod (setf date-entered) :after (text (p patient))
+
+ (ev:announce p (new-date p) text))
+
+;;;------------------------------------------
+
+(defmethod (setf comments) :after (text (p patient))
+
+ (reset-case-id p)
+ (ev:announce p (new-comments p) text))
+
+;;;------------------------------------------
+
+(defmethod (setf immob-device) :after (text (p patient))
+
+ (ev:announce p (new-immob-dev p) text))
+
+;;;------------------------------------------
+
+(defun llc-anat (pat)
+
+ "llc-anat pat
+
+Computes the extreme lower limits of the contours of the objects in
+the anatomy slot of the patient case PAT and returns them as a three
+element list, the lowest X value, the lowest Y value and lowest Z
+value in order."
+
+ (let ((min-x #.most-positive-single-float)
+ (min-y #.most-positive-single-float)
+ (min-z #.most-positive-single-float))
+ (declare (single-float min-x min-y min-z))
+ (dolist (org (coll:elements (anatomy pat)))
+ (dolist (cont (contours org))
+ (dolist (vert (vertices cont))
+ (let ((x (first vert))
+ (y (second vert)))
+ (declare (single-float x y))
+ (when (< x min-x)
+ (setq min-x x))
+ (when (< y min-y)
+ (setq min-y y))))
+ (let ((z (z cont)))
+ (declare (single-float z))
+ (when (< z min-z)
+ (setq min-z z)))))
+ (list min-x min-y min-z)))
+
+;;;------------------------------------------
+
+(defun urc-anat (pat)
+
+ "urc-anat pat
+
+Computes the extreme upper limits of the contours of the objects in
+the anatomy slot of the patient case PAT and returns them as a three
+element list, the highest X value, the highest Y value and highest Z
+value in order."
+
+ (let ((max-x #.most-negative-single-float)
+ (max-y #.most-negative-single-float)
+ (max-z #.most-negative-single-float))
+ (declare (single-float max-x max-y max-z))
+ (dolist (org (coll:elements (anatomy pat)))
+ (dolist (cont (contours org))
+ (dolist (vert (vertices cont))
+ (let ((x (first vert))
+ (y (second vert)))
+ (declare (single-float x y))
+ (when (> x max-x)
+ (setq max-x x))
+ (when (> y max-y)
+ (setq max-y y))))
+ (let ((z (z cont)))
+ (declare (single-float z))
+ (when (> z max-z)
+ (setq max-z z)))))
+ (list max-x max-y max-z)))
+
+;;;---------------------------------------------
+
+(defmethod (setf image-set) :after (imgs (p patient))
+
+ "Just announces the new image set."
+
+ (declare (ignore imgs))
+ (ev:announce p (new-image-set p)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/pixel-graphics.cl b/prism/src/pixel-graphics.cl
new file mode 100644
index 0000000..2059136
--- /dev/null
+++ b/prism/src/pixel-graphics.cl
@@ -0,0 +1,358 @@
+;;;
+;;; pixel-graphics
+;;;
+;;; defines some low level functions for pixel/real space transforms
+;;; etc.
+;;;
+;;; 13-Oct-1992 I. Kalet put cm to pixel transforms here
+;;; 22-Apr-1994 I. Kalet move pix-x and pix-y here from
+;;; dose-grid-mediators
+;;; 4-May-1994 I. Kalet add coerce single-float to cm-x and cm-y
+;;; 8-Jan-1995 I. Kalet remove proclaim optimize form
+;;; 5-Sep-1995 I. Kalet remove proclaim inline also - it is ignored.
+;;; Add declarations, use pix-x and pix-y in the other functions.
+;;; Move pixel-segments and compute-tics here to keep module
+;;; dependencies in order, rewrite some code for speed.
+;;; 8-Oct-1996 I. Kalet move clipping code here from beam-graphics,
+;;; also draw-plus-icon and draw-diamond-icon, which can be used
+;;; other places.
+;;; 20-Jun-1997 BobGian fixed clipping code:
+;;; Removed declarations for vars which won't work in macros because others
+;;; will be substituted during macro-expansion; installed THE to declare
+;;; types of inputs/outputs. Removed COERCE when result must already be
+;;; of appropriate type. Simplified CLIP, OUTCODE, and CUT to make more
+;;; understandable (and maybe a hair faster).
+;;; 26-Jun-1997 BobGian CLIP -> CLIP-FIXNUM in SCALE-AND-CLIP-LINES.
+;;; Converted polymorphic and internally-consing CLIP to specialized
+;;; argument-type specific and non-consing CLIP-FIXNUM, CLIP-FLONUM.
+;;; This requires specializing CUT as well (used internally in CLIP-xxx).
+;;; 08-Jul-1997 BobGian fixed some possibly misleading comments in
+;;; in CLIP-FIXNUM and CLIP-FLONUM involving meaning of values returned
+;;; from OUTCODE and returned by CLIP-xxx themselves.
+;;; 12-Aug-1997 BobGian converted CLIP-FIXNUM back to CLIP and eliminated
+;;; CLIP-FLONUM. Ditto CUT-xxx (used inside clipping code). Reason: dose
+;;; calculation has own interpolation functions (based on old CLIP-FLONUM)
+;;; and therefore CLIP/CUT-FLONUM macros no longer needed.
+;;; 19-Jan-1998 I. Kalet change some setf to setq, experimented with
+;;; truncate instead of round but did not make much difference.
+;;; 21-Jan-2002 I. Kalet in compute-tics make every fifth tic a little
+;;; larger. Also, downcase names.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defmacro pix-x (x x0 ppcm)
+
+ `(the fixnum (+ (the fixnum ,x0)
+ (the fixnum (round (* (the single-float ,x)
+ (the single-float ,ppcm)))))))
+
+;;;--------------------------------------
+
+(defmacro pix-y (y y0 ppcm)
+
+ `(the fixnum (- (the fixnum ,y0)
+ (the fixnum (round (* (the single-float ,y)
+ (the single-float ,ppcm)))))))
+
+;;;--------------------------------------
+
+(defun cm-x (x x0 ppcm)
+
+ (declare (fixnum x x0) (single-float ppcm))
+ (/ (- x x0) ppcm))
+
+;;;--------------------------------------
+
+(defun cm-y (y y0 ppcm)
+
+ (declare (fixnum y y0) (single-float ppcm))
+ (/ (- y0 y) ppcm))
+
+;;;--------------------------------------
+
+(defun pixel-contour (cont pix-per-cm xorig yorig)
+
+ "pixel-contour cont pix-per-cm xorig yorig
+
+returns a list of pixel coordinates from cont, a list of vertices,
+each an x, y pair in cm in real space, using scale factor pix-per-cm.
+The xorig and yorig parameters are the pixel coordinates of the real
+space origin."
+
+ (declare (fixnum xorig yorig) (single-float pix-per-cm))
+ (let ((result nil))
+ (dolist (pt cont)
+ (push (pix-x (first pt) xorig pix-per-cm) result)
+ (push (pix-y (second pt) yorig pix-per-cm) result))
+ (nreverse result)))
+
+;;;--------------------------------------
+
+(defun cm-contour (pixcon pix-per-cm xorig yorig)
+
+ "cm-contour pixcon pix-per-cm xorig yorig
+
+returns a list of vertices, each an x, y pair in cm or real
+coordinates, from pixcon, a list of pixel coordinates alternating x y
+x y, using scale factor pix-per-cm. The xorig and yorig parameters
+are the pixel coordinates of the real space origin."
+
+ (declare (fixnum xorig yorig) (single-float pix-per-cm))
+ (cond ((null pixcon) nil)
+ (t (cons (list (cm-x (first pixcon) xorig pix-per-cm)
+ (cm-y (second pixcon) yorig pix-per-cm))
+ (cm-contour (rest (rest pixcon)) pix-per-cm xorig yorig)))))
+
+;;;-----------------------------------
+
+(defun pixel-segments (segs pix-per-cm xorig yorig)
+
+ "pixel-segments segs pix-per-cm xorig yorig
+
+returns a list of pixel coordinates from segs, a list of (x1 y1 x2 y2)
+4-tuples, each tuple defining a segment in model space. The pix-per-cm,
+xorig, and yorig parameters are the scale factor, x coord of the model
+space origin, and y coord of the model space origin, respectively."
+
+ (declare (single-float pix-per-cm) (fixnum xorig yorig))
+ (when segs
+ (let ((result nil))
+ (dolist (seg segs)
+ (push (pix-x (first seg) xorig pix-per-cm) result)
+ (push (pix-y (second seg) yorig pix-per-cm) result)
+ (push (pix-x (third seg) xorig pix-per-cm) result)
+ (push (pix-y (fourth seg) yorig pix-per-cm) result))
+ (nreverse result))))
+
+;;;--------------------------------------
+;;; compute-tics is used to draw the tape measure tics, the beam central
+;;; axis tics, and (when implemented) the view scale tics.
+
+(defun compute-tics (x1 y1 x2 y2 scale x-origin y-origin tic-length)
+
+ "compute-tics x1 y1 x2 y2 scale x-origin y-origin tic-length
+
+Computes a series of tic marks, spaced 1.0 cm apart, between the
+points (x1 y1) and (x2 y2) in model space. The scale and origin
+parameters are used to convert the coordinates to pixel space. The
+length of each tic is tic-length pixels. Returns a list of the form
+{x1 y1 x2 y2}*, suitable for passing to clx:draw-segments."
+
+ (unless (and (= x1 x2) (= y1 y2))
+ (do* ((len (distance x1 y1 x2 y2))
+ (rlen (/ 1.0 len))
+ (tlen (truncate len))
+ (dx (* rlen (- x2 x1))) ;; draw tape tics 1 cm apart
+ (dy (* rlen (- y2 y1)))
+ (c (+ x1 dx)) ;; start 1 cm from end
+ (d (+ y1 dy))
+ (tl (float (/ tic-length scale)))
+ (px (* dx tl))
+ (py (* dy tl))
+ (segs nil)
+ (tx1 (+ c (* tl (- dy))) (+ tx1 dx)) ;; tic end 1
+ (tx2 (- c (* tl (- dy))) (+ tx2 dx)) ;; tic end 2
+ (ty1 (+ d (* tl dx)) (+ ty1 dy))
+ (ty2 (- d (* tl dx)) (+ ty2 dy))
+ (i 0 (1+ i)))
+ ((= i tlen)
+ (pixel-segments segs scale x-origin y-origin))
+ ;; make every fifth tic double size
+ (push (list (if (zerop (mod (1+ i) 5)) (- tx1 py) tx1)
+ (if (zerop (mod (1+ i) 5)) (+ ty1 px) ty1)
+ (if (zerop (mod (1+ i) 5)) (+ tx2 py) tx2)
+ (if (zerop (mod (1+ i) 5)) (- ty2 px) ty2))
+ segs))))
+
+;;;----------------------------------------------
+
+(defun draw-plus-icon (pt scl x-orig y-orig radius)
+
+ "draw-plus-icon pt scl x-orig y-orig radius
+
+Draws a plus icon situated at the supplied point, with the given
+radius, under the supplied scale and origin parameters. Returns a list
+of the form {x1 y1 x2 y2}*, suitable for passing to clx:draw-segments."
+
+ (let ((x (pix-x (first pt) x-orig scl))
+ (y (pix-y (second pt) y-orig scl)))
+ (list (- x radius) y (+ x radius) y
+ x (- y radius) x (+ y radius))))
+
+;;;----------------------------------------------
+
+(defun draw-diamond-icon (pt scl x-orig y-orig radius)
+
+ "draw-diamond-icon pt scl x-orig y-orig radius
+
+Draws a diamond icon situated at the supplied point, with the given
+radius, under the supplied scale and origin parameters. Returns a list
+of the form {x1 y1 x2 y2}*, suitable for passing to clx:draw-segments."
+
+ (let* ((x (pix-x (first pt) x-orig scl))
+ (y (pix-y (second pt) y-orig scl))
+ (x-plus (+ x radius))
+ (x-minus (- x radius))
+ (y-plus (+ y radius))
+ (y-minus (- y radius)))
+ (list x y-minus x-plus y
+ x-plus y x y-plus
+ x y-plus x-minus y
+ x-minus y x y-minus)))
+
+;;;----------------------------------------------
+;;; Projecting points or contours may sometimes generate outlandish
+;;; coordinates, and X will misinterpret them as negative values if
+;;; given the raw data. Therefore, the following is for clipping
+;;; contours such as beam portals to fit a reasonable range.
+;;;----------------------------------------------
+
+;;; x and y args to outcode should be declared in containing code.
+
+(defmacro outcode (x y x-min y-min x-max y-max)
+
+ "outcode x y x-min y-min x-max y-max
+
+ min max
+ 0101 | 0100 | 0110
+ min -----+------+-----
+ 0001 | 0000 | 0010
+ max -----+------+-----
+ 1001 | 1000 | 1010 "
+
+ `(let ((clip-code 0))
+ (declare (fixnum clip-code))
+ (when (< ,x ,x-min)
+ (setq clip-code (logior clip-code #b0001)))
+ (when (> ,x ,x-max)
+ (setq clip-code (logior clip-code #b0010)))
+ (when (< ,y ,y-min)
+ (setq clip-code (logior clip-code #b0100)))
+ (when (> ,y ,y-max)
+ (setq clip-code (logior clip-code #b1000)))
+ clip-code))
+
+;;;----------------------------------------------
+
+;;; All args are declared fixnum in containing function definition.
+
+(defmacro cut (a b c d bound)
+
+ "cut a b c d bound
+
+b is out of bounds. Cut it at bound and interpolate thereby
+where a should go. a, b, c, d must be symbols. fixnum only"
+
+ `(progn
+ ;;
+ ;; Convert fixnums to single-float before division so result of /
+ ;; is a single-float (to be rounded to fixnum) rather than a ratio.
+ ;;
+ ;; Note: Function interpolate in beam-dose does same calculation
+ ;; as this code, but for float-only arguments. It has
+ ;; optimizing code to select end closer to bound from which to
+ ;; interpolate, so as to reduce chance of roundoff error
+ ;; affecting result. This approach is not taken here because all
+ ;; values are "small" (ie, abs value under 1000) integers and we
+ ;; want to keep this code as small as possible since it is
+ ;; expanded inline. See comments in interpolate, file beam-dose.
+ ;;
+ (setq ,a (+ ,a (round (/ (float (* (- ,c ,a) (- ,bound ,b)))
+ (float (- ,d ,b))))))
+ (setq ,b ,bound)))
+
+;;;----------------------------------------------
+
+;;; All arguments to clip must be symbols (ie, variables) which are
+;;; declared fixnum in the containing function - because macro is expanded
+;;; inline and declarations must go outside macro's scope.
+
+(defmacro clip (x1 y1 x2 y2 x-min y-min x-max y-max)
+
+ "clip x1 xy x2 y2
+
+clip the line segment from (x1,y1) to (x2,y2) by the bounds x-min,
+y-min, x-max, y-max. This is Cohen-Sutherland clipping (see
+Foley/VanDam/Feiner/Hughes) except we don't swap codes and
+coordinates, since we want to keep the list of coordinate pairs
+stable. x1, y1, x2, y2 are symbols; rest are symbols or numbers.
+Return t if line segment crosses or is in central window, nil
+if line segment is totally outside central window. fixnum-only version."
+
+ `(let ((code1 0)
+ (code2 0))
+ (declare (fixnum code1 code2))
+ (loop
+ (setq code1 (outcode ,x1 ,y1 ,x-min ,y-min ,x-max ,y-max)
+ code2 (outcode ,x2 ,y2 ,x-min ,y-min ,x-max ,y-max))
+ (cond ((zerop (logior code1 code2))
+ ;; (x1 y1), (x2 y2) were already or have been clipped into
+ ;; range - there is a line segment in the central window.
+ (return t))
+ ((logtest code1 code2)
+ ;; Both x or both y (or both) are out of range on same side
+ ;; of common boundary - no line segment crosses central window.
+ (return nil))
+ ((logtest #b1000 code1)
+ ;; y1 is too large - clip to y-max.
+ (cut ,x1 ,y1 ,x2 ,y2 ,y-max))
+ ((logtest #b0100 code1)
+ ;; y1 is too small - clip to y-min.
+ (cut ,x1 ,y1 ,x2 ,y2 ,y-min))
+ ((logtest #b0010 code1)
+ ;; x1 is too large - clip to x-max.
+ (cut ,y1 ,x1 ,y2 ,x2 ,x-max))
+ ((logtest #b0001 code1)
+ ;; x1 is too small - clip to x-min.
+ (cut ,y1 ,x1 ,y2 ,x2 ,x-min))
+ ((logtest #b1000 code2)
+ ;; y2 is too large - clip to y-max.
+ (cut ,x2 ,y2 ,x1 ,y1 ,y-max))
+ ((logtest #b0100 code2)
+ ;; y2 is too small - clip to y-min.
+ (cut ,x2 ,y2 ,x1 ,y1 ,y-min))
+ ((logtest #b0010 code2)
+ ;; x2 is too large - clip to x-max.
+ (cut ,y2 ,x2 ,y1 ,x1 ,x-max))
+ (t
+ ;; x2 is too small - clip to x-min
+ ;; only possibility left - no need to test
+ (cut ,y2 ,x2 ,y1 ,x1 ,x-min))))))
+
+;;;----------------------------------------------
+
+(defun scale-and-clip-lines
+ (pts scale x-origin y-origin x-min y-min x-max y-max)
+
+ "scale-and-clip-lines pts x-origin y-origin scale x-min y-min x-max y-max
+
+Returns list in the form {x1 y1 x2 y2}* suitable for passing to
+clx:draw-segments, clipped to the bounds x-min y-min x-max y-max.
+pts is a list of 2D points in the form of 2-element lists, in the
+viewing coordinate system. Scale is pixels per centimeter.
+x-origin and y-origin together are the origin of the window."
+
+ (declare (fixnum x-origin y-origin x-min y-min x-max y-max)
+ (single-float scale)
+ (list pts))
+ (let ((p1 (car pts))
+ (clipped-pts nil)
+ (x1 0) (y1 0) (x2 0) (y2 0))
+ (declare (type list clipped-pts)
+ (fixnum x1 y1 x2 y2))
+ (dolist (p2 (cdr pts))
+ (declare (type list p2))
+ (setq x1 (pix-x (first p1) x-origin scale)
+ y1 (pix-y (second p1) y-origin scale)
+ x2 (pix-x (first p2) x-origin scale)
+ y2 (pix-y (second p2) y-origin scale))
+ (when (clip x1 y1 x2 y2 x-min y-min x-max y-max)
+ (setq clipped-pts (list* x1 y1 x2 y2 clipped-pts)))
+ (setq p1 p2))
+ clipped-pts))
+
+;;;----------------------------------------------
+;;; End.
diff --git a/prism/src/plan-panels.cl b/prism/src/plan-panels.cl
new file mode 100644
index 0000000..4bea50c
--- /dev/null
+++ b/prism/src/plan-panels.cl
@@ -0,0 +1,690 @@
+;;;
+;;; plan-panels
+;;;
+;;; Implements the plan panel with all the dose display stuff
+;;;
+;;; 15-Jan-1992 J. Unger enhance call to interactive-make-view to handle
+;;; interactive creation of beam's eye views.
+;;; 15-Feb-1993 I. Kalet add table-position to interactive-make-view
+;;; call, add time-stamp display, rearrange and parametrize buttons.
+;;; 30-Aug-1993 I. Kalet change button and textline placement, add
+;;; dose panel button, ckpt button.
+;;; 5-Sep-1993 I. Kalet split off from plans module
+;;; 15-Oct-1993 J. Unger hook up dose panel.
+;;; 18-Oct-1993 J. Unger simplify dose-panel initialization code.
+;;; 19-Oct-1993 J. Unger change name of store plan button to 'archive'.
+;;; 21-Oct-1993 J. Unger add code for deletion of dose-panel.
+;;; 29-Oct-1993 I. Kalet add code for save plan and checkpoint plan.
+;;; 3-Nov-1993 J. Unger finish adding code for save & checkpoint plan.
+;;; 22-Dec-1993 J. Unger fix bug to allow dose info to get saved with
+;;; checkpointed plans.
+;;; 3-Jan-1994 I. Kalet plans have reference to patient, not
+;;; forwarded data.
+;;; 11-Feb-1994 J. Unger implement Print Chart operation.
+;;; 22-Apr-1994 J. Unger add point-dose panel button and action functions.
+;;; 05-May-1994 J. Unger make point-dose panel go away properly.
+;;; 13-May-1994 I. Kalet only make point dose panel if there are
+;;; points and beams.
+;;; 16-May-1994 J. Unger add support for comments textbox.
+;;; 18-May-1994 I. Kalet embed comments textbox right on the plan panel.
+;;; 8-Jun-1994 J. Unger elim *save-plan-dose* mechanism for saving
+;;; dose info.
+;;; 13-Jun-1994 I. Kalet fix copy plan button so it retains new plan.
+;;; 08-Jul-1994 J. Unger put temporary reminders into plan archive & chekpt
+;;; operations to remind user not to cross save cases and plans.
+;;; 12-Jan-1995 I. Kalet get table-position from patient, not plan.
+;;; Pass plan and patient to make-beam-panel, make-view-panel, etc.
+;;; 27-Apr-1995 I. Kalet turn timestamp border red when timestamp
+;;; changes, turn white when archive or checkpoint is successful.
+;;; 2-Jun-1996 I. Kalet big revision to add brachy support.
+;;; 21-Jan-1997 I. Kalet eliminate table-position.
+;;; 9-Jun-1997 I. Kalet move stuff here from dose-panels, reorganize
+;;; according to spec., including colored button labels for beams and
+;;; dose levels.
+;;; 2-May-1998 I. Kalet new make-chart-panel function.
+;;; 21-Mar-1999 I. Kalet add beam sorting popup panel, called here,
+;;; but general function implemented in selector-panels.
+;;; 19-Mar-2000 I. Kalet revision of support for brachy, and new chart
+;;; code using PostScript.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 14-Oct-2001 I. Kalet adapt copy plan function to new semantics of
+;;; the copy method - exact copy, modify by caller afterward.
+;;; 4-Jan-2002 I. Kalet make comments textbox slightly higher to
+;;; accomodate the bottom line.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass plan-panel (generic-panel)
+
+ ((the-plan :accessor the-plan
+ :initarg :the-plan
+ :documentation "The plan that this panel edits.")
+
+ (patient-of :accessor patient-of
+ :initarg :patient-of
+ :documentation "The current patient.")
+
+ (panel-frame :accessor panel-frame
+ :documentation "The SLIK frame containing all the
+panel stuff.")
+
+ (name-box :accessor name-box
+ :documentation "The textline for the plan name.")
+
+ (plan-by-box :accessor plan-by-box
+ :documentation "The textline for the planner's name.")
+
+ (timestamp-box :accessor timestamp-box
+ :documentation "Displays the time stamp.")
+
+ (comments-box :accessor comments-box
+ :documentation "The plan's comments box.")
+
+ (delete-b :accessor delete-b
+ :documentation "The Delete Panel button.")
+
+ (comments-btn :accessor comments-btn
+ :documentation "The Accept button for accepting the
+text in the comments box, i.e., making an update to the plan comments
+slot.")
+
+ (copy-b :accessor copy-b
+ :documentation "The Copy Plan button.")
+
+ (save-b :accessor save-b
+ :documentation "The Archive Plan button.")
+
+ (ckpt-b :accessor ckpt-b
+ :documentation "The Checkpoint button")
+
+ (brachy-b :accessor brachy-b
+ :documentation "The Brachy Sources button")
+
+ (brachy-panel :accessor brachy-panel
+ :initform nil
+ :documentation "The plan panel's brachytherapy
+sources panel.")
+
+ (point-b :accessor point-b
+ :documentation "The Point Dose Panel button.")
+
+ (point-dose-panel :accessor point-dose-panel
+ :initform nil
+ :documentation "The plan panel's point dose panel.")
+
+ (sort-beams-btn :accessor sort-beams-btn
+ :documentation "The button for the beam sorting and
+linking subpanel.")
+
+ (print-b :accessor print-b
+ :documentation "The Print Chart button")
+
+ (compute-btn :accessor compute-btn
+ :documentation "The Compute Dose button.")
+
+ (write-dose-btn :accessor write-dose-btn
+ :documentation "The Write Dose button brings up a
+menu of three dose files to send a valid dose dist.")
+
+ (beam-selector :accessor beam-selector
+ :documentation "The selector panel listing the beams
+in the plan.")
+
+ (dose-selector :accessor dose-selector
+ :documentation "The selector panel listing the dose
+levels in the plan.")
+
+ (view-selector :accessor view-selector
+ :documentation "The selector panel listing the views
+for this plan.")
+
+ (grid-size-btn :accessor grid-size-btn
+ :documentation "The grid size button.")
+
+ (grid-color-btn :accessor grid-color-btn
+ :documentation "The dose grid color button.")
+
+ (max-dos-rdt :accessor max-dos-rdt
+ :documentation "The maximum dose readout.")
+
+ (max-coord-rdt :accessor max-coord-rdt
+ :documentation "The maximum dose coordinates readout.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "The mediator busy flag for updates.")
+
+ )
+
+ )
+
+;;;------------------------------------------
+
+(defun update-max-dose-display (pp)
+
+ "update-max-dose-display pp
+
+Updates the 'max dose' and 'coords' textfields of the dose panel pp
+when pp's plan's sum-result becomes valid."
+
+ (let* ((max-dose -1.0)
+ (max-i -1)
+ (max-j -1)
+ (max-k -1)
+ (dose-arr (grid (sum-dose (the-plan pp))))
+ (x-dim (array-dimension dose-arr 0))
+ (y-dim (array-dimension dose-arr 1))
+ (z-dim (array-dimension dose-arr 2))
+ (dose-grid (dose-grid (the-plan pp))))
+ (declare (single-float max-dose))
+ (declare (fixnum max-i max-j max-k x-dim y-dim z-dim))
+ (dotimes (i x-dim)
+ (dotimes (j y-dim)
+ (dotimes (k z-dim)
+ (when (< max-dose (aref dose-arr i j k))
+ (setq
+ max-dose (aref dose-arr i j k)
+ max-i i
+ max-j j
+ max-k k)))))
+ (setf (sl:info (max-dos-rdt pp))
+ (write-to-string (fix-float max-dose 2)))
+ (setf (sl:info (max-coord-rdt pp))
+ (concatenate 'string
+ (write-to-string (fix-float
+ (+ (x-origin dose-grid)
+ (* (x-size dose-grid) (/ max-i (1- x-dim))))
+ 2))
+ ", "
+ (write-to-string (fix-float
+ (+ (y-origin dose-grid)
+ (* (y-size dose-grid) (/ max-j (1- y-dim))))
+ 2))
+ ", "
+ (write-to-string (fix-float
+ (+ (z-origin dose-grid)
+ (* (z-size dose-grid) (/ max-k (1- z-dim))))
+ 2))))))
+
+;;;------------------------------------------
+
+(defun write-dose-info (plan pat)
+
+ "write-dose-info plan pat
+
+Writes a plan's dose information (with some other identification) out
+to a dose file in the user's checkpoint directory."
+
+ (if (valid-grid (sum-dose plan))
+ (let* ((filelist '("dose1" "dose2" "dose3"))
+ (choice (sl:popup-menu filelist :title "Filename"))
+ (filename (when choice (nth choice filelist)))
+ (pathname (when choice (merge-pathnames *local-database*
+ filename))))
+ (if choice
+ (if (probe-file *local-database*)
+ (with-open-file (stream pathname
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (format stream "PRISM:PATIENT-ID ~a ~%"
+ (patient-id pat))
+ (format stream "PRISM:CASE-ID ~a ~%"
+ (case-id pat))
+ (format stream "PRISM:NAME ~a ~%"
+ (name plan))
+ (format stream "PRISM:TIME-STAMP ~a ~%"
+ (time-stamp plan))
+ (put-object (dose-grid plan) stream)
+ (put-object (sum-dose plan) stream)
+ (sl:acknowledge "Dose file written."))
+ (sl:acknowledge "Unable to find checkpoint database."))
+ (sl:acknowledge "No choice made -- no dose file written.")))
+ (sl:acknowledge
+ "You must compute a dose grid before saving dose information.")))
+
+;;;------------------------------------------
+
+(defun make-plan-panel (pln pat &rest initargs)
+
+ "make-plan-panel pln pat &rest initargs
+
+returns an instance of a plan panel for the plan pln and patient pat."
+
+ (apply #'make-instance 'plan-panel
+ :the-plan pln :patient-of pat initargs))
+
+;;;------------------------------------------
+
+(defmethod initialize-instance :after ((pp plan-panel) &rest initargs)
+
+ (let* ((p (the-plan pp))
+ (pat (patient-of pp))
+ (ppf (symbol-value *small-font*))
+ (pan-fr (apply #'sl:make-frame 585 370
+ :title "Prism PLAN Panel" initargs))
+ (pp-win (sl:window pan-fr))
+ (bth 25) ;; button and textline height for small font
+ (btw 120) ;; regular button and textline width
+ (sbw 20) ;; small button width
+ (dx 10) ;; left margin
+ (top-y 10) ;; dosim, plan id and timestamp are at top
+ (dy (+ top-y bth 95)) ;; where the middle stuff starts
+ (sp-wd (+ btw 20)) ;; the width of the selector panels
+ (sp-ht 205) ;; the height of the selector panels
+ ;; readouts, textlines and textbox at top
+ (plan-by-t (apply #'sl:make-textline 200 bth
+ :font ppf
+ :label "DS: "
+ :ulc-x dx :ulc-y top-y
+ :parent pp-win initargs))
+ (name-t (apply #'sl:make-textline 195 bth
+ :font ppf :label "Plan ID: "
+ :ulc-x (+ dx 205) :ulc-y top-y
+ :parent pp-win initargs))
+ (ts-box (apply #'sl:make-readout 165 bth
+ :font ppf :ulc-x 415 :ulc-y top-y
+ :parent pp-win initargs))
+ (com-box (apply #'sl:make-textbox 440 85
+ :ulc-x (+ dx btw 10)
+ :ulc-y (bp-y top-y bth 1)
+ :info (comments p)
+ :parent pp-win initargs))
+ (del-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 1)
+ :font ppf
+ :label "Delete Panel"
+ :parent pp-win initargs))
+ (cmt-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 2)
+ :font ppf
+ :label "Accept cmts"
+ :parent pp-win initargs))
+ (cpy-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 3)
+ :font ppf
+ :label "Copy Plan"
+ :parent pp-win initargs))
+ (sv-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 4)
+ :font ppf
+ :label "Archive"
+ :parent pp-win initargs))
+ (ckp-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 5)
+ :font ppf
+ :label "Checkpt"
+ :parent pp-win initargs))
+ (bra-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 6)
+ :font ppf
+ :label "Brachy sources"
+ :parent pp-win initargs))
+ (pt-b (apply #'sl:make-button btw bth
+ :ulc-x dx :ulc-y (bp-y top-y bth 7)
+ :font ppf
+ :label "Point doses"
+ :parent pp-win initargs))
+ (bsrt-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 8)
+ :font ppf
+ :label "Sort beams"
+ :parent pp-win initargs))
+ (prt-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 9)
+ :font ppf
+ :label "Print Chart"
+ :parent pp-win initargs))
+ (comp-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 10)
+ :font ppf
+ :label "Compute"
+ :parent pp-win initargs))
+ (wrtd-b (apply #'sl:make-button btw bth :button-type :momentary
+ :ulc-x dx :ulc-y (bp-y top-y bth 11)
+ :font ppf
+ :label "Write Dose"
+ :parent pp-win initargs))
+ (gsize-b (apply #'sl:make-button (- btw sbw 10) bth
+ :ulc-x (+ dx btw 5)
+ :ulc-y (bp-y top-y bth 11)
+ :font ppf
+ :parent pp-win initargs))
+ (gcolor-b (apply #'sl:make-button sbw bth
+ :ulc-x (+ dx btw (- btw sbw))
+ :ulc-y (bp-y top-y bth 11)
+ :bg-color (display-color (dose-grid p))
+ :parent pp-win initargs))
+ (max-dos-r (apply #'sl:make-readout (+ btw 20) bth
+ :ulc-x (+ dx (* 2 btw) 5)
+ :ulc-y (bp-y top-y bth 11)
+ :font ppf
+ :label "Max Dose: "
+ :parent pp-win initargs))
+ (max-crd-r (apply #'sl:make-readout 180 bth
+ :ulc-x (+ dx (* 3 btw) 30)
+ :ulc-y (bp-y top-y bth 11)
+ :font ppf
+ :label "At: "
+ :parent pp-win initargs)))
+ (setf (panel-frame pp) pan-fr ;; put all the widgets in the slots
+ ;; info initialized here so that it won't be centered
+ (plan-by-box pp) plan-by-t
+ (sl:info plan-by-t) (plan-by p)
+ (name-box pp) name-t
+ (sl:info name-t) (name p)
+ (timestamp-box pp) ts-box
+ (sl:info ts-box) (time-stamp p)
+ (comments-box pp) com-box
+ (delete-b pp) del-b
+ (comments-btn pp) cmt-b
+ (copy-b pp) cpy-b
+ (save-b pp) sv-b
+ (ckpt-b pp) ckp-b
+ (brachy-b pp) bra-b
+ (point-b pp) pt-b
+ (sort-beams-btn pp) bsrt-b
+ (print-b pp) prt-b
+ (compute-btn pp) comp-b
+ (write-dose-btn pp) wrtd-b
+ (grid-size-btn pp) gsize-b
+ (grid-color-btn pp) gcolor-b
+ (max-dos-rdt pp) max-dos-r
+ (max-coord-rdt pp) max-crd-r)
+ (ev:add-notify pp (sl:new-info plan-by-t)
+ #'(lambda (pan pl info)
+ (declare (ignore pl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (plan-by (the-plan pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (new-plan-by p)
+ #'(lambda (pan pl info)
+ (declare (ignore pl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (plan-by-box pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (sl:new-info name-t)
+ #'(lambda (pan tl info)
+ (declare (ignore tl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (name (the-plan pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (new-name p)
+ #'(lambda (pan pl info)
+ (declare (ignore pl))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (name-box pan)) info)
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (new-time-stamp p)
+ #'(lambda (pan pl new-ts)
+ (declare (ignore pl))
+ (setf (sl:info (timestamp-box pan)) new-ts)
+ (setf (sl:border-color (timestamp-box pan))
+ 'sl:red)))
+ (ev:add-notify pp (sl:new-info com-box)
+ #'(lambda (pan box)
+ (declare (ignore box))
+ (unless (sl:on (comments-btn pan))
+ (setf (sl:on (comments-btn pan)) t))))
+ (ev:add-notify pp (sl:button-on del-b)
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (destroy pan)))
+ (ev:add-notify pp (sl:button-off cmt-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (setf (comments (the-plan pan))
+ (sl:info (comments-box pan)))))
+ (ev:add-notify pp (sl:button-on cpy-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (let ((temp-plan (copy (the-plan pan))))
+ (setf (name temp-plan)
+ (format nil "~A" (gensym "PLAN-")))
+ (coll:insert-element temp-plan
+ (plans (patient-of pan))))))
+ (ev:add-notify pp (sl:button-on sv-b)
+ #'(lambda (pan btn)
+ (let ((pat (patient-of pan)))
+ (if (zerop (case-id pat))
+ (sl:acknowledge
+ '("Plan not archived: belongs to new case."
+ "Archive case from Patient panel instead."))
+ (if (sl:confirm
+ '("Reminder - only archive this plan if"
+ "current case came from archive."))
+ (if (put-plan-data
+ (patient-id pat) (case-id pat)
+ (the-plan pan) *patient-database*)
+ (progn
+ (sl:acknowledge
+ "Plan successfully archived")
+ (setf (sl:border-color
+ (timestamp-box pan))
+ 'sl:white))
+ (sl:acknowledge "Archive failed"))
+ (sl:acknowledge "Archive aborted."))))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify pp (sl:button-on ckp-b)
+ #'(lambda (pan btn)
+ (let ((pat (patient-of pan)))
+ (if (zerop (case-id pat))
+ (sl:acknowledge
+ '("Plan not checkpointed: belongs to new case."
+ "Checkpoint case from Patient panel instead."))
+ (if (sl:confirm
+ '("Reminder - only checkpoint this plan if"
+ "current case came from checkpt database"))
+ (if (put-plan-data
+ (patient-id pat) (case-id pat)
+ (the-plan pan) *local-database*)
+ (progn
+ (sl:acknowledge "Plan saved locally")
+ (setf (sl:border-color
+ (timestamp-box pan))
+ 'sl:white))
+ (sl:acknowledge "Checkpoint failed"))
+ (sl:acknowledge "Checkpoint aborted."))))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify pp (sl:button-on bra-b)
+ #'(lambda (pan bb)
+ (declare (ignore bb))
+ (let* ((pln (the-plan pan))
+ (bra-p (make-brachy-panel
+ :line-sources (line-sources pln)
+ :seeds (seeds pln)
+ :points (points (patient-of pan)))))
+ (setf (brachy-panel pan) bra-p)
+ (ev:add-notify pan (deleted bra-p)
+ #'(lambda (ppl bp)
+ (ev:remove-notify ppl
+ (deleted bp))
+ (setf (brachy-panel ppl) nil)
+ (when (not (busy ppl))
+ (setf (busy ppl) t)
+ (setf (sl:on (brachy-b ppl))
+ nil)
+ (setf (busy ppl) nil)))))))
+ (ev:add-notify pp (sl:button-off bra-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (brachy-panel pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (sl:button-on pt-b)
+ #'(lambda (pan pb) ;; first check for points and beams
+ (if (and (coll:elements (points (patient-of pan)))
+ (coll:elements (beams (the-plan pan))))
+ (let ((pdp (make-point-dose-panel
+ :plan (the-plan pan)
+ :pat (patient-of pan))))
+ (setf (point-dose-panel pan) pdp)
+ (ev:add-notify pan (deleted pdp)
+ #'(lambda (ppl pdp)
+ (ev:remove-notify
+ ppl (deleted pdp))
+ (setf (point-dose-panel ppl)
+ nil)
+ (when (not (busy ppl))
+ (setf (busy ppl) t)
+ (setf (sl:on
+ (point-b ppl))
+ nil)
+ (setf (busy ppl)
+ nil)))))
+ (progn
+ (sl:acknowledge "Points or beams missing")
+ (setf (busy pan) t)
+ (setf (sl:on pb) nil)
+ (setf (busy pan) nil)))))
+ (ev:add-notify pp (sl:button-off pt-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (point-dose-panel pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify pp (sl:button-on prt-b)
+ #'(lambda (pan btn)
+ (declare (ignore btn))
+ (chart-panel 'main (patient-of pan) (the-plan pan))
+ (setf (sl:on (print-b pan)) nil)))
+ (ev:add-notify pp (sl:button-on bsrt-b)
+ #'(lambda (pan btn)
+ (popup-listsort (beam-selector pan))
+ (setf (sl:on btn) nil)))
+ (ev:add-notify pp (sl:button-on comp-b)
+ #'(lambda (pan bt)
+ (compute-dose-grid (the-plan pan) (patient-of pan))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify pp (sl:button-on wrtd-b)
+ #'(lambda (pan bt)
+ (write-dose-info (the-plan pan) (patient-of pan))
+ (setf (sl:on bt) nil)))
+ ;; set up the coarseness label
+ (let ((vs (voxel-size (dose-grid p))))
+ (cond
+ ((= vs *fine-grid-size*)
+ (setf (sl:label gsize-b) "Fine Grid"))
+ ((= vs *medium-grid-size*)
+ (setf (sl:label gsize-b) "Medium Grid"))
+ ((= vs *coarse-grid-size*)
+ (setf (sl:label gsize-b) "Coarse Grid"))
+ (t (setf (sl:label gsize-b) (format nil "~A" vs)))))
+ (ev:add-notify p (sl:button-on gsize-b)
+ #'(lambda (pl bt)
+ (let ((item (sl:popup-menu
+ '("Coarse Grid"
+ "Medium Grid"
+ "Fine Grid"))))
+ (when item
+ (case item
+ (0 (setf (voxel-size (dose-grid pl))
+ *coarse-grid-size*)
+ (setf (sl:label bt) "Coarse Grid"))
+ (1 (setf (voxel-size (dose-grid pl))
+ *medium-grid-size*)
+ (setf (sl:label bt) "Medium Grid"))
+ (2 (setf (voxel-size (dose-grid pl))
+ *fine-grid-size*)
+ (setf (sl:label bt) "Fine Grid"))))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify p (sl:button-on gcolor-b)
+ #'(lambda (pln bt)
+ (let ((new-col (sl:popup-color-menu)))
+ (when new-col
+ (setf (display-color (dose-grid pln)) new-col)
+ (setf (sl:bg-color bt) new-col)))
+ (setf (sl:on bt) nil)))
+ ;; initialize the max-dose display
+ (when (valid-grid (sum-dose p)) (update-max-dose-display pp))
+ (ev:add-notify pp (grid-status-changed (sum-dose p))
+ #'(lambda (pan sd v)
+ (declare (ignore v))
+ (if (valid-grid sd)
+ (update-max-dose-display pan)
+ (setf (sl:info max-dos-r) ""
+ (sl:info max-crd-r) ""))))
+ (setf (beam-selector pp)
+ (make-selector-panel sp-wd sp-ht
+ "Add a beam" (beams p)
+ 'make-beam
+ #'(lambda (bm)
+ (make-beam-panel bm :plan-of p
+ :patient-of pat))
+ :parent pp-win :font ppf
+ :ulc-x (+ dx btw 10)
+ :ulc-y dy
+ :use-color t))
+ (setf (dose-selector pp)
+ (make-selector-panel sp-wd sp-ht
+ "Add dose level" (dose-surfaces p)
+ #'(lambda (name)
+ (declare (ignore name))
+ (make-dose-surface :dose-grid (dose-grid p)
+ :result (sum-dose p)))
+ 'make-dose-surface-panel
+ :parent pp-win :font ppf
+ :ulc-x (+ dx (* 2 btw) 40)
+ :ulc-y dy
+ :use-color t))
+ (setf (view-selector pp)
+ (make-selector-panel sp-wd sp-ht
+ "Add a view" (plan-views p)
+ #'(lambda (name)
+ (interactive-make-view
+ name
+ :beams (coll:elements (beams p))))
+ #'(lambda (vw)
+ (make-view-panel vw :plan-of p
+ :patient-of pat))
+ :parent pp-win :font ppf
+ :ulc-x (+ dx (* 2 btw) 50 sp-wd)
+ :ulc-y dy))))
+
+;;;------------------------------------------
+
+(defmethod destroy :before ((pp plan-panel))
+
+ "releases X resources used by this panel and its children."
+
+ (ev:remove-notify pp (new-name (the-plan pp)))
+ (ev:remove-notify pp (new-plan-by (the-plan pp)))
+ (ev:remove-notify pp (new-time-stamp (the-plan pp)))
+ (ev:remove-notify pp (grid-status-changed (sum-dose (the-plan pp))))
+ (when (point-dose-panel pp) (destroy (point-dose-panel pp)))
+ (when (brachy-panel pp) (destroy (brachy-panel pp)))
+ (sl:destroy (plan-by-box pp))
+ (sl:destroy (name-box pp))
+ (sl:destroy (timestamp-box pp))
+ (sl:destroy (comments-box pp))
+ (sl:destroy (delete-b pp))
+ (sl:destroy (comments-btn pp))
+ (sl:destroy (copy-b pp))
+ (sl:destroy (save-b pp))
+ (sl:destroy (ckpt-b pp))
+ (sl:destroy (brachy-b pp))
+ (sl:destroy (point-b pp))
+ (sl:destroy (sort-beams-btn pp))
+ (sl:destroy (print-b pp))
+ (sl:destroy (compute-btn pp))
+ (sl:destroy (write-dose-btn pp))
+ (sl:destroy (grid-size-btn pp))
+ (sl:destroy (grid-color-btn pp))
+ (sl:destroy (max-dos-rdt pp))
+ (sl:destroy (max-coord-rdt pp))
+ (destroy (beam-selector pp))
+ (destroy (dose-selector pp))
+ (destroy (view-selector pp))
+ (sl:destroy (panel-frame pp)))
+
+;;;------------------------------------------
+;;; End.
diff --git a/prism/src/planar-editor.cl b/prism/src/planar-editor.cl
new file mode 100644
index 0000000..e47dfde
--- /dev/null
+++ b/prism/src/planar-editor.cl
@@ -0,0 +1,1275 @@
+;;;
+;;; planar-editor
+;;;
+;;; The planar editor provides a graphical display with a background
+;;; picture and a list of points to be edited, along with mouse
+;;; interaction techniques to enter and edit the points and some
+;;; related controls. It provides support for editing lists of points
+;;; of interest and planar contours.
+;;;
+;;; 10-Jul-1992 I. Kalet created contour editor, made many modifications.
+;;; 24-Feb-1993 J. Unger rewrite from I. Kalet's original code.
+;;; 13-Apr-1993 J. Unger revise after extensive discussions.
+;;; 11-Mar-1994 I. Kalet major rewrite, move ruler to separate
+;;; module, reorganize event dispatching, use pickable objects.
+;;; 17-Mar-1994 I. Kalet don't announce new-vertices in setf method,
+;;; only when Accept button is pressed.
+;;; 1-Apr-1994 I. Kalet further mods in major rewrite.
+;;; 25-Apr-1994 I. Kalet use new pickable objects and stuff
+;;; 10-May-1994 I. Kalet fix error in ce-deselected, landmark code,
+;;; change type of image data to unsigned byte 8. Fix error in
+;;; delete-duplicate-vertices.
+;;; 17-May-1994 I. Kalet take free-pixmap out of destroy method
+;;; 22-May-1994 I. Kalet ignore grab box motion unless button 1 down
+;;; 30-May-1994 I. Kalet split off to share code and reduce
+;;; duplication. Add pan-zoom flag to lock scale and origin when
+;;; image displayed, don't depend on image slot.
+;;; 10-Jun-1994 I. Kalet add full digitizer support.
+;;; 30-Jun-1994 I. Kalet don't recalibrate digitizer every time.
+;;; 11-Jul-1994 J. Unger work on getting digitizer dialogs to show up
+;;; (not finished).
+;;; 11-Jul-1994 J. Unger implement call to tape-measure; impl may change
+;;; after some more design work.
+;;; 22-Jul-1995 J. Unger make title of planar editor panel a keyword param,
+;;; pass 'enabled' param into call to make-square.
+;;; 03-Aug-1994 J. Unger add get-pe-magnification method and call
+;;; in use-digitizer.
+;;; 04-Aug-1994 J. Unger make use-digitizer a method.
+;;; 13-Jan-1995 I. Kalet don't make destroy method free background pixmap
+;;; but do change name of digitizer routine from gp8 to digit.
+;;; 23-May-1995 I. Kalet move pop-event-level up in use-digitizer to
+;;; avoid problems with side effects of accept-vertices in
+;;; 3d-point-editor
+;;; 20-May-1997 I. Kalet finally fix tape measure implementation to
+;;; eliminate circularity, update tape-measure scale and origin from
+;;; here.
+;;; 22-Jun-1997 I. Kalet move "global" params to init-inst let form,
+;;; make Accept button work like Accept Cmts button on patient and
+;;; plan panels, setting when vertices are added, deleted or changed,
+;;; and reset when client sets vertices. Simplify protocol for
+;;; accept-vertices. Add set-pe-origin function to provide for
+;;; external change of origin.
+;;; 17-Apr-1998 I. Kalet add display-planar-editor when ruler is
+;;; deleted.
+;;; 23-Jun-1998 I. Kalet but not when destroying the whole panel,
+;;; because the background pixmap might have been deleted.
+;;; 25-Feb-1999 I. Kalet change primary method for delete-vertex to be
+;;; a default method to handle user deleting last vertex in digitizer
+;;; mode, when there are no vertices.
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 19-Dec-1999 I. Kalet coerce float in digitizer magnification input
+;;; 20-Jul-2000 I. Kalet take out enable-pan-zoom, now always enabled
+;;; with GL support.
+;;; 29-Jan-2003 I. Kalet raise upper limit on scale slider.
+;;; 8-Feb-2004 I. Kalet remove unnecessary get-pe-magnification method
+;;; 10-May-2004 I. Kalet merge contour editor back in here, move
+;;; digitizer stuff to digitizers module, other stuff to polygons package.
+;;; ------------ change log excerpts from contour-editor --------------
+;;; 31-May-1994 I. Kalet don't look for leader value on empty
+;;; scratch-vertices list.
+;;; 07-Jun-1994 I. Kalet make image slot (unsigned-byte 16) since we
+;;; are not providing grayscale mapped image anymore. Change back to
+;;; (unsigned-byte 8) if you restore mapping in volume-editor
+;;; 02-Mar-1997 I. Kalet change image slot back to (unsigned-byte 8),
+;;; since we are back again to autocontouring on mapped images.
+;;; 16-Jun-1997 I. Kalet take out resetting the Accept button, now
+;;; done in planar-editor. Make ACCEPT-VERTICES call planar-editor method.
+;;; 07-Jul-1997 BobGian added collinearity to set of conditions tested
+;;; when accepting a contour. Poly:CANONICAL-CONTOUR is used to remove
+;;; redundant (nearly identical) vertices and to remove vertices internal
+;;; to a chain of collinear vertices (with wraparound). Call and fixup
+;;; happens in ACCEPT-VERTICES method for class CONTOUR-EDITOR before
+;;; LEGAL-CONTOUR checks other requirements.
+;;; 5-Feb-2000 I. Kalet Allow adding contour points, breaking
+;;; segments, even in autocontour mode. Change names to lower case.
+;;; -------------------------------------------------------------------
+;;; 17-May-2004 I. Kalet continued overhaul to merge contour and point
+;;; editing
+;;; 24-Jan-2005 I. Kalet change make-contour-editor to
+;;; make-planar-editor, other fixes towards finishing the overhaul.
+;;; 26-Aug-2005 I. Kalet more changes to handle points
+;;; 24-Jun-2007 I. Kalet announce pt-selected when user clicks on a
+;;; point vertex. Also, remove event notifies for point new-color and
+;;; new-loc when planar editor is in point mode and scratch-vertices
+;;; are cleared or planar-editor is destroyed.
+;;; 25-Jun-2008 I. Kalet don't allow Auto edit mode for points
+;;; 15-Jun-2009 I. Kalet fix error in setf vertices method
+;;;
+
+(in-package :prism)
+
+;;;-----------------------------------
+
+(defparameter *ce-sketch-tolerance* 1
+ "A distance criterion that determines how closely a set of vertices
+output by reduce-contour approximates an input set of vertices traced
+out in sketch mode. The lower the number, the closer the
+approximation.")
+
+(defvar *default-point-color* 'sl:yellow
+ "determines what color new points are in the contour/point editor")
+
+;;;-----------------------------------
+
+(defclass planar-editor (generic-panel)
+
+ ((vertices :type list
+ :accessor vertices
+ :initarg :vertices
+ :documentation "The vertices to be edited. The
+coordinates are in model space (eg: cm).")
+
+ (background :type clx:pixmap
+ :accessor background
+ :initarg :background
+ :documentation "The background pixmap for the drawing
+region of the planar-editor.")
+
+ (x-origin :type fixnum
+ :accessor x-origin
+ :initarg :x-origin
+ :documentation "The x pixel coordinate of the origin of
+model space on the planar editor's picture.")
+
+ (y-origin :type fixnum
+ :accessor y-origin
+ :initarg :y-origin
+ :documentation "The y pixel coordinate of the origin of
+model space on the planar editor's picture.")
+
+ (scale :type single-float
+ :accessor scale
+ :initarg :scale
+ :documentation "The number of pixels per unit of model
+space.")
+
+ (digitizer-mag :type single-float
+ :accessor digitizer-mag
+ :initarg :digitizer-mag
+ :documentation "The magnification factor from cm on
+the digitizing tablet to cm in model space.")
+
+ (new-vertices :type ev:event
+ :accessor new-vertices
+ :initform (ev:make-event)
+ :documentation "Announced when the vertices attribute
+is updated.")
+
+ (new-origin :type ev:event
+ :accessor new-origin
+ :initform (ev:make-event)
+ :documentation "Announced when a new origin is set.")
+
+ (new-scale :type ev:event
+ :accessor new-scale
+ :initform (ev:make-event)
+ :documentation "Announced when a new scale is set.")
+
+ (pt-selected :type ev:event
+ :accessor pt-selected
+ :initform (ev:make-event)
+ :documentation "Announced when a point vertex is
+ clicked with mouse-1 by the user.")
+
+ ;; change to (unsigned-byte 16) if not using grayscale mapping for
+ ;; autocontour operations
+ (image :type (simple-array (unsigned-byte 8) 2)
+ :accessor image
+ :initarg :image
+ :documentation "The raw image array from which
+autocontouring is done. If nil, autocontouring is not available.")
+
+ (img-x0 :accessor img-x0
+ :initarg :img-x0
+ :documentation "The image pixel space x coordinate of the
+patient origin")
+
+ (img-y0 :accessor img-y0
+ :initarg :img-y0
+ :documentation "The image pixel space y coordinate of the
+patient origin")
+
+ (img-ppcm :accessor img-ppcm
+ :initarg :img-ppcm
+ :documentation "The pixels per cm scale factor of the
+image array, not necessarily the same as for the display window of the
+contour editor.")
+
+ (next-mark-id :type fixnum
+ :accessor next-mark-id
+ :initarg :next-mark-id
+ :documentation "The integer to be assigned to the
+next new mark created in the contour/point editor.")
+
+ (contour-mode :type (member t nil)
+ :accessor contour-mode
+ :initarg :contour-mode
+ :initform t
+ :documentation "A boolean flag indicating whether the
+points are connected as a contour or are individual points. If all
+points are deleted, we need to be able to retain this mode information
+somehow..")
+
+ ;;-------------------------------------------------------
+ ;; internal attributes of the planar editor from here on
+ ;;-------------------------------------------------------
+
+ (scratch-vertices :type list
+ :accessor scratch-vertices
+ :initform nil
+ :documentation "The working vertext list being
+edited, a list of vertex objects. This is the contour or set of
+points which appears on the screen.")
+
+ (scratch-points :type list
+ :accessor scratch-points
+ :initform nil
+ :documentation "A temporary placeholder for cached
+point information, for example, the temporary vertices in sketch
+mode.")
+
+ (landmarks :type list
+ :accessor landmarks
+ :initform nil
+ :documentation "A list of landmark objects.")
+
+ (tape-measure :accessor tape-measure
+ :initform nil
+ :documentation "A ruler that appears in the picture on
+demand.")
+
+ (edit-mode :type (member :manual :automatic :landmarks :digitizer)
+ :accessor edit-mode
+ :initform :manual
+ :documentation "Determines the mode for pointer
+operations in the drawing region when the pointer is not on a pickable
+object such as the ruler or a landmark, or digitizer mode.")
+
+ (color :type clx:gcontext
+ :accessor color
+ :initarg :color
+ :documentation "The color of the contour or point being edited.")
+
+ (fr :type sl:frame
+ :accessor fr
+ :documentation "The SLIK frame that contains the planar
+editor.")
+
+ (picture :type sl:picture
+ :accessor picture
+ :initform nil
+ :documentation "The picture for the drawing region. The
+picture's pixmap contains all the graphics, including a copy of the
+background pixmap and any foreground graphics, such as vertices, the
+ruler, landmarks, etc.")
+
+ (accept-btn ; :type sl:button
+ :accessor accept-btn
+ :documentation "The Accept button. Pressing it causes
+the vertices being edited to be accepted.")
+
+ (clear-btn ; :type sl:button
+ :accessor clear-btn
+ :documentation "The Clear button. Pressing it causes
+the vertices being edited to be erased, for the purposes of starting
+over.")
+
+ (tape-measure-btn :accessor tape-measure-btn
+ :documentation "The Ruler button. Pressing it causes a
+ruler to appear in the display area.")
+
+ (edit-mode-btn ; :type sl:button
+ :accessor edit-mode-btn
+ :documentation "The editing mode button.")
+
+ (scale-sdr ; :type sl:slider
+ :accessor scale-sdr
+ :documentation "The scale slider.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "The busy bit for controlling updates between
+planar editor attributes and planar editor controls.")
+
+ )
+
+ (:default-initargs :vertices nil :scale 20.0 :digitizer-mag 1.0
+ :color (sl:color-gc 'sl:green) :image nil
+ :next-mark-id 1)
+
+ (:documentation "A planar editor provides a drawing region for
+drawing and editing contours or points, and some controls for managing
+the editing process.")
+
+ )
+
+;;;-----------------------------------
+
+(defclass vertex ()
+
+ ((pe :type planar-editor
+ :accessor pe
+ :initarg :pe
+ :documentation "The planar editor in which this vertex
+appears.")
+
+ (x :accessor x
+ :initarg :x
+ :documentation "x coordinate in model space")
+
+ (y :accessor y
+ :initarg :y
+ :documentation "y coordinate in model space")
+
+ (xpix :accessor xpix
+ :initarg xpix
+ :documentation "x coordinate in pixel space on the screen")
+
+ (ypix :accessor ypix
+ :initarg ypix
+ :documentation "y coordinate in pixel space on the screen")
+
+ (marker :accessor marker
+ :documentation "The SLIK square that is the visible
+vertex on the planar editor drawing area.")
+
+ )
+
+ (:documentation "A vertex is a point of interest or a point on a
+contour.")
+
+ )
+
+;;;-----------------------------------
+
+(defclass point-vertex (vertex)
+
+ ((point :accessor point
+ :initarg :point
+ :initform nil
+ :documentation "The point or mark associated with this vertex.")
+
+ )
+
+ (:documentation "A point vertex is the visible manifestation of a
+mark object in the 2d point editor.")
+
+ )
+
+;;;-----------------------------------
+
+(defclass contour-vertex (vertex)
+
+ ((leader :accessor leader
+ :initarg :leader
+ :initform nil
+ :documentation "The boolean indicating that this vertex is
+the leading one in the contour.")
+
+ )
+
+ (:documentation "A contour-vertex is a point on a contour.")
+
+ )
+
+;;;-----------------------------------
+
+(defun display-planar-editor (pe)
+
+ "display-planar-editor pe
+
+Refreshes the planar editor drawing area with the background, the
+subject of drawing, e.g., contour or points, and the various grab
+boxes and circles, i.e., vertices, landmarks, and the tape measure."
+
+ (let* ((pic (picture pe))
+ (pm (sl:pixmap pic))
+ (size (clx:drawable-width pm)))
+ (clx:copy-area (background pe) (sl:color-gc 'sl:white)
+ 0 0 size size pm 0 0)
+ ;; draw the segments or numbers
+ (if (contour-mode pe)
+ (let ((col (color pe))
+ (sv (apply #'append ;; get a flat list of x and y pixels
+ (mapcar #'(lambda (v) (list (xpix v) (ypix v)))
+ (scratch-vertices pe)))))
+ (clx:draw-lines pm col sv)
+ ;; if there are vertices and no leading vertex, close the contour
+ (when (and sv (not (leader (first (scratch-vertices pe)))))
+ (let ((end (nthcdr (- (length sv) 2) sv)))
+ (clx:draw-line pm col
+ (first sv) (second sv)
+ (first end) (second end)))))
+ ;; draw the numbers next to each point
+ (dolist (pv (scratch-vertices pe))
+ (clx:draw-glyphs pm (sl:color-gc (display-color (point pv)))
+ (+ (xpix pv) 5) (+ (ypix pv) 10)
+ (write-to-string (id (point pv))))))
+ (if (tape-measure pe) (draw-tape-measure-tics (tape-measure pe)))
+ (sl:display-picture pic))) ;; draw the grab boxes, landmarks etc.
+
+;;;-----------------------------------
+
+(defmethod marker-motion ((vt vertex) mk xp yp state)
+
+ (if (member :button-1 (clx:make-state-keys state))
+ (let* ((pe (pe vt))
+ (ppcm (scale pe)))
+ (setf (xpix vt) xp
+ (ypix vt) yp
+ (x vt) (cm-x xp (x-origin pe) ppcm)
+ (y vt) (cm-y yp (y-origin pe) ppcm))
+ (sl:update-pickable-object mk xp yp)
+ ;; and do it when the point moves
+ (unless (sl:on (accept-btn pe))
+ (setf (sl:on (accept-btn pe)) t))
+ (display-planar-editor pe))))
+
+;;;-----------------------------------
+
+(defmethod marker-motion :after ((vt point-vertex) mk xp yp state)
+
+ (declare (ignore mk xp yp state)) ;; for now...
+ ;; this automatically announces the new-loc event
+ (let ((pe (pe vt)))
+ (when (not (busy pe))
+ (setf (busy pe) t)
+ (setf (x (point vt)) (x vt)
+ (y (point vt)) (y vt))
+ (setf (busy pe) nil))))
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((v vertex) &rest initargs
+ &key (enabled t) &allow-other-keys)
+
+ (declare (ignore initargs))
+ (let* ((pe (pe v))
+ (ppcm (scale pe))
+ (xp (pix-x (x v) (x-origin pe) ppcm))
+ (yp (pix-y (y v) (y-origin pe) ppcm)))
+ (setf (xpix v) xp
+ (ypix v) yp
+ (marker v) (sl:make-square v xp yp :enabled enabled))
+ (sl:add-pickable-obj (marker v) (picture pe))
+ ;; turn on the Accept button anytime you add a point, unless it is
+ ;; already on, or the Accept button was just turned off and new
+ ;; vertices are being added as a result (busy).
+ (unless (or (busy pe) (sl:on (accept-btn pe)))
+ (setf (sl:on (accept-btn pe)) t)) ;; no guard needed for turning on
+ (ev:add-notify v (sl:motion (marker v))
+ #'marker-motion)))
+
+;;;-----------------------------------
+
+(defmethod delete-vertex :around ((vt vertex))
+
+ (let ((pe (pe vt)))
+ (sl:remove-pickable-objs vt (picture pe))
+ (call-next-method)
+ (display-planar-editor pe)))
+
+;;;-----------------------------------
+
+(defmethod delete-vertex ((vt contour-vertex))
+
+ "for contour points, remove the vertex, make the next one leader if
+this was the leader"
+
+ (let ((pe (pe vt)))
+ (setf (scratch-vertices pe)
+ (remove vt (scratch-vertices pe)))
+ (if (and (leader vt) (scratch-vertices pe))
+ (setf (leader (first (scratch-vertices pe))) t))
+ (setf (sl:on (accept-btn pe)) t)))
+
+;;;-----------------------------------
+
+(defmethod delete-vertex ((vt point-vertex))
+
+ "for point-vertex remove the corresponding point, and let the caller
+ update everything."
+
+ (let ((pe (pe vt)))
+ (setf (vertices pe)
+ (remove-if #'(lambda (pt) (eql pt (point vt)))
+ (vertices pe)))
+ (ev:announce pe (new-vertices pe) (vertices pe))))
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((pv point-vertex) &rest initargs)
+
+ (declare (ignore initargs))
+ (setf (sl:color (marker pv))
+ (sl:color-gc (display-color (point pv))))
+ (ev:add-notify pv (new-color (point pv))
+ #'(lambda (vt pt color)
+ (declare (ignore pt))
+ (setf (sl:color (marker vt)) (sl:color-gc color))))
+ (ev:add-notify pv (new-loc (point pv))
+ #'(lambda (vt pt loc)
+ (declare (ignore pt))
+ (let* ((pe (pe vt))
+ (ppcm (scale pe)))
+ (when (not (busy pe))
+ (setf (busy pe) t)
+ (setf (x vt) (first loc)
+ (y vt) (second loc)
+ (xpix vt) (pix-x (first loc)
+ (x-origin pe) ppcm)
+ (ypix vt) (pix-y (second loc)
+ (y-origin pe) ppcm))
+ (sl:update-pickable-object (marker vt)
+ (xpix vt) (ypix vt))
+ (unless (sl:on (accept-btn pe))
+ (setf (sl:on (accept-btn pe)) t))
+ (display-planar-editor pe)
+ (setf (busy pe) nil)))))
+ (ev:add-notify pv (sl:selected (marker pv))
+ #'(lambda (vt mk code x y)
+ (declare (ignore mk x y))
+ (case code
+ (1 (let ((ped (pe vt)))
+ (ev:announce ped (pt-selected ped)
+ (point vt))))
+ (2 (delete-vertex vt))))))
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((v contour-vertex)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (let ((ce (pe v))
+ (mk (marker v)))
+ (setf (sl:color mk) (color ce)
+ (sl:filled mk) (leader v))
+ (ev:add-notify v (sl:selected (marker v))
+ #'(lambda (vt mk code x y)
+ (declare (ignore mk x y))
+ (when (= code 2) (delete-vertex vt))))))
+
+;;;-----------------------------------
+
+(defun make-point-vertex (&rest initargs)
+
+ (apply #'make-instance 'point-vertex initargs))
+
+;;;-----------------------------------
+
+(defun make-contour-vertex (&rest initargs)
+
+ (apply #'make-instance 'contour-vertex initargs))
+
+;;;-----------------------------------
+
+(defmethod (setf leader) :after (new-val (v vertex))
+
+ (setf (sl:filled (marker v)) new-val))
+
+;;;-----------------------------------
+
+(defun vertex-list (pe points)
+
+ "Returns a list of vertex objects created from the coordinate pair
+list or mark list, points, for the contour editor pe."
+
+ (mapcar #'(lambda (pt)
+ (if (contour-mode pe)
+ (make-contour-vertex :pe pe :x (first pt) :y (second pt))
+ (make-point-vertex :pe pe :x (x pt) :y (y pt)
+ :point pt)))
+ points))
+
+;;;-----------------------------------
+
+(defmethod (setf color) :after (new-color (pe planar-editor))
+
+ "When a new color is supplied in contour mode for the contour
+editor's vertices, redraw the picture with the vertices in the new color."
+
+ (if (contour-mode pe)
+ (mapc #'(lambda (vt) (setf (sl:color (marker vt)) new-color))
+ (scratch-vertices pe)))
+ (display-planar-editor pe))
+
+;;;-----------------------------------
+
+(defclass landmark ()
+
+ ((pe :type planar-editor
+ :initarg :pe
+ :accessor pe
+ :documentation "The planar editor in which the landmark
+appears.")
+
+ (x :accessor x
+ :initarg :x
+ :documentation "x coordinate in model space of the landmark")
+
+ (y :accessor y
+ :initarg :y
+ :documentation "y coordinate in model space of the landmark")
+
+ (marker :accessor marker
+ :documentation "The SLIK circle that is the visible
+landmark on the planar editor drawing area.")
+
+ )
+
+ (:documentation "A landmark is a point on the drawing area
+corresponding to a point in real space, but only 2-d, i.e., it
+persists in the same location from plane to plane if the background
+changes.")
+
+ )
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((l landmark) &rest initargs)
+
+ (declare (ignore initargs))
+ (let* ((pe (pe l))
+ (ppcm (scale pe)))
+ (setf (marker l)
+ (sl:make-circle l (pix-x (x l) (x-origin pe) ppcm)
+ (pix-y (y l) (y-origin pe) ppcm)
+ :color (sl:color-gc 'sl:cyan)))
+ (sl:add-pickable-obj (marker l) (picture pe))
+ (ev:add-notify l (sl:selected (marker l))
+ #'(lambda (lm mk code x y)
+ (declare (ignore x y))
+ (case code
+ (1 nil)
+ (2 (let ((pe (pe lm)))
+ (setf (landmarks pe)
+ (remove lm (landmarks pe)))
+ (sl:remove-pickable-objs lm (picture pe))
+ (display-planar-editor pe)))
+ (3 (let ((new-col (sl:popup-color-menu)))
+ (when new-col
+ (setf (sl:color (marker lm))
+ (sl:color-gc new-col))
+ (display-planar-editor pe)))
+ ;; the popup menu will preempt a button
+ ;; release event, so handle it here
+ (setf (sl:active mk) nil)))))
+ (ev:add-notify l (sl:motion (marker l))
+ #'(lambda (lm mk xpix ypix state)
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (let* ((pe (pe lm))
+ (ppcm (scale pe)))
+ (setf (x lm) (cm-x xpix (x-origin pe) ppcm)
+ (y lm) (cm-y ypix (y-origin pe) ppcm))
+ (sl:update-pickable-object mk xpix ypix)
+ (display-planar-editor (pe lm))))))))
+
+;;;-----------------------------------
+
+(defun make-landmark (&rest initargs)
+
+ (apply #'make-instance 'landmark initargs))
+
+;;;-----------------------------------
+
+(defun pe-rescale (pe)
+
+ "pe-rescale pe
+
+Computes new pixel coordinates for the scratch vertices & landmarks."
+
+ (let* ((ppcm (scale pe))
+ (xorig (x-origin pe))
+ (yorig (y-origin pe))
+ (pic (picture pe)))
+ (mapc #'(lambda (vt)
+ (let ((vbox (first (sl:find-pickable-objs vt pic)))
+ (xp (pix-x (x vt) xorig ppcm))
+ (yp (pix-y (y vt) yorig ppcm)))
+ (setf (xpix vt) xp
+ (ypix vt) yp
+ (sl:x-center vbox) xp
+ (sl:y-center vbox) yp)))
+ (scratch-vertices pe))
+ (mapc #'(lambda (lm)
+ (let ((lbox (first (sl:find-pickable-objs lm pic))))
+ (setf (sl:x-center lbox) (pix-x (x lm) xorig ppcm)
+ (sl:y-center lbox) (pix-y (y lm) yorig ppcm))))
+ (landmarks pe))))
+
+;;;-----------------------------------
+
+(defmethod (setf scale) :after (new-scale (pe planar-editor))
+
+ (pe-rescale pe)
+ (unless (busy pe)
+ (setf (busy pe) t)
+ (setf (sl:setting (scale-sdr pe)) new-scale)
+ (setf (busy pe) nil))
+ (when (tape-measure pe) ;; update the tape-measure scale
+ (setf (scale (tape-measure pe)) new-scale))
+ (ev:announce pe (new-scale pe) new-scale)
+ (display-planar-editor pe))
+
+;;;-----------------------------------
+
+(defun set-pe-origin (pe x0 y0)
+
+ "set-pe-origin pe x0 y0
+
+updates the x and y origins of the planar editor pe, announces
+new-origin but does not refresh the window. So it can be part of a
+sequence of updates that conclude with a single call to
+display-planar-editor to refresh the window."
+
+ (setf (x-origin pe) x0
+ (y-origin pe) y0)
+ (pe-rescale pe)
+ (when (tape-measure pe) ;; update the tape-measure origin
+ (setf (origin (tape-measure pe)) (list x0 y0)))
+ (ev:announce pe (new-origin pe) (list x0 y0)))
+
+;;;-----------------------------------
+
+(defmethod (setf background) :after (new-bkgnd (pe planar-editor))
+
+ "When a new background is supplied to the planar editor, redraw the
+picture with the new background."
+
+ (declare (ignore new-bkgnd))
+ (display-planar-editor pe))
+
+;;;-----------------------------------
+
+(defmethod (setf vertices) :after (new-verts (pe planar-editor))
+
+ "When a new list of vertices is supplied, cancel any vertices being
+edited, reset the scratch-vertices from the new vertices, and redraw
+the picture."
+
+ (declare (ignore new-verts))
+ (mapc #'(lambda (obj)
+ (sl:remove-pickable-objs obj (picture pe))
+ ;; don't depend on editor mode here
+ (when (typep obj 'point-vertex)
+ (ev:remove-notify obj (new-loc (point obj)))
+ (ev:remove-notify obj (new-color (point obj)))))
+ (scratch-vertices pe))
+ (setf (busy pe) t) ;; insure that Accept button will not turn on
+ (setf (scratch-vertices pe) (vertex-list pe (vertices pe)))
+ ;; turn off the Accept button only if it is on, i.e., when a new set
+ ;; of vertices is in and an old one was pending.
+ (if (sl:on (accept-btn pe)) (setf (sl:on (accept-btn pe)) nil))
+ (setf (busy pe) nil)
+ (display-planar-editor pe))
+
+;;;-----------------------------------
+
+(defun point-near-contour (x y sv-list)
+
+ "point-near-contour x y sv-list
+
+If the point at (x y) is near the segments determined by the scratch
+vertex list sv-list, returns the index of the trailing vertex of the
+segment (so an index of 1 through (1- (length sv)), inclusive, may be
+returned for open contours and 1 through (length sv), inclusive for
+closed contours). If (x y) is not near any segment, returns NIL."
+
+ (position t
+ (cons nil
+ (maplist #'(lambda (vt-list)
+ (when (rest vt-list)
+ (let ((x1 (xpix (first vt-list)))
+ (y1 (ypix (first vt-list)))
+ (x2 (xpix (second vt-list)))
+ (y2 (ypix (second vt-list)))
+ (tolerance 2))
+ (sl:point-near-segment x y
+ x1 y1
+ x2 y2
+ tolerance))))
+ (if (and sv-list (leader (first sv-list)))
+ sv-list ;; open list
+ (append sv-list ;; closed list
+ (list (first sv-list))))))))
+
+;;;------------------------------------
+
+(defun pe-selected (pe pic code xpix ypix)
+
+ "An action function which determines which editing operation to
+invoke when a mouse button is pressed while the pointer is over the
+picture."
+
+ (declare (ignore pic))
+ (case code
+ (1 (case (edit-mode pe)
+ ((:manual :automatic :digitizer)
+ (if (contour-mode pe)
+ (let ((ppcm (scale pe))
+ (index (point-near-contour xpix ypix
+ (scratch-vertices pe))))
+ (if index
+ (setf (scratch-vertices pe)
+ (append (subseq (scratch-vertices pe) 0 index)
+ (cons (make-contour-vertex
+ :pe pe
+ :x (cm-x xpix (x-origin pe) ppcm)
+ :y (cm-y ypix (y-origin pe) ppcm))
+ (subseq (scratch-vertices pe) index))))
+ (case (edit-mode pe)
+ ((:manual :digitizer) ;; new point or sketch
+ (let ((sv (scratch-vertices pe)))
+ (when (or (null sv) ;; no points yet, or
+ (leader (first sv))) ;; contour is still open
+ (if sv (setf (leader (first sv)) nil))
+ (push (make-contour-vertex ;; add point, maybe sketch
+ :pe pe
+ :x (cm-x xpix (x-origin pe) ppcm)
+ :y (cm-y ypix (y-origin pe) ppcm)
+ :leader t)
+ (scratch-vertices pe))
+ (setf (scratch-points pe) ;; reset with this pt only
+ (list (list xpix ypix))))))
+ (:automatic ;; automated contour using pe image data
+ (when (and (image pe) (= code 1))
+ (let* ((img (image pe))
+ (size (array-dimension img 0))
+ (img-scale (img-ppcm pe))
+ (mag (/ (scale pe) img-scale))
+ (img-x0 (img-x0 pe))
+ (img-y0 (img-y0 pe))
+ (img-x (+ (round (/ (- xpix (x-origin pe)) mag))
+ img-x0))
+ (img-y (+ (round (/ (- ypix (y-origin pe)) mag))
+ img-y0)))
+ ;; first remove old grab boxes
+ (mapc #'(lambda (obj) (sl:remove-pickable-objs
+ obj (picture pe)))
+ (scratch-vertices pe))
+ ;; then find and make new vertices
+ (setf (scratch-vertices pe)
+ (vertex-list
+ pe
+ ;; needs cm coordinates and autocon gives pixels
+ (mapcar #'(lambda (pix-pair)
+ (list (cm-x (first pix-pair)
+ img-x0 img-scale)
+ (cm-y (second pix-pair)
+ img-y0 img-scale)))
+ (autocontour img img-x img-y
+ 0 0 (1- size) (1- size)
+ *ce-sketch-tolerance*))))
+ ))))))
+ ;; point mode
+ ;; still need to get it inserted into point collection
+ (if (member (edit-mode pe) '(:manual :digitizer))
+ (let* ((ppcm (scale pe))
+ (pt (make-point (format nil "~A" (gensym "POINT-"))
+ :x (cm-x xpix (x-origin pe) ppcm)
+ :y (cm-y ypix (y-origin pe) ppcm)
+ :z 0.0 ;; reset later by volume editor
+ :id (next-mark-id pe)
+ :display-color *default-point-color*)))
+ (incf (next-mark-id pe))
+ (setf (vertices pe)
+ (append (vertices pe) (list pt)))
+ (ev:announce pe (new-vertices pe) (vertices pe))
+ ))))
+ (:landmarks (let ((ppcm (scale pe)))
+ (push (make-landmark
+ :x (cm-x xpix (x-origin pe) ppcm)
+ :y (cm-y ypix (y-origin pe) ppcm)
+ :pe pe)
+ (landmarks pe))))))
+ (2 nil) ;; button 2 is ignored
+ (3 (setf (scratch-points pe) (list xpix ypix)))) ;; button 3 does pan
+ (display-planar-editor pe))
+
+;;;-----------------------------------
+
+(defun pe-deselected (pe pic code x y)
+
+ "An action function for mouse button release while the pointer is
+over the picture. If left button and there are 3 or more temporary
+points, those points are reduced by removing duplicates, and appended
+to the scratch vertices in the planar editor pe."
+
+ (declare (ignore pic x y))
+ (if (and (contour-mode pe)
+ (eql (edit-mode pe) :manual)
+ (= code 1)
+ (third (scratch-points pe))) ;; sketch mode
+ (let ((xorig (x-origin pe))
+ (yorig (y-origin pe))
+ (ppcm (scale pe)))
+ (setf (leader (first (scratch-vertices pe))) nil)
+ (setf (scratch-vertices pe)
+ (append ;; the new ones
+ (vertex-list pe
+ ;; needs cm but reduce-contour gives pixels
+ (mapcar #'(lambda (pix-pair)
+ (list (cm-x (first pix-pair)
+ xorig ppcm)
+ (cm-y (second pix-pair)
+ yorig ppcm)))
+ (butlast
+ (reduce-contour (scratch-points pe)
+ *ce-sketch-tolerance*))))
+ (scratch-vertices pe))) ;; to the old ones
+ (setf (leader (first (scratch-vertices pe))) t)))
+ (setf (scratch-points pe) nil) ;; reset every time
+ (display-planar-editor pe))
+
+;;;-----------------------------------
+
+(defun pe-motion (pe pic x y state)
+
+ "An action function which determines what to do upon detecting
+pointer motion."
+
+ (declare (ignore pic))
+ (let ((keys (clx:make-state-keys state)))
+ (cond ;; note - button 2 down is ignored
+ ((and (member :button-1 keys);; to sketch, need all these
+ (contour-mode pe)
+ (eql (edit-mode pe) :manual)
+ (scratch-vertices pe) ;; check if there are any points
+ (leader (first (scratch-vertices pe)))) ;; and an open contour
+ (clx:draw-point (sl:window (picture pe)) (color pe) x y)
+ (push (list x y) (scratch-points pe))
+ (sl:flush-output))
+ ((member :button-3 keys) ;; pan, works in any mode
+ (set-pe-origin pe
+ (+ (x-origin pe)
+ (- x (first (scratch-points pe))))
+ (+ (y-origin pe)
+ (- y (second (scratch-points pe)))))
+ (display-planar-editor pe)
+ (setf (scratch-points pe) (list x y))))))
+
+;;;-----------------------------------
+
+(defun clear-vertices (pe bt)
+
+ "clear-vertices pe bt
+
+resets the scratch vertices to an empty list if not already empty."
+
+ (declare (ignore bt))
+ (mapc #'(lambda (vt)
+ (sl:remove-pickable-objs vt (picture pe))
+ (if (not (contour-mode pe))
+ (let ((pt (point vt)))
+ (ev:remove-notify vt (new-color pt))
+ (ev:remove-notify vt (new-loc pt)))))
+ (scratch-vertices pe))
+ (setf (scratch-vertices pe) nil)
+ ;; turn on Accept button to indicate modification
+ (setf (sl:on (accept-btn pe)) t)
+ (display-planar-editor pe))
+
+;;;-----------------------------------
+
+(defun legal-contour (sv &optional (quiet nil))
+
+ "legal-contour sv &optional (quiet nil)
+
+If sv has at least 3 vertices and does not cross over itself, then
+returns t. Otherwise, returns nil, and depending on quiet, displays a
+pop-up acknowledge box informing user of detected problem or just
+writes a line to standard output."
+
+ (let ((flat-sv (apply #'append sv)))
+ (cond ((not (sixth flat-sv))
+ (if quiet
+ (format t "~%Contour not added - fewer than three vertices.")
+ (sl:acknowledge '("Contour not accepted."
+ "It has fewer than three vertices.")))
+ nil)
+ ((not (poly:simple-polygon flat-sv))
+ (if quiet
+ (format t "~%Contour not added - it is self-intersecting.")
+ (sl:acknowledge '("Contour not accepted."
+ "Some segments would cross each other.")))
+ nil)
+ (t t))))
+
+;;;-----------------------------------
+
+(defun accept-vertices (pe bt)
+
+ "accept-vertices pe bt
+
+action function for when the ACCEPT button is turned off, signaling to
+register the temporary data in the planar editor."
+
+ (unless (busy pe)
+ ;; insures that the button will not turn on again or off redundantly
+ (setf (busy pe) t)
+ (if (contour-mode pe)
+ (let ((sv (poly:canonical-contour
+ (mapcar #'(lambda (v) ;; get x-y pairs
+ (list (x v) (y v)))
+ (scratch-vertices pe)))))
+ (cond ((legal-contour sv) ;; then pass it on
+ (setf (vertices pe) sv)
+ (ev:announce pe (new-vertices pe) (vertices pe)))
+ (t (setf (sl:on bt) t)))) ;; otherwise turn button back on
+ (ev:announce pe (new-vertices pe) (vertices pe))) ;; point mode
+ (setf (busy pe) nil)))
+
+;;;-----------------------------------
+
+(defun use-digitizer (pe)
+
+ "use-digitizer pe
+
+synchronously accepts input from sonic digitizer."
+
+ (if (digitizer-present)
+ (progn
+ (sl:push-event-level)
+ (digit-calibrate)
+ (let* ((fr (sl:make-frame 160 75 :title "Digitizer"))
+ (win (sl:window fr))
+ (mb (sl:make-textline 150 30
+ :parent win
+ :ulc-x 5 :ulc-y 5
+ :label "Mag: "
+ :numeric t
+ :lower-limit 0.1
+ :upper-limit 10.0))
+ (eb (sl:make-exit-button 150 30
+ :parent win
+ :ulc-x 5 :ulc-y 40
+ :bg-color 'sl:blue
+ :label "Accept")))
+ (setf (sl:info mb) (digitizer-mag pe))
+ (sl:process-events)
+ (setf (digitizer-mag pe)
+ (coerce (read-from-string (sl:info mb)) 'single-float))
+ (sl:destroy mb)
+ (sl:destroy eb)
+ (sl:destroy fr))
+ (let ((mag (float (/ (digitizer-mag pe))))
+ (scale (scale pe))
+ (pb (sl:make-readout 300 30 :title "Digitizer directions"))
+ state
+ x0 y0)
+ (loop
+ (setf (sl:info pb) "Please digitize the origin.")
+ (multiple-value-setq (state x0 y0) (digitize-point))
+ (when (eql state :point) (return)))
+ (loop
+ (setf (sl:info pb) "Now digitize points")
+ (multiple-value-bind (status x y) (digitize-point)
+ (case status
+ (:done (sl:destroy pb)
+ (sl:pop-event-level)
+ (accept-vertices pe (accept-btn pe)) (return))
+ (:point (pe-selected pe nil 1
+ (pix-x (* (- x x0) mag)
+ (x-origin pe) scale)
+ (pix-y (* (- y y0) mag)
+ (y-origin pe) scale)))
+ (:delete-last (delete-vertex
+ (first (scratch-vertices pe))))
+ (:delete-all (clear-vertices pe (clear-btn pe)))
+ )))))
+ (sl:acknowledge "Digitizer not available.")))
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((pe planar-editor)
+ &rest initargs &key title
+ &allow-other-keys)
+
+ "Initializes the user interface for the planar editor. The caller
+ should provide an initial value for the next-mark-id slot and the
+ contour-mode slot, if different from the default."
+
+ (let* ((pic-size (clx:drawable-height (background pe))) ;; square
+ (btw 80)
+ (bth 25)
+ (peft (symbol-value *small-font*))
+ (bt-off 5)
+ (ctrl-height (+ (* 2 bt-off) bth))
+ (frm-height (+ pic-size ctrl-height))
+ (frm (apply #'sl:make-frame pic-size frm-height
+ :title (or title "Prism Planar Editor")
+ initargs))
+ (frm-win (sl:window frm))
+ (pic (apply #'sl:make-picture pic-size pic-size
+ :parent frm-win
+ :ulc-x 0
+ :ulc-y ctrl-height
+ :border-width 0 ;; so doesn't flash
+ initargs))
+ (hspace (+ btw bt-off))
+ (accept-b (apply #'sl:make-button btw bth
+ :parent frm-win
+ :ulc-x bt-off :ulc-y bt-off
+ :font peft :label "Accept"
+ initargs))
+ (clear-b (apply #'sl:make-button btw bth
+ :parent frm-win
+ :ulc-x (+ hspace bt-off)
+ :ulc-y bt-off
+ :font peft :label "Clear"
+ :button-type :momentary
+ initargs))
+ (edit-mode-b (apply #'sl:make-button btw bth
+ :parent frm-win
+ :ulc-x (+ (* 2 hspace) bt-off)
+ :ulc-y bt-off
+ :font peft :label "Manual" ;; initial setting
+ :button-type :momentary
+ initargs))
+ (tape-measure-b (apply #'sl:make-button btw bth
+ :parent frm-win
+ :ulc-x (+ (* 3 hspace) bt-off)
+ :ulc-y bt-off
+ :font peft :label "Ruler"
+ :button-type :momentary
+ initargs))
+ (slider-x (+ (* 4 hspace) bt-off))
+ (scale-s (apply #'sl:make-slider ;; size to fit
+ (- pic-size slider-x bt-off) bth
+ 5.0 100.0 ;; lo and hi range
+ :parent frm-win
+ :setting (scale pe)
+ :ulc-x slider-x :ulc-y bt-off
+ initargs)))
+ (setf (fr pe) frm
+ (picture pe) pic
+ (scale-sdr pe) scale-s
+ (accept-btn pe) accept-b
+ (clear-btn pe) clear-b
+ (edit-mode-btn pe) edit-mode-b
+ (tape-measure-btn pe) tape-measure-b)
+ (when (vertices pe)
+ (setf (busy pe) t) ;; guard against turning Accept button on
+ (setf (scratch-vertices pe) (vertex-list pe (vertices pe)))
+ (setf (busy pe) nil))
+ (ev:add-notify pe (sl:button-press pic) #'pe-selected)
+ (ev:add-notify pe (sl:button-release pic) #'pe-deselected)
+ (ev:add-notify pe (sl:motion-notify pic) #'pe-motion)
+ (ev:add-notify pe (sl:value-changed scale-s)
+ #'(lambda (pe a new-val)
+ (declare (ignore a))
+ (when (not (busy pe))
+ (setf (busy pe) t)
+ (setf (scale pe) new-val)
+ (setf (busy pe) nil))))
+ (ev:add-notify pe (sl:button-off accept-b) #'accept-vertices)
+ (ev:add-notify pe (sl:button-on clear-b) #'clear-vertices)
+ (ev:add-notify pe (sl:button-on edit-mode-b)
+ #'(lambda (pe bt)
+ (let ((selection (sl:popup-menu '("Manual"
+ "Automatic"
+ "Landmarks"
+ "Digitizer")))
+ (old-mode (edit-mode pe)))
+ (when selection
+ (case selection
+ (0 (setf (edit-mode pe) :manual))
+ (1 (if (contour-mode pe)
+ (setf (edit-mode pe) :automatic)
+ (sl:acknowledge '("Auto mode not available"
+ "for points"))))
+ (2 (setf (edit-mode pe) :landmarks))
+ (3 (setf (edit-mode pe) :digitizer)
+ (setf (sl:label (edit-mode-btn pe))
+ "Digitizer")
+ (use-digitizer pe)
+ (setf (edit-mode pe) old-mode)))
+ (setf (sl:label (edit-mode-btn pe))
+ (case (edit-mode pe)
+ (:manual "Manual")
+ (:automatic "Auto")
+ (:landmarks "Landmarks"))))
+ (setf (sl:on bt) nil))))
+ (ev:add-notify pe (sl:button-on tape-measure-b)
+ #'(lambda (pe bt)
+ (declare (ignore bt))
+ (unless (tape-measure pe)
+ (let ((center (/ *easel-size* 2))
+ (x-origin (x-origin pe))
+ (y-origin (y-origin pe))
+ (scale (scale pe)))
+ (setf (tape-measure pe)
+ (make-tape-measure
+ :picture (picture pe)
+ :scale scale
+ :origin (list x-origin y-origin)
+ :x1 (cm-x (- center 20) x-origin scale)
+ :y1 (cm-x (- center 20) y-origin scale)
+ :x2 (cm-x (+ center 20) x-origin scale)
+ :y2 (cm-x (+ center 20) y-origin scale)))
+ (setf (sl:label (tape-measure-btn pe))
+ (write-to-string (fix-float
+ (tape-length
+ (tape-measure pe)) 2)))
+ (ev:add-notify pe (new-length (tape-measure pe))
+ #'(lambda (pe tp len)
+ (declare (ignore tp))
+ (setf (sl:label
+ (tape-measure-btn pe))
+ (write-to-string
+ (fix-float len 2)))))
+ (ev:add-notify pe (refresh (tape-measure pe))
+ #'(lambda (ped tp)
+ (declare (ignore tp))
+ (display-planar-editor
+ ped)))
+ (ev:add-notify pe (deleted (tape-measure pe))
+ #'(lambda (ped tp)
+ (declare (ignore tp))
+ (setf (sl:label
+ (tape-measure-btn ped))
+ "Ruler")
+ (setf (tape-measure ped) nil)
+ (unless (busy ped)
+ (display-planar-editor
+ ped))))
+ (display-planar-editor pe)))))))
+
+;;;-----------------------------------
+
+(defun make-planar-editor (&rest initargs)
+
+ "make-planar-editor &rest initargs
+
+Returns a contour/point editor with specified parameters."
+
+ (apply #'make-instance 'planar-editor initargs))
+
+;;;-----------------------------------
+
+(defmethod destroy :before ((pe planar-editor))
+
+ "Releases X resources used by this panel and its children."
+
+ (if (not (contour-mode pe))
+ (mapc #'(lambda (vt)
+ (let ((pt (point vt)))
+ (ev:remove-notify vt (new-color pt))
+ (ev:remove-notify vt (new-loc pt))))
+ (scratch-vertices pe)))
+ (sl:destroy (scale-sdr pe))
+ (sl:destroy (accept-btn pe))
+ (sl:destroy (clear-btn pe))
+ (sl:destroy (edit-mode-btn pe))
+ (when (tape-measure pe)
+ (setf (busy pe) t)
+ (destroy (tape-measure pe))
+ (setf (busy pe) nil))
+ (sl:destroy (tape-measure-btn pe))
+ (sl:destroy (picture pe))
+ (sl:destroy (fr pe)))
+
+;;;-----------------------------------
+;;; End.
diff --git a/prism/src/plans.cl b/prism/src/plans.cl
new file mode 100644
index 0000000..a07d0b9
--- /dev/null
+++ b/prism/src/plans.cl
@@ -0,0 +1,384 @@
+;;;
+;;; plans
+;;;
+;;; The Prism plan class and associated functions.
+;;;
+;;; 30-Jul-1992 I. Kalet created from rtp-objects and view-test
+;;; 17-Aug-1992 I. Kalet add events to plan, busy bits and action
+;;; functions to plan panel, destroy method for plan-panel
+;;; 29-Nov-1992 I. Kalet condense view-set-mediator stuff, add
+;;; table-position slot to cache this info, put in a beam when
+;;; creating one, and arrange to forward to all beams when updated.
+;;; 16-Dec-1992 I. Kalet/J. Unger add object manager code and slots in
+;;; plan class to maintain objects in views, also add image manager
+;;; 31-Dec-1992 I. Kalet provide setf method for images so can create
+;;; mediators anyway even if images are loaded after plans are
+;;; created. Also anatomy, tumor, target object mediators created by
+;;; code in patients module, not here.
+;;; 2-Mar-1993 I. Kalet don't save new-time-stamp
+;;; 11-Oct-1993 J. Unger replace old dose attributes with dose-grid,
+;;; dose-result, and dose-surfaces attributes.
+;;; 15-Oct-1993 J. Unger add dose-view manager and dose-result manager
+;;; attributes to plan definition and init-inst :after method.
+;;; 18-Oct-1993 J. Unger add organs and marks attributes to plan, add
+;;; compute-dose function to plan.
+;;; 20-Oct-1993 J. Unger add organ-dose manager slot to plan definition,
+;;; add rudimentary destroy method for plans (still needs work).
+;;; 01-Nov-1993 J. Unger add (temporary) *save-plan-dose* reference in
+;;; plan's not-saved method - determines whether dose-results are saved.
+;;; 05-Nov-1993 J. Unger add pat-id and case-id slots to plan def'n & to
+;;; plan's not-saved method. Also add table-position to not-saved method.
+;;; 6-Jan-1994 I. Kalet add pointer to patient, eliminate slots for
+;;; stuff from patient, provide reader method for table-position as
+;;; if it were a slot. Fix dose comp to get organs from patient.
+;;; 07-Feb-1994 J. Unger set back pointer from view to plan when view
+;;; is added to plan's collection of views.
+;;; 15-Feb-1994 J. Unger move initialization of (grid-vm p) from plan's
+;;; init-inst (creation time) to plan's setf patient-of :after method
+;;; (insertion time into patient's collection of plans).
+;;; 16-Feb-1994 J. Unger define plan's dose-grid from the patient's
+;;; anatomy limits.
+;;; 18-Feb-1994 D. Nguyen add copy-plan, fix dose-grid, sum-dose initargs.
+;;; 25-Apr-1994 J. Unger add code to initialize point-view manager.
+;;; 5-May-1994 J. Unger split compute-dose into compute-dose-points
+;;; and compute-dose-grid.
+;;; 17-May-1994 I. Kalet change type of comments to list of strings
+;;; 01-Jun-1994 J. Unger add :points arg to make-dose-specification-mgr
+;;; 02-Jun-1994 J. Unger change time-stamp attribute from read-only to
+;;; read-write, implement way to update plan's time-stamp when appropriate.
+;;; 8-Jun-1994 J. Unger remove refs to tsm (vestigial). Add function
+;;; write-dose-info; take out old system for saving dose to the
+;;; checkpoint database.
+;;; 13-Jun-1994 I. Kalet make destroy primary method instead of :before
+;;; 21-Jun-1994 I. Kalet declare time-stamp to be slot type :timestamp
+;;; 30-Jun-1994 I. Kalet delete function references to brachy for now.
+;;; 07-Jul-1994 J. Unger add copy-name param to copy-beam in copy-plan.
+;;; 25-Aug-1994 J. Unger change :overwrite to :supersede in write-dose-info.
+;;; 26-Sep-1994 J. Unger enhance copy-plan to copy dose surfaces, comments,
+;;; and plan author as well.
+;;; 11-Oct-1994 J. Unger modify documentation string for copy-plan.
+;;; 19-Jan-1995 I. Kalet Delete all the views when destroying a plan.
+;;; Add notify on beam's update-plan event when inserting a beam into
+;;; the beam set. Remove table-position, not needed. Remove refs to
+;;; plan-of back-pointer for views. Pass plan to beam-view-mediator.
+;;; Move compute-dose stuff to dosecomp. Don't set beam back-pointer,
+;;; it has been deleted. Do new-coll-set registration on insert of
+;;; beam in beam set, for restoration from file system.
+;;; 5-Mar-1995 I. Kalet finally remove patient-of back pointer, move
+;;; code to initialize-instance method and to patient-plan-mediator.
+;;; Now can destroy view on deletion here since it is not drawn into
+;;; from elsewhere on deletion.
+;;; 1-Jun-1995 I. Kalet name is now a required parameter to
+;;; make-dose-surface, not a keyword parameter. Also must initialize
+;;; dose surfaces as they are inserted here, for reading from file.
+;;; 27-Jul-1995 I. Kalet add missing initarg declaration for dose-grid.
+;;; 9-Jun-1996 I. Kalet add support for line sources and seeds, take
+;;; out redundant registrations when beams inserted.
+;;; 20-May-1997 I. Kalet only pass view set, not plan, to
+;;; beam-view-mediator constructor, to avoid circularity.
+;;; 26-Jun-1997 I. Kalet take out redundant setting name of dose
+;;; surface, use flet in init-inst method, init stuff in make-plan.
+;;; 4-Jul-1997 I. Kalet fix error - actually return plan in
+;;; make-plan.
+;;; 15-Aug-1997 I. Kalet put make-grid-geometry in initform, not in
+;;; make-plan. If it gets replaced by dose grid from data file, it is
+;;; still ok, since registrations happen afterward.
+;;; 5-Mar-2000 I. Kalet replace copy-beam with just copy.
+;;; 29-Mar-2000 I. Kalet mods for brachy, made and rescinded.
+;;; 14-Oct-2001 I. Kalet copy retains original name and time stamp,
+;;; so if change is desired, caller must do it to the copy. This is
+;;; the same semantics of copy for other things.
+;;; 6-Oct-2002 I. Kalet combined line and seed view-mediators into
+;;; single brachy-view-mediator class so just use that.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass plan (generic-prism-object)
+
+ ((comments :type list
+ :initarg :comments
+ :accessor comments
+ :documentation "Multiple lines of text to be printed on
+the chart")
+
+ (new-comments :type ev:event
+ :initform (ev:make-event)
+ :accessor new-comments
+ :documentation "Announced when the comments are
+updated.")
+
+ (time-stamp :type string
+ :initform (date-time-string)
+ :accessor time-stamp)
+
+ (new-time-stamp :type ev:event
+ :accessor new-time-stamp
+ :initform (ev:make-event)
+ :documentation "Announced when the time-stamp is
+updated.")
+
+ (plan-by :type string ; nice to know who did it
+ :initarg :plan-by
+ :accessor plan-by)
+
+ (new-plan-by :type ev:event
+ :initform (ev:make-event)
+ :accessor new-plan-by
+ :documentation "Announced when the plan-by attribute
+is updated.")
+
+ (prescription-used :initarg :prescription-used ; a target object
+ :accessor prescription-used)
+
+ (beams :initform (coll:make-collection)
+ :accessor beams)
+
+ (line-sources :initform (coll:make-collection)
+ :accessor line-sources)
+
+ (seeds :initform (coll:make-collection)
+ :accessor seeds)
+
+ (beam-vm :accessor beam-vm
+ :documentation "The beams-views-manager.")
+
+ (line-vm :accessor line-vm
+ :documentation "The line-sources-views-manager.")
+
+ (seed-vm :accessor seed-vm
+ :documentation "The seeds-views-manager.")
+
+ (history :initarg :history ; past modifications
+ :accessor history)
+
+ (dose-grid :type grid-geometry
+ :initarg :dose-grid
+ :accessor dose-grid
+ :initform (make-grid-geometry)
+ :documentation "The plan's dose grid specification.")
+
+ (sum-dose :type dose-result
+ :initarg :sum-dose
+ :initform (make-dose-result)
+ :accessor sum-dose
+ :documentation "The plan's summed dose results from all
+radiation sources are stored here. It can be created blank since
+results are not saved in files.")
+
+ (dose-surfaces ; :type coll:collection
+ :initform (coll:make-collection)
+ :accessor dose-surfaces
+ :documentation "A collection of dose-surface objects")
+
+ (plan-views :initform (coll:make-collection)
+ :accessor plan-views)
+
+ (vsm :accessor vsm
+ :documentation "The view-set-mediator for this plan. Needed
+to manage the locator bars that should appear in the various
+cross-sectional views.")
+
+ (dose-vm :accessor dose-vm
+ :documentation "The dose-view manager.")
+
+ (grid-vm :accessor grid-vm
+ :documentation "The grid-view manager.")
+
+ (drm :accessor drm
+ :documentation "The plan's dose-result manager.")
+
+ )
+
+ (:default-initargs :name "" :comments '("") :plan-by ""
+ :prescription-used nil :history nil)
+
+ (:documentation "A plan specifies how a given patient is to be
+treated, but does not needlessly replicate the anatomy or other
+patient information that is the same for all of a collection of
+plans.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod slot-type ((object plan) slotname)
+
+ (case slotname
+ ((beams line-sources seeds dose-surfaces) :collection)
+ ((dose-grid sum-dose) :object)
+ (patient-of :ignore)
+ (time-stamp :timestamp)
+ (otherwise :simple)))
+
+;;;--------------------------------------
+
+(defmethod not-saved ((object plan))
+
+ (append
+ (call-next-method)
+ '(new-comments new-time-stamp new-plan-by prescription-used
+ sum-dose history plan-views
+ beam-vm line-vm seed-vm dose-vm grid-vm vsm drm)))
+
+;;;--------------------------------------
+
+(defmethod (setf name) :after (text (p plan))
+
+ (declare (ignore text))
+ (setf (time-stamp p) (date-time-string)))
+
+;;;--------------------------------------
+
+(defmethod (setf comments) :after (text (p plan))
+
+ (setf (time-stamp p) (date-time-string))
+ (ev:announce p (new-comments p) text))
+
+;;;--------------------------------------
+
+(defmethod (setf plan-by) :after (text (p plan))
+
+ (setf (time-stamp p) (date-time-string))
+ (ev:announce p (new-plan-by p) text))
+
+;;;--------------------------------------
+
+(defmethod (setf time-stamp) :after (new-time (p plan))
+
+ (ev:announce p (new-time-stamp p) new-time))
+
+;;;--------------------------------------
+
+(defun make-plan (name &rest initargs)
+
+ "make-plan name &rest initargs
+
+returns a plan with the specified initial values. Certain
+initialization is done here rather than in the initialize-instance
+method, in order to correctly initialize object-valued slots both here
+and from files."
+
+ (let ((pl (apply #'make-instance 'plan
+ :name (if (equal name "")
+ (format nil "~A" (gensym "PLAN-"))
+ name)
+ initargs)))
+ ;; update the plan's timestamp when dose grid changes
+ (ev:add-notify pl (new-coords (dose-grid pl))
+ #'(lambda (pln a)
+ (declare (ignore a))
+ (setf (time-stamp pln) (date-time-string))))
+ (ev:add-notify pl (new-voxel-size (dose-grid pl))
+ #'(lambda (pln a v)
+ (declare (ignore a v))
+ (setf (time-stamp pln) (date-time-string))))
+ ;; set internal components of initial dose surfaces
+ (dolist (s (coll:elements (dose-surfaces pl)))
+ (setf (dose-grid s) (dose-grid pl)
+ (result s) (sum-dose pl)))
+ ;; and arrange for each new dose surface to get set similarly
+ (ev:add-notify pl (coll:inserted (dose-surfaces pl))
+ #'(lambda (pln ann ds)
+ (declare (ignore ann))
+ (setf (dose-grid ds) (dose-grid pln)
+ (result ds) (sum-dose pln))))
+ (setf (grid-vm pl) (make-object-view-manager
+ (coll:make-collection (list (dose-grid pl)))
+ (plan-views pl)
+ #'make-grid-view-mediator))
+ pl))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((p plan) &rest initargs)
+
+ "Takes care of things local to plans."
+
+ (declare (ignore initargs))
+ (setf (vsm p) (make-view-set-mediator (plan-views p)))
+ (setf (beam-vm p) (make-object-view-manager
+ (beams p) (plan-views p)
+ #'(lambda (bm vw) ;; needed for extra parameter
+ (make-beam-view-mediator bm vw
+ (plan-views p)))))
+ (setf (line-vm p) (make-object-view-manager
+ (line-sources p) (plan-views p)
+ #'make-brachy-view-mediator))
+ (setf (seed-vm p) (make-object-view-manager
+ (seeds p) (plan-views p)
+ #'make-brachy-view-mediator))
+ (setf (dose-vm p) (make-object-view-manager
+ (dose-surfaces p) (plan-views p)
+ #'make-dose-view-mediator))
+ (setf (drm p) (make-dose-result-manager
+ :beams (beams p) :seeds (seeds p)
+ :line-sources (line-sources p)
+ :result (sum-dose p)))
+ (ev:add-notify p (coll:deleted (plan-views p))
+ #'(lambda (pln vs vw)
+ (declare (ignore pln vs))
+ (destroy vw)))
+ (flet ((plan-update-action (pln coll src)
+ (declare (ignore coll))
+ (ev:add-notify pln (update-plan src)
+ #'(lambda (pl s)
+ (declare (ignore s))
+ (setf (time-stamp pl) (date-time-string))))
+ (setf (time-stamp pln) (date-time-string))))
+ (ev:add-notify p (coll:inserted (beams p))
+ #'plan-update-action)
+ (ev:add-notify p (coll:inserted (line-sources p))
+ #'plan-update-action)
+ (ev:add-notify p (coll:inserted (seeds p))
+ #'plan-update-action))
+ (ev:add-notify p (coll:deleted (beams p))
+ #'(lambda (pln ann bm)
+ (declare (ignore ann bm))
+ (setf (time-stamp pln) (date-time-string))))
+ (ev:add-notify p (coll:deleted (line-sources p))
+ #'(lambda (pln ann ln)
+ (declare (ignore ann ln))
+ (setf (time-stamp pln) (date-time-string))))
+ (ev:add-notify p (coll:deleted (seeds p))
+ #'(lambda (pln ann sd)
+ (declare (ignore ann sd))
+ (setf (time-stamp pln) (date-time-string)))))
+
+;;;--------------------------------------
+
+(defmethod copy ((pl plan))
+
+ "Copies and returns a new instance of a plan."
+
+ (let ((new-plan (make-plan (name pl)
+ :history (history pl)
+ :dose-grid (copy (dose-grid pl))
+ :sum-dose (copy (sum-dose pl))
+ :prescription-used (prescription-used pl)
+ :plan-by (copy-seq (plan-by pl))
+ :comments (mapcar #'copy-seq
+ (comments pl)))))
+ ;; copy the beams, line sources, seeds, and dose surfaces, and add
+ ;; them to the new plan's respective collections
+ (dolist (bm (coll:elements (beams pl)))
+ (coll:insert-element (copy bm) (beams new-plan)))
+ (dolist (src (coll:elements (line-sources pl)))
+ (coll:insert-element (copy src) (line-sources new-plan)))
+ (dolist (sd (coll:elements (seeds pl)))
+ (coll:insert-element (copy sd) (seeds new-plan)))
+ (dolist (ds (coll:elements (dose-surfaces pl)))
+ (coll:insert-element (copy ds) (dose-surfaces new-plan)))
+ (setf (time-stamp new-plan) (time-stamp pl))
+ new-plan))
+
+;;;--------------------------------------
+
+(defmethod destroy ((p plan))
+
+ (dolist (vw (coll:elements (plan-views p)))
+ (coll:delete-element vw (plan-views p))))
+
+;;;---------------------------------------------
diff --git a/prism/src/plots.cl b/prism/src/plots.cl
new file mode 100644
index 0000000..788a009
--- /dev/null
+++ b/prism/src/plots.cl
@@ -0,0 +1,1233 @@
+;;;
+;;; plots
+;;;
+;;; The plot class definitions, draw methods and related functions
+;;;
+;;; 14-Jan-1994 J. Unger started.
+;;; 10-Feb-1994 J. Unger finish adding textual items to plot.
+;;; 14-Feb-1994 I. Kalet put sl: package name in call to acknowledge
+;;; 14-Feb-1994 J. Unger enhance hp7550a init-inst to handle big page size
+;;; 18-Feb-1994 J. Unger add code to print isodose labels on plot.
+;;; 02-Mar-1994 J. Unger change 'mu' --> 'cGy' in a couple places.
+;;; 06-Apr-1994 J. Unger get plotter device name from configurable const.
+;;; 06-Apr-1994 J. Unger put plotter popup menu in interactive-make-plot.
+;;; 17-May-1994 I. Kalet move globals to prism-globals and consolidate.
+;;; 8-Jun-1994 J. Unger add beam name to bev plots.
+;;; 24-Jun-1994 J. Unger fix color bug in interactive-make-plot
+;;; 09-Aug-1994 J. Unger make plot draw in off-screen view.
+;;; 30-Aug-1994 J. Unger fix bug in off-screen view creation for bev's.
+;;; 03-Oct-1994 J. Unger add support for dashed colors.
+;;; 13-Jan-1995 I. Kalet get table-position from view, not plan. Get
+;;; plan and patient as passed parameters to interactive-make-plot.
+;;; 31-May-1995 I. Kalet DON'T destroy the view at the end of
+;;; make-plot. It is done when the view is deleted from the view set.
+;;; 3-Sep-1995 I. Kalet make Mag: textline numeric - should have
+;;; been...also force single float arguments to nearly-equal.
+;;; 8-Oct-1996 I. Kalet remove &rest parameter from draw method, add
+;;; package name to find-solid-color, as it is moved to slik.
+;;; 21-Jan-1997 I. Kalet eliminate table-position.
+;;; 03-Jul-1997 BobGian updated nearly-xxx -> poly:nearly-xxx .
+;;; 19-May-1998 I. Kalet move max-plane-dose to dose-surface-graphics,
+;;; reorganize, and add Postscript plot type.
+;;; 11-Jun-1998 I. Kalet fix call to make-view to use :beam-for
+;;; 2-Jul-1998 I. Kalet make yellow map to black on PostScript plots.
+;;; Also coerce mag factor to single-float in dialog box.
+;;; 10-Jul-1998 I. Kalet print 2 digits to the right of the decimal
+;;; point for the view position, instead of 1.
+;;; 13-Oct-1998 I. Kalet add gray scale image output to the PostScript
+;;; printer.
+;;; 14-Dec-1998 I. Kalet add hp455c-plot. Still need a way to map
+;;; yellow to black.
+;;; 24-Dec-1998 I. Kalet remove wait t in run-subprocess, now default
+;;; 11-Jan-1999 I. Kalet reorganize page size info in order to add 14
+;;; by 17 inch page size and other orientations.
+;;; 1-Feb-1999 I. Kalet fix error in plot scaling parameters for
+;;; small page sizes in dj455c plot initialization. Every device uses
+;;; slightly different HP-GL coordinate conventions.
+;;; 15-Feb-1999 I. Kalet fix error in draw method for image in
+;;; PostScript plot - which image origin coordinates to use depends on
+;;; type of view you are plotting.
+;;; 3-May-1999 I. Kalet mods to support multiple colormaps for X -
+;;; the SLIK color symbols now hold lists of stuff, not just a
+;;; gcontext for the default colormap.
+;;; 8-Aug-2000 I. Kalet add capability for drawing cross hatch
+;;; interiors for contours in Postscript plots. Also, condense
+;;; slightly initialization code for HP 455C plots.
+;;; 26-Nov-2000 I. Kalet cosmetics for buttons in dialog box.
+;;; 26-Dec-2000 I. Kalet add :use-gl parameter to view, so can avoid
+;;; mysterious GL problem in off screen view.
+;;; 11-Mar-2001 I. Kalet print view position on plot to 3 decimal places.
+;;; 31-Dec-2001 I. Kalet remove black background from CT on plot, by
+;;; doing a raster left-right fill. Parametrize the value range that
+;;; will be considered black by the conversion.
+;;; 6-Jan-2002 I. Kalet add window and level at bottom of plot
+;;; 13-Jan-2002 I. Kalet add number of copies and black background
+;;; option on plot panel, make default black for BEV with DRR.
+;;; 17-Mar-2002 I. Kalet add plot page rectangle in view as "preview"
+;;; and don't make plot panel a dialog box, but allow other controls
+;;; to operate while it is up. Change interactive-make-plot to
+;;; make-plot-panel, returns instance of the new plot-panel class.
+;;; 1-Nov-2003 I. Kalet move push-plot-text macro so it is compiled
+;;; before it is referenced.
+;;; 3-Jan-2009 I. Kalet NOTE that plots of room-views are NOT
+;;; supported because you can't NOT use OpenGL. Will fix this later.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------------
+
+(defparameter *plotter-row-height* 0.5
+ "The height, in cm, of a row of plotted text.")
+
+(defvar *image-black* 0
+ "The threshold for changing black background to white.")
+
+;;;----------------------------------------------------
+
+;;; The page-width's and page-height's are currently limited by the
+;;; hard-clip limits of the HP 7550A pen plotter - See the HP
+;;; Interfacing and Programming Manual, page 2-9. We use the same for
+;;; Postscript and DesignJet plots, although the limits are more
+;;; permissive there.
+
+(defvar *plot-sizes* '((small "8.5x11" 19.05 25.4)
+ (wide-small "11x8.5" 25.4 19.05)
+ (ledger "17x11" 40.64 25.4)
+ (large "11x17" 25.4 40.64)
+ (film "14x17" 33.0 40.64)
+ (wide-film "17x14" 40.64 33.0)
+ (a4 "A4" 18.46 27.16)
+ (a4-wide "A4 wide" 27.16 18.46)
+ (a3 "A3" 27.16 39.46)
+ (a3-wide "A3 wide" 39.46 27.16)
+ )
+ "Table of symbol, name, width and height in cm, for the available
+plot sizes. The sizes allow 1/2 inch margins.")
+
+;;;----------------------------------------------------
+
+(defclass plot (generic-prism-object)
+
+ ((page-size :type symbol
+ :accessor page-size
+ :initarg :page-size
+ :documentation "Symbol, small, large, or film,
+ indicating the physical page size of the plot.")
+
+ (magnification :type single-float
+ :accessor magnification
+ :initarg :magnification
+ :documentation "The plot's magnification, in relation
+to patient space.")
+
+ (patient-name :accessor patient-name
+ :initarg :patient-name
+ :documentation "The name of the patient, a string,
+all we need from the patient case, for the plot.")
+
+ (plan :accessor plan
+ :initarg :plan
+ :documentation "The plan that is being plotted.")
+
+ (view :accessor view
+ :initarg :view
+ :documentation "An off-screen view, into which the graphics
+to be plotted are drawn.")
+
+ (width :accessor width
+ :initarg :width
+ :documentation "The off-screen view width in pixels.")
+
+ (height :accessor height
+ :initarg :height
+ :documentation "The off-screen view height in pixels.")
+
+ (upperband :accessor upperband
+ :documentation "The height in pixels of the upper band
+of plot label text")
+
+ (lowerband :accessor lowerband
+ :documentation "The height in pixels of the lower band
+of plot label text")
+
+ (current-pen-color :accessor current-pen-color
+ :initform 0
+ :documentation "Keeps track of current color, so
+on the HP pen plotter can avoid changing pens when not necessary.")
+
+ (text-color :accessor text-color
+ :initarg :text-color
+ :documentation "A SLIK symbol specifying the color to
+use for text primitives on the plot. It may be different for
+different plot devices.")
+
+ (colormap :type list
+ :accessor colormap
+ :initarg :colormap
+ :documentation "A list of gcontexts representing SLIK
+colors. For a HP pen plot, the index of a color on the list is the
+plotter pen assignment for that color. For a PostScript plot, the
+Postscript RGB color specification string is found at that index in a
+separate table.")
+
+ (output-stream :accessor output-stream
+ :initarg :output-stream
+ :documentation "The stream to a file, into which
+HP-GL or other plotting commands are sent.")
+
+ )
+
+ (:default-initargs :page-size 'small :magnification 1.0
+ :orientation 'portrait
+ :colormap (mapcar #'sl:color-gc
+ '(sl:black sl:red sl:blue
+ sl:magenta sl:green sl:white
+ sl:yellow sl:cyan sl:gray))
+ :output-stream nil)
+
+ (:documentation "The general plot class for all types of plots.")
+
+ )
+
+;;;----------------------------------------------------
+
+(defmacro push-plot-text (text x y inc plt)
+
+ "push-plot-text text x y inc plt
+
+Makes a characters-prim graphic primitive from text, x, y, and the
+plot text-color and pushes it onto plt's list of graphic primitives.
+The x and y parameters are the location of the text on the plot. Also
+increments y by inc, so that this macro can be called many times in
+succession to generate a column of text."
+
+ `(progn
+ (push (make-characters-prim
+ ,text ,x ,y (sl:color-gc (text-color ,plt)) :object ,plt)
+ (foreground (view ,plt)))
+ (incf ,y ,inc)))
+
+;;;----------------------------------------------------
+
+(defmethod initialize-instance :after ((plt plot) &rest initargs)
+
+ "does the generic initialization, assuming certain slots are
+initialized by initargs."
+
+ (declare (ignore initargs))
+ (let* ((mag (magnification plt))
+ (plot-width (width plt))
+ (plot-height (height plt))
+ (init-y (round (* (scale (view plt)) *plotter-row-height*
+ (/ mag))))
+ (init-x (round (/ init-y 2)))
+ (text-x init-x)
+ (text-y init-y)
+ (y-inc init-y)
+ (x-inc (* 5 init-y)) ;; for plotting dose values at bottom
+ (pln (plan plt))
+ (max-dose (max-plane-dose (view plt) (dose-grid pln)
+ (sum-dose pln)))
+ (dose-key (mapcar #'(lambda (srf)
+ (list (round (threshold srf))
+ (sl:color-gc (display-color srf))))
+ (coll:elements (dose-surfaces pln)))))
+ ;; make a graphic primitive for the rectangular border
+ (push (make-rectangles-prim (list 0 0 plot-width plot-height)
+ (sl:color-gc (text-color plt))
+ :object plt)
+ (foreground (view plt)))
+
+ ;; institutional header
+ (dolist (txt *hardcopy-header*)
+ (push-plot-text txt text-x text-y y-inc plt))
+ ;; make graphic primitives for various text items at top of plot
+ (incf text-y y-inc)
+ (push-plot-text (patient-name plt) text-x text-y y-inc plt)
+ (push-plot-text (name pln) text-x text-y y-inc plt)
+ (push-plot-text (time-stamp pln) text-x text-y y-inc plt)
+ (push-plot-text (concatenate 'string "Plot Magnification: "
+ (write-to-string mag))
+ text-x text-y y-inc plt)
+ (setf (upperband plt) text-y) ;; for clipping images
+ ;; make graphic primitives for various text items at bottom
+ ;; only print out dose-specific info if non-zero max dose
+ (if (zerop max-dose) (setq text-y (- plot-height init-y)
+ y-inc (- y-inc))
+ (progn
+ (setq text-y (- plot-height init-y
+ (* y-inc (1+ (floor (length dose-key) 6)))))
+ (push-plot-text "Isodose levels (cGy):" text-x text-y y-inc plt)
+ (setq text-x (* 3 init-x))
+ (setq dose-key (sort dose-key #'< :key #'first))
+ (let ((count 0))
+ (dolist (pair dose-key)
+ (push (make-characters-prim (write-to-string (first pair))
+ text-x text-y (second pair)
+ :object plt)
+ (foreground (view plt)))
+ (incf count)
+ (if (zerop (mod count 6))
+ (setq text-x (* 3 init-x)
+ text-y (+ text-y y-inc))
+ (incf text-x x-inc))))
+ (setq text-x init-x)
+ (setq text-y (- plot-height init-y
+ (* y-inc (+ 2 (floor (length dose-key) 6)))))
+ (setq y-inc (- y-inc))
+ (push-plot-text (concatenate 'string
+ "Grid Size: "
+ (write-to-string (voxel-size (dose-grid pln)))
+ " cm")
+ text-x text-y y-inc plt)
+ (push-plot-text (concatenate 'string
+ "Max Dose: "
+ (write-to-string max-dose) " cGy")
+ text-x text-y y-inc plt)))
+ ;; print the plot position and orientation in any case
+ (push-plot-text (format nil "Plot Position: ~A~6,3F cm"
+ (typecase (view plt)
+ (transverse-view "Z=")
+ (coronal-view "Y=")
+ (sagittal-view "X=")
+ (beams-eye-view "D="))
+ (view-position (view plt)))
+ text-x text-y y-inc plt)
+ (if (typep (view plt) 'beams-eye-view)
+ (push-plot-text (format nil "Beam Name: ~A"
+ (name (beam-for (view plt))))
+ text-x text-y y-inc plt))
+ (push-plot-text (format nil "Plot Orientation: ~A Window=~A, Level=~A"
+ (typecase (view plt)
+ (transverse-view "Transverse")
+ (coronal-view "Coronal")
+ (sagittal-view "Sagittal")
+ (beams-eye-view "Beam's Eye"))
+ (window (view plt)) (level (view plt)))
+ text-x text-y y-inc plt)
+ (setf (lowerband plt) (- plot-height text-y)))
+ (setf (output-stream plt)
+ (open *plotter-file* :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)))
+
+;;;----------------------------------------------------
+
+(defmethod finish-plot ((plt plot))
+
+ ;; remove the off screen view from the plan view collection - this
+ ;; destroys the view
+ (coll:delete-element (view plt) (plan-views (plan plt))))
+
+;;;----------------------------------------------------
+
+(defun draw-isodose-labels (plt x-sep y-sep width height)
+
+ "draw-isodose-labels plt x-sep y-sep width height
+
+Creates a characters primitive containing a label for each unconnected
+isodose contour segment in plot plt, and adds those primitives to
+plt's list of graphic primitives. The labels are added in a manner so
+that no two labels fall within the same x-sep by y-sep box, and no
+label is printed outside the frame determined by 0,0 and width,height
+since otherwise they would be off the page."
+
+ (let* ((label-list nil)
+ (dose-prims (remove-if-not
+ #'(lambda (prim)
+ (and (slot-boundp prim 'object)
+ (typep (object prim) 'dose-surface)))
+ (foreground (view plt)))))
+ (dolist (prim dose-prims)
+ (dolist (curve (points prim))
+ (do* ((ptr curve (rest (rest ptr)))
+ (x-pos (first ptr) (first ptr))
+ (y-pos (second ptr) (second ptr))
+ (done nil))
+ ((or done (null ptr)))
+ (when (and (<= 0 x-pos (- width x-sep))
+ (<= y-sep y-pos height)
+ (notany #'(lambda (l)
+ (and (poly:nearly-equal
+ (coerce x-pos 'single-float)
+ (coerce (first l)
+ 'single-float)
+ x-sep)
+ (poly:nearly-equal
+ (coerce y-pos 'single-float)
+ (coerce (second l)
+ 'single-float)
+ y-sep)))
+ label-list))
+ (push (list x-pos y-pos) label-list)
+ (push (make-characters-prim
+ (write-to-string (round (threshold (object prim))))
+ x-pos y-pos (color prim)
+ :object plt)
+ (foreground (view plt)))
+ (setq done t)))))))
+
+;;;----------------------------------------------------
+
+(defclass plot-box (generic-panel)
+
+ ((view-for :accessor view-for
+ :initarg :view-for
+ :documentation "The on-screen view to be plotted, not the
+temporary internal off-screen view used to actually generate the plot.")
+
+ (view-panel :accessor view-panel
+ :initarg :view-panel)
+
+ (plan-of :accessor plan-of
+ :initarg :plan-of)
+
+ (patient :accessor patient
+ :initarg :patient)
+
+ (pframe :accessor pframe
+ :documentation "The plot panel frame.")
+
+ (black-btn :accessor black-btn
+ :documentation "A button to set the background to black
+or white when an image is displayed in the view")
+
+ (black-off :accessor black-off
+ :initarg :black-off
+ :documentation "Boolean, t if the background is to be
+changed to white when an image is present, and nil if the background
+is to be black")
+
+ (mag-tln :accessor mag-tln
+ :documentation "A text line to specify the plot
+magnification factor, where 1.0 means life-size.")
+
+ (mag :accessor mag
+ :initform 1.0)
+
+ (copies-tln :accessor copies-tln
+ :documentation "A text line to set the number of
+copies, if you want multiple copies of a plot")
+
+ (numcopies :accessor numcopies
+ :initform 1)
+
+ (size-menu :accessor size-menu
+ :documentation "A menu to select from the available
+paper sizes and orientations.")
+
+ (page-size :accessor page-size)
+
+ (pmenu :accessor pmenu
+ :documentation "A menu to select from the available plotters")
+
+ (plotter :accessor plotter)
+
+ (accept-btn :accessor accept-btn
+ :documentation "A button that produces the plot and
+removes the panel when pressed.")
+
+ (cancel-btn :accessor cancel-btn
+ :documentation "A button that removes the panel
+without producing a plot, when pressed.")
+
+ )
+ (:documentation "A plot box is a panel that comes up to specify the
+ parameters of a hard copy plot for a view, and to make the plot
+ when the accept button is pressed.")
+ )
+
+;;;----------------------------------------------------
+
+(defun do-plot (pbox)
+
+ "do-plot pbox
+
+Makes and spools a plot of the appropriate type for the specified
+queue, plotter, magnification factor, page size, view, plan and
+patient case, all specified in pbox, an instance of a plot-box."
+
+ (let* ((plotter (plotter pbox))
+ (mag (mag pbox))
+ (page-size (page-size pbox))
+ (vw (view-for pbox))
+ (pln (plan-of pbox))
+ (pat (patient pbox))
+ (scale (scale vw))
+ (size-data (find page-size *plot-sizes* :key #'first))
+ (plot-width (round (* scale (third size-data)
+ (/ mag))))
+ (plot-height (round (* scale (fourth size-data)
+ (/ mag))))
+ (vw-picwin (sl:window (picture vw)))
+ (plt (make-instance (second ;; gives the plot type for plotter
+ (find plotter *plotters*
+ :key #'first :test #'string-equal))
+ :name plotter
+ :page-size page-size
+ :magnification mag
+ :patient-name (name pat)
+ :plan pln
+ :width plot-width
+ :height plot-height
+ :view
+ (make-view plot-width plot-height (type-of vw)
+ :scale scale
+ :window (window vw)
+ :level (level vw)
+ :view-position (view-position vw)
+ :beam-for (if (typep vw 'beams-eye-view)
+ (beam-for vw))
+ :x-origin (round (+ (x-origin vw)
+ (/ (- plot-width
+ (clx:drawable-width
+ vw-picwin))
+ 2)))
+ :y-origin (round (+ (y-origin vw)
+ (/ (- plot-height
+ (clx:drawable-height
+ vw-picwin))
+ 2)))))))
+ ;; add the off-screen view to the plan view collection, which will
+ ;; generate all the graphic primitives in the off-screen view
+ (coll:insert-element (view plt) (plan-views pln))
+ ;; now add isodose labels, since the above has generated the
+ ;; graphic prims for isodose curves, if they are there
+ (let ((init-y (round (* scale *plotter-row-height* (/ mag)))))
+ (draw-isodose-labels plt (* init-y 2.25) (* init-y 0.75)
+ plot-width plot-height))
+ ;; draw the background image first if present
+ (when (background-displayed vw) ;; the image button was pressed
+ ;; find the image corresponding to view vw by looking through
+ ;; the image-view mediators of the image manager for the plan.
+ (setf (black-off plt) (black-off pbox))
+ (let ((img-vw-mgr (im-vm (find pln (coll:elements
+ (pat-plan-mediator-set
+ pat))
+ :key #'the-plan))))
+ ;; also check that there is a study loaded
+ (when img-vw-mgr
+ (draw (image (find vw (coll:elements
+ (mediator-set img-vw-mgr))
+ :key #'view))
+ plt))))
+ ;; sort graphic primitives by color - copy since sort is destructive
+ (setf (foreground (view plt))
+ (sort (copy-list (foreground (view plt)))
+ #'(lambda (pr1 pr2)
+ (< (pen-color (color pr1) plt)
+ (pen-color (color pr2) plt)))))
+ ;; then draw all the primitives, i.e., write to file
+ (dolist (prim (foreground (view plt)))
+ (let ((original (find (object prim) (foreground vw)
+ :key #'object)))
+ (if (or (not original) ;; always draw the added text stuff
+ (visible original))
+ (draw prim plt))))
+ (finish-plot plt)
+ (close (output-stream plt))
+ (unless (or (string-equal (name plt) "HP File only")
+ (string-equal (name plt) "PS File only"))
+ (dotimes (i (numcopies pbox))
+ (run-subprocess
+ (format nil "~a~a ~a"
+ *spooler-command* (name plt) *plotter-file*))))))
+
+;;;----------------------------------------------------
+
+(defun draw-plot-preview (p-panel)
+
+ "draw-plot-preview p-panel
+
+puts a temporary rectangle in the on-screen view to show what will
+appear on the plot."
+
+ (let* ((vw (view-for p-panel))
+ (mag (mag p-panel))
+ (ppcm (scale vw))
+ (pixw (truncate (clx:drawable-width (sl:window (picture vw)))
+ 2))
+ (pixh (truncate (clx:drawable-height (sl:window (picture vw)))
+ 2))
+ (size-data (find (page-size p-panel) *plot-sizes* :key #'first))
+ (w (round (* (third size-data) ppcm) mag))
+ (h (round (* (fourth size-data) ppcm) mag))
+ (ulc-x (- pixw (round w 2)))
+ (ulc-y (- pixh (round h 2)))
+ (preview-box (list ulc-x ulc-y w h))
+ (rect-prim (find p-panel (foreground vw) :key #'object)))
+ (if rect-prim (setf (rectangles rect-prim) preview-box)
+ (push (make-rectangles-prim preview-box (sl:color-gc 'sl:white)
+ :object p-panel)
+ (foreground vw)))
+ (display-view vw)))
+
+;;;----------------------------------------------------
+
+(defmethod destroy :before ((pb plot-box))
+
+ (ev:remove-notify pb (new-scale (view-for pb)))
+ (setf (foreground (view-for pb))
+ (remove pb (foreground (view-for pb)) :key #'object))
+ (sl:destroy (pmenu pb))
+ (sl:destroy (mag-tln pb))
+ (sl:destroy (copies-tln pb))
+ (sl:destroy (black-btn pb))
+ (sl:destroy (size-menu pb))
+ (sl:destroy (accept-btn pb))
+ (sl:destroy (cancel-btn pb))
+ (sl:destroy (pframe pb)))
+
+;;;----------------------------------------------------
+
+(defun make-plot-panel (v vp pln pat)
+
+ "make-plot-panel v vp pln pat
+
+Returns a plot panel, with controls for the user to specify/select
+plotter, paper size and orientation, etc. The plot is generated from
+the supplied view v, plan pln and patient pat. The view panel is needed
+to synchronize the deletion of the plot panel if the user removes the
+view panel."
+
+ (make-instance 'plot-box :view-for v :view-panel vp
+ :plan-of pln :patient pat
+ :black-off (if (typep v 'beams-eye-view) nil t)))
+
+;;;----------------------------------------------------
+
+(defmethod initialize-instance :after ((pbox plot-box) &rest initargs)
+
+ (declare (ignore initargs))
+ (let* ((plotter-names (mapcar #'first *plotters*))
+ (paper-sizes (mapcar #'second *plot-sizes*))
+ (pmenu (sl:make-radio-menu plotter-names :mapped nil))
+ (size-menu (sl:make-radio-menu paper-sizes :mapped nil))
+ (delta-y (+ 10 (max (sl:height pmenu)
+ (sl:height size-menu))
+ 10))
+ (pframe (sl:make-frame (+ (sl:width pmenu)
+ (sl:width size-menu)
+ 30)
+ (+ delta-y 30 10 30 10 30 10)
+ :title "Plot Parameters"))
+ (win (sl:window pframe))
+ (mag-tln (sl:make-textline (- (sl:width pframe) 20) 30
+ :parent win
+ :label "Magnification: "
+ :info "1.0"
+ :numeric t
+ :lower-limit 0.1
+ :upper-limit 10.0
+ :ulc-x 10 :ulc-y delta-y))
+ (copies-tln (sl:make-textline 70 30
+ :label "Copies: "
+ :parent win
+ :info "1"
+ :numeric t
+ :lower-limit 1
+ :upper-limit 9
+ :ulc-x 10 :ulc-y (+ delta-y 40)))
+ (black-btn (sl:make-button 70 30
+ :label "Background"
+ :border-style :flat
+ :fg-color 'sl:white
+ :bg-color 'sl:black
+ :font (symbol-value *small-font*)
+ :parent win
+ :ulc-x (- (sl:width pframe) 80)
+ :ulc-y (+ delta-y 40)))
+ (accept-btn (sl:make-exit-button 70 30
+ :label "Accept"
+ :parent win
+ :ulc-x 10
+ :ulc-y (+ delta-y 80)
+ :bg-color 'sl:green))
+ (cancel-btn (sl:make-exit-button 70 30
+ :label "Cancel"
+ :parent win
+ :ulc-x (- (sl:width pframe) 80)
+ :ulc-y (+ delta-y 80))))
+ (clx:reparent-window (sl:window pmenu) win 10 10)
+ (clx:map-window (sl:window pmenu))
+ (clx:map-subwindows (sl:window pmenu))
+ (clx:reparent-window (sl:window size-menu)
+ win (+ (sl:width pmenu) 20) 10)
+ (clx:map-window (sl:window size-menu))
+ (clx:map-subwindows (sl:window size-menu))
+ (setf (sl:on black-btn) (black-off pbox))
+ (setf (pframe pbox) pframe
+ (pmenu pbox) pmenu
+ (mag-tln pbox) mag-tln
+ (copies-tln pbox) copies-tln
+ (black-btn pbox) black-btn
+ (size-menu pbox) size-menu
+ (accept-btn pbox) accept-btn
+ (cancel-btn pbox) cancel-btn)
+ (ev:add-notify pbox (sl:selected pmenu)
+ #'(lambda (pbx m item)
+ (declare (ignore m))
+ (setf (plotter pbx)
+ (first (nth item *plotters*)))))
+ (ev:add-notify pbox (sl:selected size-menu)
+ #'(lambda (pbx m item)
+ (declare (ignore m))
+ (setf (page-size pbx)
+ (first (nth item *plot-sizes*)))
+ ;; redraw plot area rectangle in on-screen view
+ (draw-plot-preview pbx)))
+ (sl:select-button 0 pmenu) ;; sets default selection
+ (sl:select-button 0 size-menu) ;; ditto, and draws initial rectangle
+ (ev:add-notify pbox (sl:new-info mag-tln)
+ #'(lambda (pbx tln info)
+ (declare (ignore tln))
+ (setf (mag pbx)
+ (coerce (read-from-string info) 'single-float))
+ ;; redraw plot area rectangle in on-screen view
+ (draw-plot-preview pbx)))
+ (ev:add-notify pbox (new-scale (view-for pbox))
+ #'(lambda (pbx vw scl)
+ (declare (ignore vw scl))
+ (draw-plot-preview pbx)))
+ (ev:add-notify pbox (sl:new-info copies-tln)
+ #'(lambda (pbx tln info)
+ (declare (ignore tln))
+ (setf (numcopies pbx)
+ (coerce (read-from-string info) 'integer))))
+ (ev:add-notify pbox (sl:button-on black-btn)
+ #'(lambda (pbx bt)
+ (declare (ignore bt))
+ (setf (black-off pbx) t)))
+ (ev:add-notify pbox (sl:button-off black-btn)
+ #'(lambda (pbx bt)
+ (declare (ignore bt))
+ (setf (black-off pbx) nil)))
+ (ev:add-notify pbox (sl:button-on accept-btn)
+ #'(lambda (pbx bt)
+ (declare (ignore bt))
+ (do-plot pbx)
+ (setf (foreground (view-for pbx))
+ (remove pbx (foreground (view-for pbx))
+ :key #'object))
+ (display-view (view-for pbx))
+ (destroy pbx)))
+ (ev:add-notify pbox (sl:button-on cancel-btn)
+ #'(lambda (pbx bt)
+ (declare (ignore bt))
+ (setf (foreground (view-for pbx))
+ (remove pbx (foreground (view-for pbx))
+ :key #'object))
+ (display-view (view-for pbx))
+ (destroy pbx)))))
+
+;;;----------------------------------------------------
+
+(defmethod pen-color (color (plt plot))
+
+ "Given color (a gcontext representing a SLIK color), returns the pen
+index corresponding to that color as determined by the plot's
+colormap. Returns pen index #8 if no such color is in the colormap."
+
+ (or (position color (colormap plt)) 8))
+
+;;;----------------------------------------------------
+;;; Definitions for subclasses - first, generic HPGL plotter
+;;;----------------------------------------------------
+
+(defclass hpgl-plot (plot)
+
+ ()
+
+ (:documentation "A plot object corresponding to the generic HPGL
+plotter.")
+
+ )
+
+;;;----------------------------------------------------
+
+(defmethod initialize-instance :after ((plt hpgl-plot)
+ &rest initargs)
+
+ "Initialization operations for any HPGL plot. Generates the Prism
+logo."
+
+ (declare (ignore initargs))
+ (let* ((size-data (find (page-size plt) *plot-sizes* :key #'first))
+ (page-width (third size-data))
+ (text-y (round (* (scale (view plt)) *plotter-row-height*
+ (/ (magnification plt)))))
+ (y-inc text-y)
+ (text-x (round (* (scale (view plt))
+ (- page-width 5.0)
+ (/ (magnification plt))))))
+ (push-plot-text "Prism RTP System" text-x text-y y-inc plt)
+ (push-plot-text *prism-version-string*
+ text-x text-y y-inc plt)))
+
+;;;----------------------------------------------------
+;;; HP7550 pen plotter has own initialization and colors
+;;;----------------------------------------------------
+
+(defclass hp7550a-plot (hpgl-plot)
+
+ ()
+
+ (:default-initargs :text-color 'sl:blue)
+
+ (:documentation "A plot object corresponding to the HP7550A pen
+plotter.")
+
+ )
+
+;;;----------------------------------------------------
+
+(defmethod initialize-instance :after ((plt hp7550a-plot)
+ &rest initargs)
+
+ "Initialization operations for HP7550A plot."
+
+ ;; The number of HP plotter units per centimeter (pupcm below) is
+ ;; found on p 3-2 of the HP 7550A Interfacing & Programming Manual
+
+ (declare (ignore initargs))
+ (let* ((str (output-stream plt))
+ (pupcm 400)
+ (P1x 0)
+ (P1y 0)
+ (P2x 0)
+ (P2y 0)
+ (rot 0)
+ (size-data (find (page-size plt) *plot-sizes* :key #'first))
+ (page-width (third size-data))
+ (page-height (fourth size-data)))
+ ;; initialize plotter
+ (format str "IN;~%")
+ (case (page-size plt)
+ ((small a4) (setq P1x (round (* pupcm page-width))
+ P2y (round (* pupcm page-height))
+ rot 90))
+ ((wide-small a4-wide) (setq P1x (round (* pupcm page-width))
+ P2y (round (* pupcm page-height))))
+ ((ledger a3-wide) (setq P1y (round (* pupcm page-height))
+ P2x (round (* pupcm page-width))))
+ ((large a3) (setq P1y (round (* pupcm page-height))
+ P2x (round (* pupcm page-width))
+ rot 90)))
+ ;; rotate axes if needed
+ (format str "RO~a;~%" rot)
+ ;; reset P1 & P2 to bring origin into ulc of page and create a
+ ;; region on the page determined by page width & height.
+ (format str "IP~a,~a,~a,~a;~%" P1x P1y P2x P2y)
+ ;; set soft clip limits to this region
+ (format str "IW~a,~a,~a,~a;~%" P1x P1y P2x P2y)
+ ;; set plotter scale to region - maps screen space coords to region
+ (format str "SC~a,~a,~a,~a;~%" 0 (width plt) 0 (height plt))))
+
+;;;----------------------------------------------------
+
+(defmethod finish-plot :after ((p hp7550a-plot))
+
+ "Reset the current pen color of p and write a return-pen command
+to stream."
+
+ (setf (current-pen-color p) 0)
+ (format (output-stream p) "SP0;~%"))
+
+;;;----------------------------------------------------
+;;; HP Design Jet 455C pen plotter has its own initialization and colors
+;;;----------------------------------------------------
+
+(defclass hp455c-plot (hpgl-plot)
+
+ ()
+
+ (:default-initargs :text-color 'sl:black
+ ;; note that pen 0 is not used, so it is just a placeholder here.
+ :colormap (mapcar #'sl:color-gc
+ '(nil sl:black sl:red sl:green
+ sl:yellow sl:blue sl:magenta sl:cyan)))
+
+ (:documentation "A plot object corresponding to the HP Design Jet
+455C pen plotter.")
+
+ )
+
+;;;----------------------------------------------------
+
+(defmethod initialize-instance :after ((plt hp455c-plot)
+ &rest initargs)
+
+ "Initialization operations for HP Design Jet 455C plot."
+
+ ;; The number of HP plotter units per centimeter (pupcm below) is
+ ;; found on p 3-2 of the HP 7550A Interfacing & Programming Manual.
+ ;; The offset numbers are from Tim Fox of Emory University.
+
+ (declare (ignore initargs))
+ (let* ((str (output-stream plt))
+ (pupcm 400)
+ (P1x 0)
+ (P1y 0)
+ (P2x 0)
+ (P2y 0)
+ (rot 0)
+ (size-data (find (page-size plt) *plot-sizes* :key #'first))
+ (page-width (third size-data))
+ (page-height (fourth size-data)))
+ ;; initialize plotter
+ (format str "IN;~%")
+ (case (page-size plt)
+ ((small a4) (setq P2x (round (* pupcm page-width))
+ P1y (round (* pupcm page-height))))
+ ((wide-small a4-wide) (setq P2x (round (* pupcm page-width))
+ P1y (round (* pupcm page-height))
+ rot 90))
+ ((ledger a3-wide wide-film) (setq P1y (- (round (* pupcm page-height))
+ 5200)
+ P2x (- (round (* pupcm page-width))
+ 7920)
+ P1x -7920
+ P2y -5200
+ rot 90))
+ ((large a3 film) (setq P1y (- (round (* pupcm page-height))
+ 5200)
+ P2x (- (round (* pupcm page-width))
+ 7920)
+ P1x -7920
+ P2y -5200)))
+ ;; rotate axes if needed
+ (format str "RO~a;~%" rot)
+ ;; reset P1 & P2 to bring origin into ulc of page and create a
+ ;; region on the page determined by page width & height.
+ (format str "IP~a,~a,~a,~a;~%" P1x P1y P2x P2y)
+ ;; set soft clip limits to this region
+ (format str "IW~a,~a,~a,~a;~%" P1x P1y P2x P2y)
+ ;; set plotter scale to region - maps screen space coords to region
+ (format str "SC~a,~a,~a,~a;~%" 0 (width plt) 0 (height plt))))
+
+;;;----------------------------------------------------
+
+(defmethod pen-color (color (plt hp455c-plot))
+
+ "works like general method, but substitutes black for yellow also."
+
+ (let ((n (or (position color (colormap plt)) 8)))
+ (if (= n 4) 1 n)))
+
+;;;----------------------------------------------------
+
+(defmethod finish-plot :after ((p hp455c-plot))
+
+ "Reset the current pen color of p and write a return-pen command
+to stream."
+
+ (setf (current-pen-color p) 0)
+ (format (output-stream p) "SP0;~%")
+ (format (output-stream p) "PG;~%")) ;; page eject
+
+;;;----------------------------------------------------
+;;; DRAW methods for graphic prims in any hpgl-plot
+;;;----------------------------------------------------
+
+(defmethod draw ((l lines-prim) (p hpgl-plot))
+
+ "Draws lines primitive l into HP plot p."
+
+ (let* ((str (output-stream p))
+ (temp-col (sl:find-solid-color (color l))) ; nil if already solid
+ (col (pen-color (or temp-col (color l)) p)))
+ (unless (eq (color l) (sl:color-gc 'sl:invisible))
+ (unless (= col (current-pen-color p))
+ (setf (current-pen-color p) col)
+ (format str "SP~a;~%" col))
+ (when temp-col (format str "LT2,2;~%")) ; non-nil if dashed color
+ (dolist (pts (points l))
+ (format str "PA~a,~a; PD~%" (first pts) (second pts))
+ (do* ((pt (rest (rest pts)) (rest (rest pt)))
+ (x (first pt) (first pt))
+ (y (second pt) (second pt)))
+ ((null pt))
+ (format str "~a,~a,~%" x y))
+ (format str "; PU;~%"))
+ (when temp-col (format str "LT;~%"))))) ; non-nil if dashed color
+
+;;;----------------------------------------------------
+
+(defmethod draw ((s segments-prim) (p hpgl-plot))
+
+ "Draws segments primitive s into HPGL plot p."
+
+ (let* ((str (output-stream p))
+ (temp-col (sl:find-solid-color (color s))) ; nil if already solid
+ (col (pen-color (or temp-col (color s)) p))
+ (format-string (if temp-col ; non-nil if dashed, nil if solid
+ "LT2,2; PA~a,~a; PD~a,~a; PU; LT;~%"
+ "PA~a,~a; PD~a,~a; PU;~%")))
+ (unless (eq (color s) (sl:color-gc 'sl:invisible))
+ (unless (= col (current-pen-color p))
+ (setf (current-pen-color p) col)
+ (format str "SP~a;~%" col))
+ (do ((tup (points s) (nthcdr 4 tup)))
+ ((null tup))
+ (format str format-string
+ (first tup) (second tup) (third tup) (fourth tup))))))
+
+;;;----------------------------------------------------
+
+(defmethod draw ((r rectangles-prim) (p hpgl-plot))
+
+ "Draws rectangles primitive r into HPGL plot p."
+
+ (let ((str (output-stream p))
+ (col (pen-color (color r) p)))
+ (unless (eq (color r) (sl:color-gc 'sl:invisible))
+ (unless (= col (current-pen-color p))
+ (setf (current-pen-color p) col)
+ (format str "SP~a;~%" col))
+ (do ((tup (rectangles r) (nthcdr 4 tup)))
+ ((null tup))
+ (let* ((x1 (first tup))
+ (y1 (second tup))
+ (x2 (+ x1 (third tup)))
+ (y2 (+ y1 (fourth tup))))
+ (format str "PA~a,~a; PD~a,~a,~a,~a,~a,~a,~a,~a; PU;~%"
+ x1 y1 x2 y1 x2 y2 x1 y2 x1 y1))))))
+
+;;;----------------------------------------------------
+
+(defparameter *plotter-char-width* 0.187
+ "The width, in cm, of a plotted character. For example, see the HP
+7550A Interfacing and Programming Manual, page 7-14.")
+
+(defparameter *plotter-char-height* 0.269
+ "The height, in cm, of a plotted character.")
+
+;;;----------------------------------------------------
+
+(defmethod draw ((c characters-prim) (p hpgl-plot))
+
+ "Draws characters primitive c into HPGL plot p."
+
+ (let ((str (output-stream p))
+ (col (pen-color (color c) p)))
+ (unless (eq (color c) (sl:color-gc 'sl:invisible))
+ (unless (= col (current-pen-color p))
+ (setf (current-pen-color p) col)
+ (format str "SP~a;~%" col))
+ (format str "SI~a,~a;~%" *plotter-char-width* *plotter-char-height*)
+ (format str "PA~a,~a;~%" (x c) (y c))
+ (format str "LB~a~a;~%" (characters c) #\^C))))
+
+;;;----------------------------------------------------
+;;; Postscript plots go to PostScript color printers
+;;;----------------------------------------------------
+
+(defclass ps-plot (plot)
+
+ ((ps-colormap :accessor ps-colormap
+ :initarg :ps-colormap
+ :documentation "A list of PostScript RGB values
+corresponding to SLIK colors in the general plot colormap")
+
+ (black-off :accessor black-off
+ :initarg :black-off
+ :documentation "A flag to specify whether to leave the
+image background black or change it to white.")
+
+ )
+
+ ;; The order here is the same as in the colormap of the general
+ ;; plot: black red blue magenta green white yellow cyan gray
+ ;; except that screen white and yellow map to black on output.
+ ;; Actually this will all work unchanged on a monochrome PostScript
+ ;; printer - the printer remaps stuff in a reasonable way.
+
+ (:default-initargs :text-color 'sl:black :black-off t
+ :ps-colormap '((0 0 0) (1 0 0) (0 0 1) (0.7 0 1)
+ (0 1 0) (0 0 0) (0 0 0) (0 1 1)
+ (0.5 0.5 0.5)))
+
+ (:documentation "A plot object corresponding to a PostScript
+printer.")
+
+ )
+
+;;;----------------------------------------------------
+
+(defmethod initialize-instance :after ((plt ps-plot)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (let* ((strm (output-stream plt))
+ (inch-scale (/ (* (scale (view plt)) 2.54)
+ (magnification plt)))
+ (size-data (find (page-size plt) *plot-sizes* :key #'first))
+ (page-width (/ (third size-data) 2.54))
+ (page-height (/ (fourth size-data) 2.54)))
+ (ps:initialize strm 0.5 0.5
+ (/ (width plt) inch-scale)
+ (/ (height plt) inch-scale)
+ (+ page-width 1.0)
+ (+ page-height 1.0))
+ (ps:translate-origin strm 0.5 (+ page-height 0.5))
+ (ps:prism-logo strm (- page-width 3.0) -0.1 *prism-version-string*)
+ (ps:set-graphics strm :width 1)))
+
+;;;----------------------------------------------------
+
+(defmethod finish-plot :after ((p ps-plot))
+
+ "Prints the page."
+
+ (ps:finish-page (output-stream p)))
+
+;;;----------------------------------------------------
+
+(defmethod draw ((pr lines-prim) (plt ps-plot))
+
+ "Draws lines primitive pr into Postscript plot plt."
+
+ (let* ((str (output-stream plt))
+ (temp-col (sl:find-solid-color (color pr))) ;; nil if already solid
+ (col (pen-color (or temp-col (color pr)) plt))
+ (inch-scale (/ (* (scale (view plt)) 2.54)
+ (magnification plt))))
+ (unless (eq (color pr) (sl:color-gc 'sl:invisible))
+ (setf (current-pen-color plt) col)
+ (ps:set-graphics str
+ :color (nth col (ps-colormap plt))
+ :pattern (if temp-col "[10 10] 0" "[] 0"))
+ ;; experimental - draw mesh for tumors and targets
+ (let ((draw-mesh (typep (object pr) '(or tumor target))))
+ (declare (ignore draw-mesh)) ;; for now
+ (dolist (pts (points pr))
+ (let ((inch-con (cm-contour pts inch-scale 0 0)))
+ ;; (if draw-mesh (ps:draw-poly-mesh str inch-con 0.25))
+ (ps:draw-lines str inch-con)))))))
+
+;;;----------------------------------------------------
+
+(defmethod draw ((pr segments-prim) (plt ps-plot))
+
+ "Draws segments primitive pr into Postscript plot plt."
+
+ (let* ((str (output-stream plt))
+ (temp-col (sl:find-solid-color (color pr))) ;; nil if already solid
+ (col (pen-color (or temp-col (color pr)) plt))
+ (inch-scale (/ (* (scale (view plt)) 2.54)
+ (magnification plt))))
+ (unless (eq (color pr) (sl:color-gc 'sl:invisible))
+ (setf (current-pen-color plt) col)
+ (ps:set-graphics str
+ :color (nth col (ps-colormap plt))
+ :pattern (if temp-col "[10 10] 0" "[] 0"))
+ (do ((coords (points pr) (nthcdr 4 coords)))
+ ((null coords))
+ (ps:draw-line str
+ (cm-x (first coords) 0 inch-scale)
+ (cm-y (second coords) 0 inch-scale)
+ (cm-x (third coords) 0 inch-scale)
+ (cm-y (fourth coords) 0 inch-scale))))))
+
+;;;----------------------------------------------------
+
+(defmethod draw ((pr rectangles-prim) (plt ps-plot))
+
+ "Draws rectangles primitive pr into Postscript plot plt."
+
+ (let ((str (output-stream plt))
+ (col (pen-color (color pr) plt))
+ (inch-scale (/ (* (scale (view plt)) 2.54)
+ (magnification plt))))
+ (unless (eq (color pr) (sl:color-gc 'sl:invisible))
+ (setf (current-pen-color plt) col)
+ (ps:set-graphics str :color (nth col (ps-colormap plt)))
+ (do ((rects (rectangles pr) (nthcdr 4 rects)))
+ ((null rects))
+ (ps:draw-rectangle str
+ (cm-x (first rects) 0 inch-scale)
+ (cm-y (second rects) 0 inch-scale)
+ (cm-x (third rects) 0 inch-scale)
+ (cm-y (fourth rects) 0 inch-scale))))))
+
+;;;----------------------------------------------------
+
+(defmethod draw ((pr characters-prim) (plt ps-plot))
+
+ "Draws characters primitive pr into Postscript plot plt."
+
+ (let ((str (output-stream plt))
+ (col (pen-color (color pr) plt))
+ (inch-scale (/ (* (scale (view plt)) 2.54)
+ (magnification plt))))
+ (unless (eq (color pr) (sl:color-gc 'sl:invisible))
+ (setf (current-pen-color plt) col)
+ (ps:set-graphics str :color (nth col (ps-colormap plt)))
+ (ps:draw-text str
+ (cm-x (x pr) 0 inch-scale)
+ (cm-y (y pr) 0 inch-scale)
+ (characters pr)))))
+
+;;;----------------------------------------------------
+
+(defmethod draw ((im image-2d) (plt ps-plot))
+
+ "Draws image-2d im into Postscript plot plt."
+
+ (let* ((vw (view plt))
+ (image-8 (sl:map-raw-image (pixels im) (window vw) (level vw) 4095))
+ (cmppix (/ 1.0 (scale vw)))
+ (mag (* 0.3937 (magnification plt)))
+ (im-orig-x (svref (origin im)
+ (typecase vw
+ ((or transverse-view coronal-view
+ beams-eye-view) 0)
+ (sagittal-view 2))))
+ (im-orig-y (svref (origin im)
+ (typecase vw
+ ((or transverse-view sagittal-view
+ beams-eye-view) 1)
+ (coronal-view 2))))
+ (x (* mag (+ (* cmppix (x-origin vw)) im-orig-x)))
+ (y (* mag (- (if (typep vw 'coronal-view) (- im-orig-y)
+ im-orig-y)
+ (* cmppix (y-origin vw))
+ (second (size im)))))
+ (strm (output-stream plt))
+ (inch-scale (/ (scale vw) mag)) ;; mag already has cm to in.
+ (width (/ (width plt) inch-scale))
+ (height (/ (height plt) inch-scale))
+ (lowerband (/ (lowerband plt) inch-scale))
+ (upperband (/ (upperband plt) inch-scale)))
+ (declare (type (simple-array (unsigned-byte 8) 2) image-8))
+ (when (black-off plt)
+ ;; take out the black background by doing left and right raster
+ ;; scans, converting black to white until bumping into non-black data
+ (let ((xdim (array-dimension image-8 0))
+ (ydim (array-dimension image-8 1)))
+ ;; left scans
+ (dotimes (i ydim)
+ (dotimes (j xdim)
+ (if (= (aref image-8 i j) *image-black*)
+ (setf (aref image-8 i j) 127)
+ (return))))
+ ;; right scans
+ (dotimes (i ydim)
+ (dotimes (j xdim)
+ (if (= (aref image-8 i (- xdim j 1)) *image-black*)
+ (setf (aref image-8 i (- xdim j 1)) 127)
+ (return))))))
+ (format strm "gsave~%")
+ (ps:set-clip strm 0.0 (- lowerband height)
+ width (- height lowerband upperband))
+ (ps:draw-image strm x y
+ (* mag (first (size im)))
+ (* mag (second (size im)))
+ (array-dimension image-8 0)
+ (array-dimension image-8 1)
+ image-8)
+ (format strm "grestore~%")))
+
+;;;----------------------------------------------------
+;;; End.
diff --git a/prism/src/point-dose-panels.cl b/prism/src/point-dose-panels.cl
new file mode 100644
index 0000000..541f801
--- /dev/null
+++ b/prism/src/point-dose-panels.cl
@@ -0,0 +1,558 @@
+;;;
+;;; point-dose-panels
+;;;
+;;; The Prism point-dose panel class definition and associated functions.
+;;;
+;;; 21-Apr-1994 J. Unger created.
+;;; 22-Apr-1994 J. Unger lots more work.
+;;; 05-May-1994 J. Unger change valid to valid-points, add compute-dose btn.
+;;; 01-Jun-1994 J. Unger add-notify changes to beam names, elim extra code,
+;;; other misc modifications.
+;;; 05-Jun-1994 J. Unger fix bugs - typing into empty textlines and such.
+;;; 17-Jun-1994 J. Unger add pt ID's to name textline, make name textline
+;;; bigger, sort point lines by ID, two rows of beam tlns.
+;;; 13-Jul-1994 J. Unger fix bug - mu's wouldn't update when chg frac btn.
+;;; 26-Jul-1994 J. Unger add :numeric & limits to numerical textline defs.
+;;; 29-Aug-1994 J. Unger fix bug - crash when press down arrow w/ empty pnl
+;;; 30-Aug-1994 J. Unger remove code to sort points - list should always be
+;;; in correct order now.
+;;; 11-Sep-1994 J. Unger increase volatile border width interior textlines.
+;;; 18-Sep-1994 J. Unger add omitted remove-notify for beam names. Also
+;;; fix bug in beam name drawing that caused names not to get
+;;; updated properly when a beam was deleted.
+;;; 12-Jan-1995 I. Kalet destroy comp-dose button also. Get and cache
+;;; plan and patient as passed parameters.
+;;; 8-Jun-1997 I. Kalet use new SLIK widget, icon-button, with
+;;; make-arrow-button fn.
+;;; 27-Feb-1998 I. Kalet strip down, use new spreadsheet widget in SLIK.
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 21-Oct-1999 I. Kalet protect against entering a zero total dose
+;;; for a point.
+;;; 11-May-2000 I. Kalet parametrize lower and upper dose input limits
+;;; 16-Dec-2000 I. Kalet add plan name to title of panel.
+;;; 5-May-2002 I. Kalet handle possibility of button off event (info=0)
+;;; 2-Nov-2003 I. Kalet remove use of reader macro #. in *pdp-cells*
+;;; to allow compile without first loading
+;;; 1-Dec-2003 I. Kalet use backquote in array initialization instead
+;;; of quote, to allow eval of parameters.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defvar *pdp-row-heights*
+ (append '(30 50) (make-list 13 :initial-element 30))
+ "The second row is a little bigger.")
+
+;;;---------------------------------------------
+
+(defvar *pdp-col-widths* '(160 10 90 40 90 90 90 90 40))
+
+;;;---------------------------------------------
+
+(defparameter *pdp-dose-min* 0.0)
+(defparameter *pdp-dose-max* 10000.0)
+
+;;;---------------------------------------------
+
+(defvar *pdp-cells*
+ (make-array '(15 9)
+ :initial-contents
+ `(((:button "Delete Panel") nil
+ (:button "Compute" nil nil :button-type :momentary)
+ nil nil (:label "Beams") nil nil nil)
+ (nil nil nil
+ (:left-arrow nil nil nil :fg-color sl:red)
+ (:label "") (:label "")
+ (:label "") (:label "")
+ (:right-arrow nil nil nil :fg-color sl:red))
+ ;; the monitor units row
+ ((:label "Points") nil
+ (:button "ALL FRAC" nil nil :button-type :momentary)
+ (:label "MU")
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:up-arrow nil nil nil :fg-color sl:red)
+ nil (:label "Dose") nil nil nil nil nil nil)
+ ;; ten rows of point doses
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:label "") nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ (:number nil ,*pdp-dose-min* ,*pdp-dose-max*)
+ nil)
+ ((:down-arrow nil nil nil :fg-color sl:red)
+ nil nil nil nil nil nil nil nil))))
+
+;;;---------------------------------------------
+
+(defclass point-dose-panel (generic-panel)
+
+ ((fr :accessor fr
+ :documentation "The SLIK spreadsheet panel that contains
+all the control buttons, name cells, data cells and arrow buttons.")
+
+ (plan :type plan
+ :accessor plan
+ :initarg :plan
+ :documentation "The plan for this point-dose panel.")
+
+ (pat :accessor pat
+ :initarg :pat
+ :documentation "The current patient.")
+
+ (mode-factor :type single-float
+ :accessor mode-factor
+ :initform 1.0
+ :documentation "A cached multiplicative factor for
+computation of dose and mu per fraction -- equals 1.0 when display
+mode is ALL FRAC, or the inverse of the number of treatments when
+display mode is ONE FRAC.")
+
+ (beam-pos :type fixnum
+ :accessor beam-pos
+ :initform 0
+ :documentation "The position in the plan's collection of
+beams of the beam currently in the first beam column in the point dose
+panel spreadsheet.")
+
+ (point-pos :type fixnum
+ :accessor point-pos
+ :initform 0
+ :documentation "The position in the patient point list
+of the point in the first row of the points part of the point dose
+panel spreadsheet.")
+
+ )
+
+ (:documentation "The point-dose panel contains a table which
+displays the dose at each defined point of interest under each beam,
+and provides a mechanism for the user to specify dose to particular
+points and monitor units to beams.")
+
+ )
+
+;;;---------------------------------------------
+
+(defun make-point-dose-panel (&rest initargs)
+
+ "make-point-dose-panel &rest initargs
+
+Creates and returns a point-dose panel with the specified initargs."
+
+ (apply #'make-instance 'point-dose-panel
+ ;; :font sl:helvetica-bold-18
+ initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((pdp point-dose-panel)
+ &rest initargs)
+
+ "Initializes the user interface for the point-dose panel."
+
+ (let* ((pln (plan pdp))
+ (frm (apply #'sl:make-spreadsheet
+ *pdp-row-heights* *pdp-col-widths*
+ *pdp-cells*
+ :title (format t "Point Dose Panel for ~A"
+ (name pln))
+ initargs)))
+ (setf (fr pdp) frm)
+ (display-beam-names pdp)
+ (display-mu pdp)
+ (display-point-names pdp)
+ (if (valid-points (sum-dose pln)) (display-all-doses pdp))
+ ;; register with panel user input event
+ (ev:add-notify pdp (sl:user-input frm)
+ #'(lambda (pan sheet i j info)
+ (let* ((bmlist (coll:elements
+ (beams (plan pan))))
+ (lastcol (min (+ 4 (- (length bmlist)
+ (beam-pos pan)))
+ 8))
+ (pts (coll:elements (points (pat pan))))
+ (lastrow (min (+ 4 (- (length pts)
+ (point-pos pan)))
+ 14)))
+ (cond ((and (= i 0) (= j 0))
+ (when (= info 1) (destroy pan)))
+ ((and (= i 0) (= j 2))
+ (when (= info 1)
+ (compute-dose-points (plan pan) (pat pan))))
+ ((and (= i 2) (= j 2))
+ (when (= info 1) (switch-mu-frac pan i j)))
+ ((and (= i 2) (> j 3) (< j lastcol))
+ ;; user entered new MU
+ (setf (monitor-units
+ (nth (+ j -4 (beam-pos pan))
+ bmlist))
+ (coerce (/ info (mode-factor pan))
+ 'single-float)))
+ ((and (> i 3) (< i lastrow) (= j 2))
+ ;; user entered new total dose for a point
+ (new-dose-total pan i info))
+ ((and (> i 3) (< i lastrow)
+ (> j 3) (< j lastcol))
+ ;; user entered new point dose from beam
+ (new-beam-dose pan i j info))
+ ;; arrow buttons
+ ((and (= i 1) (= j 3)) ;; left arrow
+ (beam-scroll pan (case info
+ (1 -1)
+ (2 -4))))
+ ((and (= i 1) (= j 8)) ;; right arrow
+ (beam-scroll pan (case info
+ (1 1)
+ (2 4))))
+ ((and (= i 3) (= j 0)) ;; up arrow
+ (point-scroll pan (case info
+ (1 -1)
+ (2 -10))))
+ ((and (= i 14) (= j 0)) ;; down arrow
+ (point-scroll pan (case info
+ (1 1)
+ (2 10))))
+ ;; no other cases
+ (t (sl:acknowledge "That cell is empty")
+ (sl:erase-contents sheet i j))))))
+ ;; register changes to beam names and beam MU's - note that MU
+ ;; change does not affect valid flag so must handle it here.
+ (dolist (b (coll:elements (beams pln)))
+ (ev:add-notify pdp (new-name b)
+ #'(lambda (pan bm newname)
+ (let ((pos (- (position bm (coll:elements
+ (beams (plan pan))))
+ (beam-pos pan))))
+ (when (and (>= pos 0) (< pos 4))
+ (sl:set-contents (fr pan) 1 (+ pos 4)
+ newname)))))
+ (ev:add-notify pdp (new-mu b)
+ #'(lambda (pan bm newmu)
+ (let ((pos (+ 4 (- (position bm (coll:elements
+ (beams
+ (plan pan))))
+ (beam-pos pan)))))
+ (when (and (> pos 3) (< pos 8))
+ (sl:set-contents (fr pan) 2 pos
+ (format nil "~6,1F"
+ (* (mode-factor pan)
+ newmu)))
+ (when (valid-points (sum-dose (plan pan)))
+ (display-beam-doses bm pan pos)))
+ (when (valid-points (sum-dose (plan pan)))
+ (display-total-doses pan))))))
+ ;; register with status change to the plan's dose result
+ (ev:add-notify pdp (points-status-changed (sum-dose pln))
+ #'(lambda (pan a v)
+ (declare (ignore a v))
+ (if (valid-points (sum-dose (plan pan)))
+ (display-all-doses pan)
+ (erase-all-doses pan))))
+ ))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((pdp point-dose-panel))
+
+ "Releases X resources used by this panel and removes event notifies
+where needed."
+
+ (ev:remove-notify pdp (points-status-changed
+ (sum-dose (plan pdp))))
+ (dolist (b (coll:elements (beams (plan pdp))))
+ (ev:remove-notify pdp (new-name b))
+ (ev:remove-notify pdp (new-mu b)))
+ (sl:destroy (fr pdp)))
+
+;;;---------------------------------------------
+
+(defun display-beam-names (panel)
+
+ (let ((col 3)
+ (sheet (fr panel)))
+ (dolist (bm (nthcdr (beam-pos panel)
+ (coll:elements (beams (plan panel)))))
+ (if (< (incf col) 8) ;; don't go too far to the right!
+ (sl:set-contents sheet 1 col (name bm))))))
+
+;;;---------------------------------------------
+
+(defun display-point-names (panel)
+
+ (let ((row 3)
+ (sheet (fr panel)))
+ (dolist (pt (nthcdr (point-pos panel)
+ (coll:elements (points (pat panel)))))
+ (if (< (incf row) 14) ;; don't go past the bottom!
+ (sl:set-contents sheet row 0 ;; write number with name
+ (format nil "~2 at A. ~A"
+ (id pt) (name pt)))))))
+
+;;;---------------------------------------------
+
+(defun display-mu (panel)
+
+ (let ((col 3)
+ (sheet (fr panel))
+ (mode-fac (mode-factor panel)))
+ (dolist (bm (nthcdr (beam-pos panel)
+ (coll:elements (beams (plan panel)))))
+ (if (< (incf col) 8) ;; don't go off the end!
+ (sl:set-contents sheet 2 col
+ (format nil "~6,1F"
+ (* mode-fac (monitor-units bm))))))))
+
+;;;---------------------------------------------
+
+(defun display-beam-doses (bm pan col)
+
+ (let ((mu (monitor-units bm))
+ (sheet (fr pan))
+ (mode-fac (mode-factor pan))
+ (row 3))
+ (dolist (pt (nthcdr (point-pos pan) (points (result bm))))
+ (if (< (incf row) 14)
+ (sl:set-contents sheet row col
+ (format nil "~6,1F" (* mode-fac mu pt)))))))
+
+;;;---------------------------------------------
+
+(defun display-total-doses (panel)
+
+ "this function just has to compute the scaled total dose from the
+plan's dose result."
+
+ (let ((sheet (fr panel))
+ (mode-fac (mode-factor panel))
+ (row 3))
+ (dolist (pt (nthcdr (point-pos panel)
+ (points (sum-dose (plan panel)))))
+ (if (< (incf row) 14)
+ (sl:set-contents sheet row 2
+ (format nil "~6,1F" (* mode-fac pt)))))))
+
+;;;---------------------------------------------
+
+(defun display-all-doses (panel)
+
+ "this function does both the individual beams and the totals."
+
+ (let ((col 3))
+ (dolist (bm (nthcdr (beam-pos panel)
+ (coll:elements (beams (plan panel)))))
+ (if (< (incf col) 8) (display-beam-doses bm panel col))))
+ (display-total-doses panel))
+
+;;;---------------------------------------------
+
+(defun switch-mu-frac (panel i j)
+
+ (let ((sheet (fr panel))
+ (beams (coll:elements (beams (plan panel))))
+ (doses (valid-points (sum-dose (plan panel)))))
+ (if (string-equal (sl:contents sheet i j) "ONE FRAC")
+ (progn
+ (sl:set-contents sheet i j "ALL FRAC")
+ (setf (mode-factor panel) 1.0)
+ (display-mu panel)
+ (if doses (display-all-doses panel))) ;; and update the display!
+ ;; need to check first on this one, if it is possible
+ (if (apply #'= (mapcar #'n-treatments beams))
+ (progn
+ (sl:set-contents sheet i j "ONE FRAC")
+ (setf (mode-factor panel) (/ 1.0 (n-treatments
+ (first beams))))
+ (display-mu panel)
+ (if doses (display-all-doses panel))) ;; and update the display!
+ (progn
+ (sl:acknowledge '("Cannot change to single fraction"
+ "Not all beams have same number of fractions."))
+ (sl:set-button sheet i j nil))))))
+
+;;;---------------------------------------------
+
+(defun new-beam-dose (panel row col info)
+
+ "this function should compute and set the MU for one beam."
+
+ (let* ((bm (nth (+ col -4 (beam-pos panel))
+ (coll:elements (beams (plan panel)))))
+ (dose-per-mu (if (valid-points (result bm))
+ (nth (+ row -4 (point-pos panel))
+ (points (result bm))))))
+ (if dose-per-mu ;; result exists!
+ (if (zerop dose-per-mu)
+ (progn ;; it's zero, can't change dose!
+ (sl:acknowledge '("Zero dose per MU"
+ "You cannot set this"))
+ (sl:set-contents (fr panel) row col 0.0))
+ (setf (monitor-units bm)
+ (coerce (/ info (* (mode-factor panel) dose-per-mu))
+ 'single-float)))
+ (progn
+ (sl:acknowledge "No point dose result for this beam")
+ (sl:erase-contents (fr panel) row col)))))
+
+;;;---------------------------------------------
+
+(defun new-dose-total (panel row info)
+
+ "this function should compute and set all the MU for all the beams."
+
+ (if (zerop info)
+ (progn
+ (sl:acknowledge "You cannot set this dose to zero.")
+ (sl:erase-contents (fr panel) row 2))
+ (if (valid-points (sum-dose (plan panel)))
+ (let ((dose (nth (+ row -4 (point-pos panel))
+ (points (sum-dose (plan panel))))))
+ (if (zerop dose)
+ (progn
+ (sl:acknowledge '("Dose got set to zero."
+ "Please adjust MU first."))
+ (sl:erase-contents (fr panel) row 2))
+ (let ((ratio (/ info (* (mode-factor panel) dose))))
+ (dolist (bm (coll:elements (beams (plan panel))))
+ (setf (monitor-units bm)
+ (* ratio (monitor-units bm)))))))
+ (progn
+ (sl:acknowledge "No point dose results yet")
+ (sl:erase-contents (fr panel) row 2)))))
+
+;;;---------------------------------------------
+
+(defun erase-all-doses (panel)
+
+ (let ((sheet (fr panel)))
+ (dotimes (i 10)
+ (let ((row (+ i 4)))
+ (sl:erase-contents sheet row 2)
+ (dotimes (j 4)
+ (sl:erase-contents sheet row (+ j 4)))))))
+
+;;;---------------------------------------------
+
+(defun erase-names-mu (panel)
+
+ (let ((sheet (fr panel)))
+ (dotimes (i 4)
+ (sl:erase-contents sheet 1 (+ i 4)) ;; beam names
+ (sl:erase-contents sheet 2 (+ i 4))) ;; beam MU
+ (dotimes (i 10)
+ (sl:erase-contents sheet (+ i 4) 0)))) ;; point names
+
+;;;---------------------------------------------
+
+(defun pdp-refresh (panel)
+
+ (erase-names-mu panel)
+ (erase-all-doses panel)
+ (display-beam-names panel)
+ (display-point-names panel)
+ (display-mu panel)
+ (if (valid-points (sum-dose (plan panel)))
+ (display-all-doses panel)))
+
+;;;---------------------------------------------
+
+(defun beam-scroll (panel amt)
+
+ (when amt ;; could be nil - see case above
+ (let ((tmp (+ (beam-pos panel) amt))
+ (bmlist (coll:elements (beams (plan panel)))))
+ (when (and (>= tmp 0) (< tmp (length bmlist)))
+ (setf (beam-pos panel) tmp)
+ (pdp-refresh panel)))))
+
+;;;---------------------------------------------
+
+(defun point-scroll (panel amt)
+
+ (when amt ;; could be nil - see case above
+ (let ((tmp (+ (point-pos panel) amt))
+ (ptlist (coll:elements (points (pat panel)))))
+ (when (and (>= tmp 0) (< tmp (length ptlist)))
+ (setf (point-pos panel) tmp)
+ (pdp-refresh panel)))))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/prism/src/point-graphics.cl b/prism/src/point-graphics.cl
new file mode 100644
index 0000000..f402f4e
--- /dev/null
+++ b/prism/src/point-graphics.cl
@@ -0,0 +1,159 @@
+;;;
+;;; point-graphics
+;;;
+;;; Defines draw methods for drawing marks into views.
+;;;
+;;; 25-Apr-1994 J. Unger created.
+;;; 26-Apr-1994 J. Unger combine common parts of methods into separate
+;;; function
+;;; 4-Sep-1995 I. Kalet call pix-x, pix-y, declare some types
+;;; 19-Sep-1996 I. Kalet remove &rest from draw methods
+;;; 6-Dec-1996 I. Kalet don't generate prims if color is invisible
+;;; 03-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx .
+;;; 21-Apr-1999 I. Kalet change sl:invisible to 'sl:invisible
+;;; 25-Apr-1999 I. Kalet changes for support of multiple colormaps.
+;;; 5-Jan-2000 I. Kalet relax z match criterion for display.
+;;; 30-Jul-2002 I. Kalet add support for oblique views.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defparameter *point-prim-size* 4
+ "Half the length and width of the point primitive hatchmark, in pixels.")
+
+;;;--------------------------------------
+
+(defun pixel-point (xpt ypt pix-per-cm xorig yorig)
+
+ "Converts the real space coordinate pair determined by floating
+point numbers xpt and ypt into a hatch mark in screen space and
+a point at which to place a numerical id. The three values are
+returned via a (values...) form: hatch mark list, x coord of id,
+and y coord of id."
+
+ (let ((xt (pix-x xpt xorig pix-per-cm))
+ (yt (pix-y ypt yorig pix-per-cm)))
+ (declare (fixnum xt yt xorig yorig *point-prim-size*)
+ (single-float xpt ypt pix-per-cm))
+ (values
+ (list
+ (- xt *point-prim-size*) yt (+ xt *point-prim-size*) yt
+ xt (- yt *point-prim-size*) xt (+ yt *point-prim-size*))
+ (+ xt *point-prim-size*)
+ (+ yt (* 3 *point-prim-size*))
+)))
+
+;;;--------------------------------------
+
+(defun draw-point-in-view (pt v px py pz)
+
+ "draw-point-in-view pt v px py pz
+
+Draws point pt into view v. The pair (px py) is the location of the
+point on the plane of the view and pz is the position of the point
+along the same axis to which the view is perpendicular."
+
+ ; be careful not to just put tons of 'empty' graphic primitives on
+ ; the foreground list for the points - there may be a lot of points
+ ; and lots of empty primitives on the foreground is inefficient when
+ ; the foreground is drawn, so remove prims when we find them on the
+ ; list and there are no points to draw.
+
+ (let ((s-prim (find-if #'(lambda (prim)
+ (and (eq (object prim) pt)
+ (typep prim 'segments-prim)))
+ (foreground v)))
+ (c-prim (find-if #'(lambda (prim)
+ (and (eq (object prim) pt)
+ (typep prim 'characters-prim)))
+ (foreground v)))
+ (color (sl:color-gc (display-color pt)))
+ (same-plane (poly:nearly-equal pz (view-position v)
+ *display-epsilon*))
+ (hatchmarks nil)
+ (x-anchor nil)
+ (y-anchor nil))
+ (when (and s-prim (not same-plane))
+ (setf (foreground v) (remove s-prim (foreground v)))
+ (setf (foreground v) (remove c-prim (foreground v))))
+ (when same-plane
+ (unless s-prim
+ (setq s-prim (make-segments-prim nil color :object pt))
+ (push s-prim (foreground v))
+ (setq c-prim (make-characters-prim nil nil nil color :object pt))
+ (push c-prim (foreground v)))
+ (setf (color s-prim) color)
+ (setf (color c-prim) color)
+ (multiple-value-setq
+ (hatchmarks x-anchor y-anchor)
+ (pixel-point px py (scale v) (x-origin v) (y-origin v)))
+ (setf (points s-prim) hatchmarks)
+ (setf (x c-prim) x-anchor)
+ (setf (y c-prim) y-anchor)
+ (setf (characters c-prim) (write-to-string (id pt))))))
+
+;;;--------------------------------------
+
+(defmethod draw :around ((pt mark) (v view))
+
+ (if (eql (display-color pt) 'sl:invisible)
+ (setf (foreground v) (remove pt (foreground v) :key #'object))
+ (call-next-method)))
+
+;;;--------------------------------------
+
+(defmethod draw ((pt mark) (tv transverse-view))
+
+ "draw (pt mark) (tv transverse-view)
+
+Draws a mark in a transverse view if the point lies in the plane of the view."
+
+ (draw-point-in-view pt tv (x pt) (y pt) (z pt)))
+
+;;;--------------------------------------
+
+(defmethod draw ((pt mark) (cv coronal-view))
+
+ "draw (pt mark) (cv coronal-view)
+
+Draws a mark in a coronal view if the point lies in the plane of the view."
+
+ (draw-point-in-view pt cv (x pt) (- (z pt)) (y pt)))
+
+;;;--------------------------------------
+
+(defmethod draw ((pt mark) (sv sagittal-view))
+
+ "draw (pt mark) (sv sagittal-view)
+
+Draws a mark in a sagittal view if the point lies in the plane of the view."
+
+ (draw-point-in-view pt sv (z pt) (y pt) (x pt)))
+
+;;;--------------------------------------
+
+(defmethod draw ((pt mark) (ov oblique-view))
+
+ "draws the point in an oblique view if the point is in the plane of
+the view"
+
+ (let* ((x (x pt))
+ (y (y pt))
+ (z (z pt))
+ (azi-rad (* (azimuth ov) *pi-over-180*))
+ (alt-rad (* (altitude ov) *pi-over-180*))
+ (sin1 (sin azi-rad))
+ (cos1 (cos azi-rad))
+ (sin2 (sin alt-rad))
+ (cos2 (cos alt-rad))
+ (z-temp (+ (* x sin1) (* z cos1))))
+ (draw-point-in-view pt ov
+ (- (* x cos1) (* z sin1))
+ (- (* y cos2) (* z-temp sin2))
+ (+ (* y sin2) (* z-temp cos2)
+ (- (view-position ov))))))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/point-mediators.cl b/prism/src/point-mediators.cl
new file mode 100644
index 0000000..dff25ac
--- /dev/null
+++ b/prism/src/point-mediators.cl
@@ -0,0 +1,48 @@
+;;;
+;;; point-mediators
+;;;
+;;; Defines mediator for update of points in views
+;;;
+;;; 25-Apr-1994 J. Unger create.
+;;; 22-May-1994 J. Unger condense new-x, new-y, & new-z point events into
+;;; a single new-loc event.
+;;; 30-Aug-1994 J. Unger add registration for changed display-color
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass point-view-mediator (object-view-mediator)
+
+ ()
+
+ (:documentation "This mediator connects a point with a view.")
+)
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((pvm point-view-mediator)
+ &rest initargs)
+
+ (declare (ignore initargs))
+
+ (ev:add-notify pvm (new-loc (object pvm)) #'update-view)
+ (ev:add-notify pvm (new-id (object pvm)) #'update-view)
+ (ev:add-notify pvm (new-color (object pvm)) #'update-view))
+
+;;;--------------------------------------
+
+(defmethod destroy :after ((pvm point-view-mediator))
+
+ (ev:remove-notify pvm (new-loc (object pvm)))
+ (ev:remove-notify pvm (new-id (object pvm)))
+ (ev:remove-notify pvm (new-color (object pvm))))
+
+;;;--------------------------------------
+
+(defun make-point-view-mediator (point view)
+
+ (make-instance 'point-view-mediator :object point :view view))
+
+;;;--------------------------------------
diff --git a/prism/src/points.cl b/prism/src/points.cl
new file mode 100644
index 0000000..d5ebfd3
--- /dev/null
+++ b/prism/src/points.cl
@@ -0,0 +1,121 @@
+;;;
+;;; points
+;;;
+;;; defines points of interest in a patient case
+;;;
+;;; 3-Sep-1993 I. Kalet created from contours module
+;;; 25-Apr-1994 J. Unger enhance definition - add events & id attribute,
+;;; events, setf methods, etc.
+;;; 19-May-1994 J. Unger adj make-point to allow for additional initargs,
+;;; move assignment of id to 2d-point editor.
+;;; 22-May-1994 J. Unger condense new-x, new-y, & new-z events into one.
+;;; 25-May-1994 J. Unger take name out of not-saved list.
+;;; 30-Aug-1994 J. Unger add new-color announcement.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass mark (generic-prism-object)
+
+ ((x :type single-float
+ :accessor x
+ :initarg :x
+ :documentation "The mark's x coordinate.")
+
+ (y :type single-float
+ :accessor y
+ :initarg :y
+ :documentation "The mark's y coordinate.")
+
+ (z :type single-float
+ :accessor z
+ :initarg :z
+ :documentation "The mark's z coordinate.")
+
+ (new-loc :type ev:event
+ :accessor new-loc
+ :initform (ev:make-event)
+ :documentation "Announced when the mark's x, y, or z attribute
+changes.")
+
+ (id :type fixnum
+ :initarg :id
+ :reader id
+ :documentation "The id is a read-only (for now) attribute that is
+assigned when a point is created. The id for the first point created
+is 1, and increases by 1 for successively created points.")
+
+ (new-id :type ev:event
+ :accessor new-id
+ :initform (ev:make-event)
+ :documentation "Announced when the mark's id attribute changes.")
+
+ (display-color :initarg :display-color
+ :initform 'sl:yellow
+ :accessor display-color)
+
+ (new-color :type ev:event
+ :initform (ev:make-event)
+ :accessor new-color
+ :documentation "Announced by setf method when
+display-color is updated.")
+
+ )
+
+ (:documentation "A mark is a point within the patient that marks
+some anatomic landmark or a point where the dose needs to be known.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod not-saved ((pt mark))
+
+ (append (call-next-method)
+ '(new-loc new-id new-color)))
+
+;;;--------------------------------------
+
+(defmethod (setf x) :after (val (pt mark))
+
+ (declare (ignore val))
+ (ev:announce pt (new-loc pt) (list (x pt) (y pt) (z pt))))
+
+;;;--------------------------------------
+
+(defmethod (setf y) :after (val (pt mark))
+
+ (declare (ignore val))
+ (ev:announce pt (new-loc pt) (list (x pt) (y pt) (z pt))))
+
+;;;--------------------------------------
+
+(defmethod (setf z) :after (val (pt mark))
+
+ (declare (ignore val))
+ (ev:announce pt (new-loc pt) (list (x pt) (y pt) (z pt))))
+
+;;;--------------------------------------
+
+(defmethod (setf display-color) :after (clr (pt mark))
+
+ (ev:announce pt (new-color pt) clr))
+
+;;;--------------------------------------
+
+(defun make-point (point-name &rest initargs)
+
+ "MAKE-POINT point-name &rest initargs
+
+Returns a mark object with specified parameters."
+
+ (apply #'make-instance 'mark
+ :name (if (equal point-name "")
+ (format nil "~A" (gensym "POINT-"))
+ point-name)
+ initargs)
+ )
+
+;;;--------------------------------------
diff --git a/prism/src/prism-db.cl b/prism/src/prism-db.cl
new file mode 100644
index 0000000..a92cd75
--- /dev/null
+++ b/prism/src/prism-db.cl
@@ -0,0 +1,834 @@
+;;;
+;;; prism-db
+;;;
+;;; This code implements the Prism patient and image file system
+;;; (database) initial design. This could be replaced by database
+;;; access routines later.
+;;;
+;;; 25-Sep-1992 I. Kalet created
+;;; 1-Oct-1992 I. Kalet fix up filename conventions
+;;; 30-Dec-1992 I. Kalet fix error in get-case-data
+;;; 07-Jan-1993 I. Kalet change filesystem to database
+;;; 18-Jan-1993 I. Kalet add functions for storing case data and
+;;; updating patient and case lists.
+;;; 16-Feb-1993 I. Kalet add functions for selecting patients and cases
+;;; 2-Mar-1993 I. Kalet add protection from missing files or
+;;; directories, get image index item order right, and other fixes.
+;;; 5-Mar-1993 I. Kalet provide NEW CASE option in select-case and
+;;; new case for case-id 0 in get-case-data, add get-patient-entry
+;;; 4-Aug-1993 I. Kalet just use date-entered in put-case-data. In
+;;; get-case-data use name, hosp. id from patient index in every
+;;; case, old or new.
+;;; 6-Aug-1993 I. Kalet In add-patient, no "New patient", create
+;;; entry if not there, otherwise leave it as is.
+;;; 5-Nov-1993 J. Unger add some attribute init. to get-case-data.
+;;; implement put-plan-data.
+;;; 3-Jan-1994 I. Kalet take out forwarding of patient data to plans.
+;;; 14-Feb-1994 I. Kalet fix errors in let forms in add-patient, add-case
+;;; 5-May-1994 J. Unger move bulk of add-patient to modify-database-list,
+;;; provide add-patient, edit-patient, & delete-patient functions which
+;;; call it. Also made add-case call modify-database-list, added
+;;; delete-case and delete-case-file, delete-plan-from-case, and some
+;;; file manipulation functions.
+;;; 18-May-1994 I. Kalet change reference to patient comments to first
+;;; entry in patient comments list.
+;;; 06-Jun-1994 J. Unger add conditional tenuring call to get-image-set,
+;;; which will load images directly into oldspace in allegrocl.
+;;; 29-Jun-1994 J. Unger make delete-plan-from-case search list of
+;;; plans by plan timestamp, instead of plan name.
+;;; 11-Oct-1994 J. Unger fix bug in put-plan-data.
+;;; 07-Nov-1994 J. Unger ensure that timestamp of a plan written out
+;;; from put-plan-data does not update at the time the plan is written.
+;;; 27-Jul-1995 I. Kalet eliminate copy-plan in put-plan-data because
+;;; there are no back pointers anymore.
+;;; 12-Sep-1995 I. Kalet in get-case-data, coerce wedge rotation and
+;;; threshold values to single-float, to allow fast arithmetic. But
+;;; save and restore the original plan timestamp while doing this.
+;;; 22-May-1996 I. Kalet/D. Avitan implement put-image-set.
+;;; 9-Oct-1996 I. Kalet use excl:tenuring in any Allegro.
+;;; 2-Feb-1997 I. Kalet make default directory for all database
+;;; functions be the corresponding prism global, not the value of
+;;; *default-pathname-defaults*
+;;; 7-Mar-1997 I. Kalet add event registrations between beams and
+;;; their collimator and wedge objects, when reading in plan data, in
+;;; get-case-data function. This cannot be done in the
+;;; initialize-instance method for a beam.
+;;; 24-Apr-1997 I. Kalet provide a means for filtering the patient
+;;; list by patient name or number.
+;;; 06-Jun-1997 BobGian massaged "peek-char" EOF detection to use READ
+;;; function with EOF detection instead - same functionality, cleaner.
+;;; Also changed DELETE-IMAGE-FILES to use lisp's DIRECTORY rather than
+;;; RUN-SUBPROCESS to get list of image files to delete.
+;;; 26-Jun-1997 I. Kalet move case init code here from patient panel,
+;;; so it is all in one place (only the stuff that cannot be done in
+;;; the individual object init methods when data read from file).
+;;; 22-Aug-1997 I. Kalet add get-full-case-list analagous to
+;;; get-full-image-set-list. Also, get-irreg-case.
+;;; 12-Sep-1997 I. Kalet use get-index-list function in the
+;;; file-functions module, in higher level functions here, instead of
+;;; replicating file read and write code, since the index files are
+;;; all similar. Make database required, not optional, in all
+;;; functions that need it.
+;;; 9-Nov-1997 I. Kalet add optional parameter new to select-case,
+;;; defaults to t, which lists option of new case. Set to nil when
+;;; the new case option should not be included in the menu.
+;;; 28-Dec-1997 I. Kalet add select-patient-from-case-list, originally
+;;; repeated code in patdb-panels.
+;;; 28-Apr-1998 I. Kalet don't set patient case name and hospital ID
+;;; here, because need *patient-database* for patient index.
+;;; 5-Jun-1998 I. Kalet remove Allegro with-tenuring, as it tenures
+;;; garbage in addition to the images.
+;;; 15-Jun-1998 I. Kalet add image set and image index functions for
+;;; storing image sets, to use with DRR and DICOM.
+;;; 11-May-1999 I. Kalet in select-patient-from-case-list add
+;;; notification if the specified database has no information or is
+;;; inaccessible.
+;;; 2-Jan-2000 I. Kalet fix error in format directives in
+;;; select-full-image-set function.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 27-Aug-2000 I. Kalet add byte swap of image data if the image
+;;; database indicates a different byte order than the local lisp
+;;; system, as specified by global constant, *byte-order*.
+;;; 14-Oct-2001 I. Kalet in put-plan-data, first make an exact copy of
+;;; the plan, then add it to the temporary patient and store them.
+;;; Prevents mediators from creating double contours, etc. in views.
+;;; 26-Dec-2001 I. Kalet add new function select-cases, which returns
+;;; a list of the selected case entries rather than just one. Also
+;;;add optional search string to select-patient-from-case-list.
+;;; 31-Oct-2003 I. Kalet add new function select-full-image-sets,
+;;; which returns a list of the selected image set entries rather than
+;;; just one. Allows multiple image set deletion. Also add new
+;;; function select-patients-from-case-list for deleting multiple
+;;; patients from checkpoint dir.
+;;; 15-Feb-2004 I. Kalet delete IRREG functions, no longer supported
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------
+
+(defun get-patient-list (database)
+
+ "get-patient-list database
+
+Returns a list of lists, each one containing data about one patient.
+The database parameter is a pathname identifying the directory in
+which the patient database is located, so the scheme allows multiple
+databases, e.g., one for clinical use and one for test cases. If the
+index is missing or inaccessible the function returns NIL."
+
+ (get-index-list "patient.index" database nil))
+
+;;;---------------------------------
+
+(defun get-patient-entry (patient-id database)
+
+ "get-patient-entry patient-id database
+
+Returns a list containing data about one patient. The database
+parameter is a pathname identifying the directory in which the patient
+database is located, so the scheme allows multiple databases, e.g.,
+one for clinical use and one for test cases. If the patient is
+not found, or the index is missing or inaccessible the function
+returns NIL."
+
+ (first (get-index-list "patient.index" database patient-id
+ :test #'=)))
+
+;;;---------------------------------
+
+(defun select-patient (database &optional (search-key ""))
+
+ "select-patient database &optional search-key
+
+returns a patient id number or NIL, after displaying the patient list
+in a popup scrolling list for user selection. If search-key is
+provided it is used to filter the list and show only entries that
+match."
+
+ (let ((patlist (get-patient-list database)))
+ (if patlist
+ (let* ((items
+ (remove nil
+ (mapcar #'(lambda (item)
+ (let ((item-str
+ (format nil
+ "~5 at A ~30A ~11A ~A"
+ (first item)
+ (second item)
+ (third item)
+ (fourth item))))
+ (if (search (string-upcase
+ search-key)
+ (string-upcase
+ item-str))
+ item-str)))
+ patlist)))
+ (selection (if items (sl:popup-scroll-menu
+ items 525 400
+ :font (symbol-value *small-font*))
+ (sl:acknowledge "No entries match request"))))
+ (if selection (read-from-string (nth selection items))))
+ (sl:acknowledge "Patient index is inaccessible"))))
+
+;;;---------------------------------
+
+(defun modify-database-list (mod-fn filename database)
+
+ "modify-database-list mod-fn filename database
+
+Reads the file specified by filename from the specified database,
+executes mod-fn on the list, and writes the modified list back to the
+specified database. Returns T if successful, NIL otherwise. Mod-fn
+takes as a single parameter the database list, and returns a modified
+database list."
+
+ (let ((data-list (get-index-list filename database nil)))
+ (setq data-list (funcall mod-fn data-list))
+ (with-open-file
+ (stream (merge-pathnames filename database)
+ :direction :output :if-exists :new-version)
+ (when (streamp stream)
+ (mapc #'(lambda (entry) (format stream "~S~%" entry))
+ (reverse data-list))
+ t)))) ; return success
+
+;;;---------------------------------
+
+(defun add-patient (pat-id pat-name hosp-no database)
+
+ "add-patient pat-id pat-name hosp-no database
+
+Adds an entry for pat-id, pat-name, hosp-no to the table of patients
+in the patient list for the database specified by database. Returns T
+if successful, NIL otherwise. If the pat-id was already found on the
+patient list, returns T but does not add that patient again."
+
+ (modify-database-list #'(lambda (lst)
+ (if (get-patient-entry pat-id database)
+ lst
+ (push (list pat-id pat-name
+ hosp-no (date-time-string))
+ lst)))
+ "patient.index"
+ database))
+
+;;;---------------------------------
+
+(defun delete-patient (pat-id database)
+
+ "delete-patient pat-id database
+
+Deletes the entry specified by pat-id from the table of patients in
+the patient list for the database specified by database. Returns
+T if successful, NIL otherwise. If pat-id was not found on the
+patient list, returns T but does not change the database."
+
+ (modify-database-list #'(lambda (lst)
+ (remove pat-id lst :key #'first))
+ "patient.index"
+ database))
+
+;;;---------------------------------
+
+(defun edit-patient (pat-id pat-name hosp-no database)
+
+ "edit-patient pat-id pat-name hosp-no database
+
+Edits entry specified by pat-id from the table of patients in the
+patient list for the database specified by database, replacing
+pat-name and hosp-no. Returns T if successful, NIL otherwise. If
+pat-id was not found on the patient list, returns T but does not
+change the database."
+
+ (modify-database-list #'(lambda (lst)
+ (let ((entry (find pat-id lst :key #'first)))
+ (when entry
+ (setf (second entry) pat-name
+ (third entry) hosp-no))
+ lst))
+ "patient.index"
+ database))
+
+;;;---------------------------------
+
+(defun select-patient-from-case-list (patdb casedb
+ &optional (search-key ""))
+
+ "select-patient-from-case-list patdb casedb &optional search-key
+
+returns a patient id number or NIL, after displaying a list of the
+patients with entries in the case index of casedb, using the patient
+index from patdb in a popup scrolling list for user selection. This
+is useful for retrieving information from case databases that hold
+limited sets of cases and no separate patient index, e.g., the user's
+checkpoint database. If search-key is provided it is used to filter
+the list and show only entries that match."
+
+ (let* ((entries
+ (remove nil
+ (mapcar #'(lambda (pat)
+ (let* ((item (get-patient-entry pat patdb))
+ (item-str (format nil
+ "~5 at A ~30A ~11A ~A"
+ (first item)
+ (second item)
+ (third item)
+ (fourth item))))
+ (if (search (string-upcase search-key)
+ (string-upcase item-str))
+ item-str)))
+ (remove-duplicates
+ (mapcar #'first (get-full-case-list casedb))
+ :from-end t))))
+ (selection (if entries (sl:popup-scroll-menu
+ entries 525 400
+ :font (symbol-value *small-font*))
+ (sl:acknowledge "No entries match request"))))
+ (if selection (read-from-string (nth selection entries)))))
+
+;;;---------------------------------
+
+(defun select-patients-from-case-list (patdb casedb
+ &optional (search-key ""))
+
+ "select-patients-from-case-list patdb casedb &optional search-key
+
+returns a list of patient id numbers or NIL, after displaying a list
+of the patients with entries in the case index of casedb, using the
+patient index from patdb in a popup scrolling list for user selection.
+This is useful for retrieving information from case databases that
+hold limited sets of cases and no separate patient index, e.g., the
+user's checkpoint database. If search-key is provided it is used to
+filter the list and show only entries that match."
+
+ (let* ((entries
+ (sort
+ (remove nil
+ (mapcar #'(lambda (pat)
+ (let* ((item (get-patient-entry pat patdb))
+ (item-str (format nil
+ "~5 at A ~30A ~11A ~A"
+ (first item)
+ (second item)
+ (third item)
+ (fourth item))))
+ (if (search (string-upcase search-key)
+ (string-upcase item-str))
+ item-str)))
+ (remove-duplicates
+ (mapcar #'first (get-full-case-list casedb))
+ :from-end t)))
+ #'< :key #'read-from-string))
+ (selections (if entries (sl:popup-scroll-menu
+ entries 525 400
+ :font (symbol-value *small-font*)
+ :multiple t)
+ (sl:acknowledge "No entries match request"))))
+ (if selections
+ (mapcar #'(lambda (sel)
+ (read-from-string (nth sel entries)))
+ selections))))
+
+;;;---------------------------------
+
+(defun get-case-list (patient-id database)
+
+ "get-case-list patient-id database
+
+Returns a list of lists, each one containing data about one patient
+case, without the patient id. Only cases for the patient specified by
+patient-id are listed. This provides for multiple cases or sets of
+anatomy for a given patient. If the case index file is inaccessible
+the function returns NIL."
+
+ (nreverse (mapcar #'rest (get-index-list "case.index" database
+ patient-id :test #'=))))
+
+;;;---------------------------------
+
+(defun get-full-case-list (database)
+
+ "get-full-case-list database
+
+Returns a list of lists, each one containing data about one patient
+case. All cases are listed and each includes the patient id. This is
+most useful for checkpoint databases, where there is no patient list.
+If the case index file is inaccessible the function returns NIL."
+
+ (nreverse (get-index-list "case.index" database nil)))
+
+;;;---------------------------------
+
+(defun select-case (pat-id database &optional (new t))
+
+ "select-case pat-id database &optional (new t)
+
+returns a case id by displaying a popup scrolling list of case
+information for the cases under patient pat-id, and allowing user
+selection. The NEW CASE option is displayed unless new is nil.
+Returns 0 for NEW CASE, NIL if no selection."
+
+ (let* ((caselist (if new (cons (list 0 "NEW CASE" "")
+ (get-case-list pat-id database))
+ (get-case-list pat-id database)))
+ (items (mapcar #'(lambda (item)
+ (format nil "~5 at A ~40A ~A"
+ (first item) (second item)
+ (third item)))
+ caselist))
+ (selection (sl:popup-scroll-menu items 525 150
+ :font (symbol-value *small-font*))))
+ (if selection (first (nth selection caselist)))))
+
+;;;---------------------------------
+
+(defun select-cases (pat-id database)
+
+ "select-case pat-id database
+
+returns a list of case ids by displaying a popup scrolling list of case
+information for the cases under patient pat-id, and allowing user
+selection. Returns NIL if no selection."
+
+ (let* ((caselist (get-case-list pat-id database))
+ (items (mapcar #'(lambda (item)
+ (format nil "~5 at A ~40A ~A"
+ (first item) (second item)
+ (third item)))
+ caselist))
+ (selections (sl:popup-scroll-menu items 525 150
+ :font (symbol-value *small-font*)
+ :multiple t)))
+ (mapcar #'(lambda (sel) (first (nth sel caselist)))
+ selections)))
+
+;;;---------------------------------
+
+(defun add-case (pat-id case-id descrip time-stamp database)
+
+ "add-case pat-id case-id descrip time-stamp database
+
+adds the case description record specified by the given parameters to
+the list of cases. Returns T if successful, NIL otherwise."
+
+ (modify-database-list #'(lambda (lst)
+ (push (list pat-id case-id descrip time-stamp)
+ lst))
+ "case.index"
+ database))
+
+;;;---------------------------------
+
+(defun delete-case (pat-id case-id database)
+
+ "delete-case pat-id case-id database
+
+Deletes the entry specified by pat-id and case-id from the table
+of cases in the case list for the database specified by database.
+Returns T if successful, NIL otherwise. If the pat-id/case-id
+combination was not found on the case list, returns T but does
+not change the database."
+
+ (modify-database-list #'(lambda (lst)
+ (remove (find-if
+ #'(lambda (entry)
+ (and (= pat-id (first entry))
+ (= case-id (second entry))))
+ lst)
+ lst))
+ "case.index"
+ database))
+
+;;;---------------------------------
+
+(defun delete-case-file (pat-num case-num database)
+
+ "delete-case-file pat-num case-num database
+
+Deletes the files corresponding to the specified patient and case
+numbers from the specified database. Returns T if the file existed
+before deletion, NIL if it could not be found."
+
+ (let ((filename (merge-pathnames (format nil "pat-~D.case-~D"
+ pat-num case-num)
+ database)))
+ (when (probe-file filename)
+ (delete-file filename))))
+
+;;;---------------------------------------
+
+(defun get-case-data (patient-id case-id database)
+
+ "get-case-data patient-id case-id database
+
+Returns the case data for the case specified by patient-id and case-id
+in the patient database specified by database. Also initializes
+certain object-valued slots of plans and beams here because they are
+read in from the case file, not initialized by default. This includes
+the dose-grid and grid-view-manager slots in each plan, and the
+collimator and wedge slots in each beam."
+
+ (let ((pat (if (= case-id 0) (make-instance 'patient)
+ (first (get-all-objects (merge-pathnames
+ (format nil "pat-~D.case-~D"
+ patient-id case-id)
+ database))))))
+ (when pat
+ (setf (patient-id pat) patient-id ;; finish init of plans and
+ ;; beams, as in make-plan and make-beam
+ (case-id pat) case-id)
+ (dolist (pln (coll:elements (plans pat)))
+ ;; Save/restore plan time stamp: setting wedge rot. changes it
+ (let ((ts (time-stamp pln)))
+ (dolist (bm (coll:elements (beams pln)))
+ (ev:add-notify bm (new-coll-set (collimator bm))
+ #'invalidate-results)
+ (ev:add-notify bm (new-id (wedge bm))
+ #'invalidate-results)
+ (ev:add-notify bm (new-rotation (wedge bm))
+ #'invalidate-results)
+ ;; Make sure old wedge rots from files are single-floats
+ (when (rotation (wedge bm))
+ (setf (rotation (wedge bm))
+ (coerce (rotation (wedge bm)) 'single-float))))
+ (setf (time-stamp pln) ts))
+ ;; update the plan's timestamp when dose grid changes
+ (ev:add-notify pln (new-coords (dose-grid pln))
+ #'(lambda (pl a)
+ (declare (ignore a))
+ (setf (time-stamp pl) (date-time-string))))
+ (ev:add-notify pln (new-voxel-size (dose-grid pln))
+ #'(lambda (pl a v)
+ (declare (ignore a v))
+ (setf (time-stamp pl) (date-time-string))))
+ ;; update ref. to grid and result in dose surfaces, also
+ ;; some threshold values in the files are not single floats
+ (dolist (ds (coll:elements (dose-surfaces pln)))
+ (setf (dose-grid ds) (dose-grid pln)
+ (threshold ds) (coerce (threshold ds) 'single-float)
+ (result ds) (sum-dose pln)))
+ ;; and arrange for each new dose surface to get set similarly
+ (ev:add-notify pln (coll:inserted (dose-surfaces pln))
+ #'(lambda (pl ann ds)
+ (declare (ignore ann))
+ (setf (dose-grid ds) (dose-grid pl)
+ (result ds) (sum-dose pl))))
+ (setf (grid-vm pln) (make-object-view-manager
+ (coll:make-collection (list (dose-grid pln)))
+ (plan-views pln)
+ #'make-grid-view-mediator))))
+ pat))
+
+;;;---------------------------------
+
+(defun put-case-data (pat-case database)
+
+ "put-case-data pat-case database
+
+adds the patient case pat-case to the patient database specified by
+database. An entry in the case list is made as well as an entry for
+the data. Returns T if successful, NIL otherwise."
+
+ (let ((pat-id (patient-id pat-case))
+ (case-id (case-id pat-case))
+ (descrip (first (comments pat-case))) ; comments is a list
+ (time-stamp (date-entered pat-case)))
+ (when (equal case-id 0)
+ (setq case-id
+ (1+ (apply #'max 0 ; need at least one number here
+ (mapcar #'first
+ (get-case-list pat-id database)))))
+ (setf (case-id pat-case) case-id)
+ (put-all-objects (list pat-case)
+ (merge-pathnames
+ (format nil "pat-~D.case-~D" pat-id case-id)
+ database))
+ (if (listp descrip) (setq descrip (first descrip)))
+ (add-case pat-id case-id descrip time-stamp database))))
+
+;;;---------------------------------
+
+(defun put-plan-data (pat-id case-id plan database)
+
+ "put-plan-data pat-id case-id plan database
+
+Appends the specified plan to the plans for patient id pat-id under
+patient case case-id, in the patient database specified by database.
+Returns T if successful, NIL otherwise."
+
+ (let ((temp-pat (get-case-data pat-id case-id database))) ;; get case
+ (if temp-pat ;; if found, add plan to it, and write it out
+ (let ((temp-plan (copy plan)))
+ (coll:insert-element temp-plan (plans temp-pat))
+ (put-all-objects (list temp-pat)
+ (merge-pathnames
+ (format nil "pat-~D.case-~D" pat-id case-id)
+ database))
+ t)
+ nil)))
+
+;;;---------------------------------
+
+(defun delete-plan-from-case (pat-id case-id plan database)
+
+ "delete-plan-from-case pat-id case-id plan database
+
+Deletes the specified plan from the plans for patient id pat-id under
+patient case case-id, in the patient database specified by database.
+Returns T if successful, NIL otherwise. If a plan is not found in
+the case's list of plans, T is still returned."
+
+ (let ((temp-pat (get-case-data pat-id case-id database)))
+ (when temp-pat
+ (coll:delete-element plan (plans temp-pat)
+ :test #'(lambda (a b)
+ (string-equal (time-stamp a)
+ (time-stamp b))))
+ (put-all-objects (list temp-pat)
+ (merge-pathnames
+ (format nil "pat-~D.case-~D" pat-id case-id)
+ database))
+ t)))
+
+;;;---------------------------------
+
+(defun get-image-set-list (patient-id database)
+
+ "get-image-set-list patient-id database
+
+Returns a list of two element lists each containing an image-id and a
+description string, corresponding to patient-id. Returns NIL if none
+available or image index inaccessible."
+
+ (mapcar #'rest (get-index-list "image.index" database
+ patient-id :test #'=)))
+
+;;;---------------------------------
+
+(defun get-full-image-set-list (database)
+
+ "get-full-image-set-list database
+
+Returns a list of three element lists each containing an patient-id,
+an image-id, and a description string -- the entire contents of the
+specified image database. Returns NIL if the database is
+unavailable."
+
+ (nreverse (get-index-list "image.index" database nil)))
+
+;;;---------------------------------
+
+(defun select-image-set (pat-id database)
+
+ "select-image-set pat-id database
+
+lists image sets available for patient pat-id in the specified
+database, and returns NIL for no selection or none available, or the
+image-set-id if one is selected."
+
+ (let* ((study-list (get-image-set-list pat-id database))
+ (studies (mapcar #'second study-list))
+ (item (if studies (sl:popup-menu studies)
+ (sl:acknowledge "No image studies available"))))
+ (if item (first (nth item study-list)))))
+
+;;;---------------------------------
+
+(defun select-full-image-set (database &rest initargs)
+
+ "select-full-image-set database &rest initargs
+
+lists all available image sets in the specified database, and returns
+NIL for no selection or none available, or a (pat-id image-id descrip)
+list if one is selected."
+
+ (let* ((study-list (sort (get-full-image-set-list database)
+ #'< :key #'first))
+ (selections (mapcar #'(lambda (sdy)
+ (format nil "~4 at A ~4 at A ~50A"
+ (first sdy)
+ (second sdy)
+ (third sdy)))
+ study-list))
+ (item (if study-list
+ (apply #'sl:popup-scroll-menu selections
+ 525 150 :font (symbol-value *small-font*)
+ initargs)
+ (sl:acknowledge "No image studies available"))))
+ (if item (nth item study-list))))
+
+;;;---------------------------------
+
+(defun select-full-image-sets (database &rest initargs)
+
+ "select-full-image-sets database &rest initargs
+
+lists all available image sets in the specified database, and returns
+NIL for no selection or none available, or a list of (pat-id image-id
+descrip) lists if one or more are selected."
+
+ (let* ((study-list (get-full-image-set-list database))
+ (selections
+ (mapcar #'(lambda (stdy)
+ (format nil "~5 at A ~A ~4 at A ~50A"
+ (first stdy)
+ (second (get-patient-entry
+ (first stdy) *patient-database*))
+ (second stdy)
+ (third stdy)))
+ study-list))
+ (items (if study-list
+ (apply #'sl:popup-scroll-menu selections
+ 525 150 :font (symbol-value *small-font*)
+ :multiple t
+ initargs)
+ (sl:acknowledge "No image studies available"))))
+ (if items (mapcar #'(lambda (sel) (nth sel study-list))
+ items))))
+
+;;;---------------------------------
+
+(defun add-image-set (pat-id image-set-id descrip database)
+
+ "add-image-set pat-id image-set-id descrip database
+
+adds the image set description record specified by the given
+parameters to the list of image sets. Returns T if successful, NIL
+otherwise."
+
+ (modify-database-list #'(lambda (lst)
+ (push (list pat-id image-set-id descrip)
+ lst))
+ "image.index"
+ database))
+
+;;;-------------------------------------------
+
+(defun byte-swap (binarray)
+
+ "byte-swap binarray
+
+swaps the bytes of each element of binarray, a 2-d array of unsigned
+16-bit words. Used when reading in image data if necessary."
+
+ (let* ((dims (array-dimensions binarray))
+ (xdim (first dims))
+ (ydim (second dims)))
+ (declare (type (simple-array (unsigned-byte 16) (* *))
+ binarray)
+ (fixnum xdim ydim))
+ (dotimes (i xdim)
+ (declare (fixnum i))
+ (dotimes (j ydim)
+ (declare (fixnum j))
+ (let ((val (aref binarray i j)))
+ (declare (type (unsigned-byte 16) val))
+ (setf (aref binarray i j)
+ (+ (ash (logand 65280 val) -8)
+ (ash (logand 255 val) 8))))))))
+
+;;;---------------------------------
+
+(defun get-image-set (patient-id image-id database)
+
+ "get-image-set patient-id image-id database
+
+Returns a list of images that are in the specified image set,
+corresponding to patient-id and image-id."
+
+ (let ((images (get-all-objects (merge-pathnames
+ (format nil "pat-~D.image-set-~D"
+ patient-id image-id)
+ database)))
+ (img-byte-order (aif (probe-file (merge-pathnames
+ "image.config" database))
+ (with-open-file (config it)
+ (read config))
+ *byte-order*)))
+ (unless (eq *byte-order* img-byte-order)
+ (format t "Swapping bytes in image set...~%")
+ (dolist (img images)
+ (format t "Swapping bytes in image ~A~%" (id img))
+ (byte-swap (pixels img))))
+ images))
+
+;;;---------------------------------
+
+(defun put-image-set (patient-id image-set database)
+
+ "put-image-set patient-id image-set database
+
+adds the specified image set to the image sets for patient id pat-id,
+in the image database specified by database. If successful the
+function returns T. If the database does not exist, the function
+returns NIL."
+
+ (let ((image-set-id (1+ (apply #'max 0 ; need at least one number here
+ (mapcar #'first
+ (get-image-set-list
+ patient-id database))))))
+ (dolist (im image-set)
+ (setf (patient-id im) patient-id
+ (image-set-id im) image-set-id))
+ (put-all-objects image-set (merge-pathnames
+ (format nil "pat-~D.image-set-~D"
+ patient-id image-set-id)
+ database))
+ (add-image-set patient-id image-set-id
+ (description (first image-set))
+ database)))
+
+;;;---------------------------------
+
+(defun delete-image-set (pat-id img-set-id database)
+
+ "delete-image-set pat-id img-set-id database
+
+Deletes the entry specified by pat-id & img-set-id from the table of
+images in the image list for the database specified by database.
+Returns T if successful, NIL otherwise. If the the pat-id/img-set-id
+combination was not found on the image list, returns T but does not
+change the database."
+
+ (modify-database-list
+ #'(lambda (lst)
+ (remove (find-if
+ #'(lambda (entry)
+ (and (= pat-id (first entry))
+ (= img-set-id (second entry))))
+ lst)
+ lst))
+ "image.index"
+ database))
+
+;;;---------------------------------
+
+(defun delete-image-files (pat-num img-num database)
+
+ "delete-image-files pat-num img-num database
+
+Deletes the image files (and image-set file) corresponding to the
+specified patient and image numbers from the specified database. If
+the image-set file existed before, deletes image files (if any) and
+returns T; if not, deletes nothing and returns NIL."
+
+ ;; for now, delete all pat-i.image-j-k files for all k's, even if
+ ;; there are some k's that are not specified in the image-set file.
+
+ (let ((image-set-filename
+ (merge-pathnames
+ (format nil "pat-~D.image-set-~D" pat-num img-num)
+ database)))
+ (when (probe-file image-set-filename)
+ (delete-file image-set-filename)
+ (dolist (image-file
+ (directory
+ (merge-pathnames
+ (format nil "pat-~D.image-~D-*" pat-num img-num)
+ database)))
+ (delete-file image-file))
+ t))) ;; return T if image-set file existed, otherwise NIL
+
+;;;---------------------------------
+;;; End.
diff --git a/prism/src/prism-globals.cl b/prism/src/prism-globals.cl
new file mode 100644
index 0000000..949b5b0
--- /dev/null
+++ b/prism/src/prism-globals.cl
@@ -0,0 +1,390 @@
+;;;
+;;; prism-globals
+;;;
+;;; this file contains all the defvar and defparameter forms to define
+;;; the global prism parameters. This does not include some stuff that is
+;;; specific to a particular panel or function.
+;;;
+;;; 13-May-1994 I. Kalet created from prism-system.
+;;; 22-May-1994 I. Kalet add easel constants.
+;;; 26-May-1994 J. Unger add line to hardcopy header.
+;;; 27-May-1994 J. Unger change nil to none *immob-devices* list.
+;;; 2-Jun-1994 I. Kalet modify and expand constants.
+;;; 6-Jun-1994 I. Kalet add digitizer device list.
+;;; 8-Jun-1994 J. Unger elim *save-plan-dose* mechanism for saving dose info.
+;;; 7-Jul-1994 J. Unger add *config-directory* defvar form.
+;;; 18-Sep-1994 J. Unger add neutron & mlc defvar forms, minor other mods.
+;;; 03-Oct-1994 J. Unger change version string to October, 1994.
+;;; 26-Jan-1995 I. Kalet change version string to January, 1995. Move
+;;; *therapy-machines* to therapy-machines module. Not global.
+;;; 12-Mar-1995 I. Kalet add digitizer input string processing and
+;;; calibration parameters.
+;;; 1-Aug-1995 I. Kalet change version string to Version 1.1 - July
+;;; 1995.
+;;; 26-Sep-1995 I. Kalet add "File only" to printer-dests, change
+;;; defparameter to defvar.
+;;; 29-Jan-1997 I. Kalet add *pi-over-180* in wake of elimination of
+;;; geometry package, also *pi-over-2* is handy. Eliminate dosecomp
+;;; globals, dose comp is now integrated in the lisp code.
+;;; 30-Apr-1997 I. Kalet add *ruler-color* to user configurables.
+;;; 3-May-1997 I. Kalet change version string to Version 1.2X
+;;; 18-Jun-1997 I. Kalet delete selector panel sizes, as they vary.
+;;; 22-Aug-1997 I. Kalet change default directories for new UW Radonc
+;;; cluster, add *irreg-database*
+;;; 17-Sep-1997 I. Kalet add *machine-index-directory*, change
+;;; defaults so beamdata directory is at higher level, since there
+;;; does not need to be a separate research or test beamdata directory
+;;; in the new system.
+;;; 2-May-1998 I. Kalet drop *mlc-chart-file* and
+;;; *neutron-chart-file* since they are not used anymore.
+;;; 19-May-1998 I. Kalet Provide for multiple plotter destinations and
+;;; types. Delete plotter text color, it is set by plotter type.
+;;; 1-Jul-1998 I. Kalet Make the PostScript plotter the default.
+;;; 30-Nov-1998 I. Kalet add support for HP Design Jet 455C plotter.
+;;; 28-Jun-1999 J. Zeman add *postscript-printers*
+;;; 8-Sep-1999 I. Kalet add *mlc-leaf-color*
+;;; 25-Oct-1999 I. Kalet remove autoplan stuff.
+;;; 5-Jan-2000 I. Kalet add *brachy-database* and *display-epsilon*
+;;; 25-Apr-2000 BobGian add *irreg-printout* to control irreg QA printout.
+;;; 26-Apr-2000 I. Kalet make default nil for *irreg-printout*
+;;; 27-May-2000 I. Kalet parametrize small and medium fonts for
+;;; panels, remove *max-chart-lines* and *printers* since they are no
+;;; longer used.
+;;; 21-Jun-2000 BobGian remove *irreg-printout* - no longer used.
+;;; 27-Jun-2000 I. Kalet add *display-format* which specifies how the
+;;; z coordinates in the filmstrip and easel are displayed. Also drop
+;;; *display-epsilon* down to 0.001 instead of 0.005.
+;;; 29-Jun-2000 I. Kalet add *special-functions* parameter for tools panel
+;;; 13-Aug-2000 I. Kalet move most digitizer globals to digitizer module.
+;;; 27-Dec-2000 I. Kalet change order of postscript printer list,
+;;; change version number to 1.4.
+;;; 18-Mar-2001 I. Kalet add configurable parameters *fg-gray-level*,
+;;; *bg-gray-level* and *border-style*, and make the defaults black on
+;;; gray with raised borders.
+;;; 28-Jan-2002 I. Kalet add dicom-panel to built in special tools list
+;;; 30-Aug-2002 BobGian add *dicom-ae-titles*, mapping hostnames to AE titles.
+;;; 23-Sep-2002 BobGian Move pr::*DICOM-AE-TITLES* to DICOM package and from
+;;; "prism-globals" in Prism dir to "dicom-client.system" in Dicom dir.
+;;; 12-Jun-2003 BobGian regularize database variables (values are generic here,
+;;; set to site-specific directories in "prism.config"). Also add
+;;; *structure-database* to parameterize structure-set import tool.
+;;; Structure-set importer now on *special-tools* menu rather than being
+;;; added via ADD-TOOLS.
+;;; 27-Aug-2003 I. Kalet update release no. - DICOM fixes, window
+;;; close intercept in SLIK
+;;; 1-Nov-2003 I. Kalet update release no. - enhancements to patdbmgr
+;;; panel, to allow multiple selections, sort by Prism ID, include
+;;; patient name in image study display, also fix dependencies and
+;;; take out unnecessary #. reader macros
+;;; 25-Mar-2004 BobGian update release no - DMP functionality added to Dicom.
+;;; 14-Jun-2004 BobGian update release to V1.4-5
+;;; 2-Jul-2004 I. Kalet add *shared-database* for shared checkpoint
+;;; directory, and *other-databases* for list of other checkpoint
+;;; directories, add couch lateral and longitudinal limits, remove irreg
+;;; support, update release no. to 1.4-6
+;;; 04-Nov-2004 BobGian move *DICOM-LOG-DIR* and *PDR-DATA-FILE* from
+;;; "dicom-client.system" -> here.
+;;; 22-Feb-2005 A. Simms add #+cmu byte-order detection
+;;; 27-Jun-2007 I. Kalet update release to 1.5-1
+;;; 25-May-2009 I. Kalet add new global *prism-version* to use with
+;;; *features* and read-time conditionals
+;;; 24-Jun-2009 I. Kalet move defpackage here to make independent of
+;;; defsystem.
+;;;
+
+;;;-------------------------------------
+
+ ;; needed for :use below, defined more fully in inference.cl
+(defpackage "INFERENCE")
+
+(defpackage "PRISM"
+ (:nicknames "PR")
+ (:use "COMMON-LISP" "INFERENCE")
+ (:export "ACQ-DATE" "ACQ-TIME" "ADD-PATIENT" "ADD-TOOL" "ANATOMY"
+ "ARC-SIZE" "ATTEN-FACTOR" "ATTRIBUTE-EDITOR" "AVERAGE-SIZE"
+ "BACKGROUND" "BACKGROUND-DISPLAYED" "BEAM"
+ "BEAM-BLOCK" "BEAMS" "BEAMS-EYE-VIEW"
+ "BIN-ARRAY-FILENAME" "BIN-ARRAY-PATHNAME"
+ "BLOCKS"
+ "CAL-DISTANCE" "CASE-ID" "CELL-TYPE" "CHARACTERS"
+ "CM-CONTOUR" "CNTS-COLL"
+ "COLLIMATOR" "COLLIMATOR-ANGLE" "COLLIMATOR-TYPE"
+ "COLOR"
+ "COMBINATION-COLL" "COMMENTS" "COMPUTE-DOSE-GRID"
+ "COMPUTE-DOSE-POINTS" "CONE-SIZE" "CONTOUR"
+ "CONTOUR-EDITOR" "CONTOURS" "COPY-BEAM"
+ "CORONAL-VIEW" "COUCH-LATERAL"
+ "COUCH-LONGITUDINAL" "COUCH-HEIGHT" "COUCH-ANGLE"
+ "DATE-ENTERED" "DATE-TIME-STRING" "DENSITY"
+ "DESCRIPTION" "DESTROY" "DIAMETER"
+ "DISPLAY-COLOR" "DISPLAY-VIEW" "DOSE-GRID"
+ "DOSE-RESULT" "DOSE-SURFACE"
+ "DOSE-SURFACES" "DRAW" "DUMP-PRISM-IMAGE"
+ "ELECTRON-COLL" "ENERGY" "ENLARGE-ARRAY-2"
+ "FILMSTRIP" "FIND-TRANSVERSE-IMAGE" "FINDINGS"
+ "FIXED" "FOREGROUND"
+ "GANTRY-ANGLE" "GENERATE-IMAGE-FROM-SET"
+ "GENERIC-PANEL" "GENERIC-PRISM-OBJECT"
+ "GET-ALL-OBJECTS" "GET-CASE-DATA" "GET-CASE-LIST"
+ "GET-IMAGE-SET" "GET-IMAGE-SET-LIST" "GET-NUMBER"
+ "GET-OBJECT" "GET-PATIENT-LIST" "GET-STRING"
+ "GET-THERAPY-MACHINE" "GET-THERAPY-MACHINE-LIST"
+ "GET-TRANSVERSE-IMAGE" "GETENV"
+ "GRADE" "GRID" "GRID-GEOMETRY"
+ "HISTORY" "HOSP-NAME" "HOSPITAL-ID" "HOW-DERIVED"
+ "ID" "IMAGE" "IMAGE-2D" "IMAGE-3D" "IMAGE-SET"
+ "IMAGE-SET-ID" "IMAGES"
+ "IMG-TYPE" "IMMOB-DEVICE" "INDEX" "INDICES"
+ "INTERACTIVE-MAKE-VIEW"
+ "LEAF-SETTINGS" "LINE-SOURCE" "LINE-SOURCES"
+ "LLC-ANAT" "LOCATOR"
+ "MACHINE" "MAKE-ATTRIBUTE-EDITOR" "MAKE-BEAM"
+ "MAKE-CHARACTERS-PRIM" "MAKE-CONTOUR-EDITOR"
+ "MAKE-CORONAL-IMAGE"
+ "MAKE-DOSE-RESULT-MANAGER" "MAKE-DOSE-SURFACE"
+ "MAKE-DOSE-VIEW-MEDIATOR"
+ "MAKE-FILMSTRIP" "MAKE-GRID-GEOMETRY"
+ "MAKE-IMAGE-VIEW-MANAGER" "MAKE-LINES-PRIM"
+ "MAKE-OBJECT-VIEW-MANAGER" "MAKE-ORGAN"
+ "MAKE-PLAN" "MAKE-POINT-DOSE-PANEL"
+ "MAKE-RECTANGLES-PRIM" "MAKE-SAGITTAL-IMAGE"
+ "MAKE-SEGMENTS-PRIM" "MAKE-SELECTOR-PANEL"
+ "MAKE-TARGET" "MAKE-TUMOR" "MAKE-VIEW"
+ "MAKE-VIEW-SET-MEDIATOR" "MAX-LENGTH"
+ "MONITOR-UNITS" "MULTILEAF-COLL"
+ "N-STAGE" "N-TREATMENTS" "NAME"
+ "OBJECT" "OBJECT-SET" "ORGAN" "ORGAN-NAME" "ORIGIN"
+ "PARTICLE" "PART-OF" "PATIENT" "PATIENT-ID" "PAT-POS"
+ "PENUMBRA" "PHYSICAL-VOLUME"
+ "PICTURE" "PIX-PER-CM" "PIXEL-CONTOUR" "PIXELS"
+ "PIXMAPS" "PLAN" "PLAN-BY" "PLAN-VIEWS"
+ "PLANS" "POINTS" "POLYLINE" "PORTAL"
+ "PRESCRIPTION-USED" "PRINT-TREE" "PRISM"
+ "PRISM-TOP-LEVEL" "PROJECT-PORTAL" "PSTRUCT"
+ "PULM-RISK" "PUT-ALL-OBJECTS"
+ "PUT-CASE-DATA" "PUT-IMAGE-SET" "PUT-OBJECT"
+ "PUT-PLAN-DATA"
+ "RANGE" "READ-BIN-ARRAY" "RECTANGLES"
+ "REFRESH-BG" "REFRESH-FG" "REFRESH-IMAGE"
+ "REGION" "REQUIRED-DOSE" "RESIZE-IMAGE"
+ "ROTATION"
+ "SAGITTAL-VIEW" "SCALE" "SCANNER-TYPE" "SEED"
+ "SEEDS" "SIDE" "SITE" "SIZE"
+ "SSD" "STATUS-CHANGED"
+ "SUM-DOSE" "SYMMETRIC-JAW-COLL"
+ "T-STAGE" "TAB-PRINT" "TARGET"
+ "TARGET-TYPE" "TARGETS" "THERAPY-MACHINE"
+ "THICKNESS" "THRESHOLD" "TIME-STAMP"
+ "TOLERANCE-DOSE" "TRANSMISSION"
+ "TRANSVERSE-VIEW" "TUMOR"
+ "UID" "UNITS" "UPDATE-VIEW" "URC-ANAT"
+ "VALID-GRID" "VALID-POINTS" "VARIABLE-JAW-COLL"
+ "VERTICES" "VIEW" "VIEW-POSITION" "VIEW-SET"
+ "VOXEL-SIZE" "VOXELS"
+ "WEDGE" "WITHIN" "WRITE-BIN-ARRAY"
+ "X" "X-DIM" "X-INF" "X-ORIENT" "X-ORIGIN"
+ "X-SIZE" "X-SUP"
+ "Y" "Y-DIM" "Y-INF" "Y-ORIENT" "Y-ORIGIN"
+ "Y-SIZE" "Y-SUP"
+ "Z" "Z-DIM" "Z-ORIGIN" "Z-SIZE"
+ ;; following needed for backward compatibility
+ ;; with old case data files
+ "PATIENT-OF" "PLAN-OF" "RESULT" "TABLE-POSITION"
+ ))
+
+(in-package :prism)
+
+;;;-------------------------------------
+;;; some useful symbolic constants
+;;;-------------------------------------
+
+(defconstant *pi-over-180* (coerce (/ pi 180.0) 'single-float))
+(defconstant *pi-over-2* (coerce (/ pi 2.0) 'single-float))
+
+;;;-------------------------------------
+;;; nonconfigurable global parameters
+;;;-------------------------------------
+
+(defvar *config-directory* "/radonc/prism/"
+ "The directory of the prism.config file")
+
+(defconstant *prism-version* :prism-version-1.5
+ "A symbol indicating the current version of Prism")
+
+(defconstant *prism-version-string* "V1.5-2"
+ "A string indicating the current version of Prism")
+
+(defconstant *byte-order*
+ #+big-endian :big-endian #+little-endian :little-endian
+ #+cmu (if (= (extensions:htons 42) 42) :big-endian :little-endian)
+ "Used to decide whether to swap image bytes or not.")
+
+(defconstant *mini-image-size* 128 "The size of the mini-images to be
+used in the easel and other applications.")
+
+(defconstant small 256 "pixels on a side for small image")
+(defconstant medium 512 "pixels on a side for medium image")
+(defconstant large 768 "pixels on a side for large image")
+
+;;;-------------------------------------
+;;; configurable globals - per user
+;;;-------------------------------------
+
+(defvar *patient-database* "/prismdata/cases/"
+ "The location of the Prism archive patient case data files.")
+
+(defvar *local-database* "~/prismlocal/"
+ "The location of the Prism checkpointed patient case data files.")
+
+(defvar *shared-database* "/prismdata/casetemp/"
+ "The location of the Prism shared checkpointed patient case data files.")
+
+(defvar *other-databases* nil
+ "Additional Prism checkpoint locations, e.g. of other users, from
+ which to retrieve patient case data files.")
+
+(defvar *therapy-machine-database* "/prismdata/beamdata/"
+ "The location of the Prism therapy machine descriptive and dose
+computation database files")
+
+(defvar *machine-index-directory* "/prismdata/beamdata/"
+ "The location of the machine.index and machine.supp files.")
+
+(defvar *brachy-database* "/prismdata/clinical/"
+ "The location of the Prism brachytherapy source catalog file.")
+
+(defvar *image-database* "/prismdata/images/"
+ "The location of the Prism image data files.")
+
+(defvar *structure-database* "/prismdata/structures/"
+ "Directory containing structure sets.")
+
+(defvar *chart-file* "~/chart.cht"
+ "The pathname to the file containing the generated chart.")
+
+(defvar *plotter-file* "~/plot.plt"
+ "The pathname to the file of plotter commands which is generated and
+spooled upon creation of a plot.")
+
+(defvar *neutron-setup-file* "~/neutron.dat"
+ "The pathname to the file containing the output neutron beam setup info.")
+
+(defvar *fine-grid-size* 0.5
+ "The dimensions, in centimeters, of each voxel of a finely spaced
+dose grid.")
+
+(defvar *medium-grid-size* 1.0
+ "The dimensions, in centimeters, of each voxel of a medium spaced
+dose grid.")
+
+(defvar *coarse-grid-size* 2.0
+ "The dimensions, in centimeters, of each voxel of a coarsely spaced
+dose grid.")
+
+(defvar *minimum-grid-size* 4.0
+ "The minimum allowable value for the overall length, width, or
+height of the dose grid, in centimeters.")
+
+(defvar *easel-size* medium
+ "The size (in pixels) of the easel's contour editor drawing
+region.")
+
+(defvar *ruler-color* 'sl:white
+ "The default or initial color of a tape measure, e.g. in the contour
+editor or point editor etc.")
+
+(defvar *mlc-leaf-color* 'sl:gray
+ "The color of the MLC leaves in the mlc or CNTS collimator
+portal/leaf editing panel.")
+
+(defvar *display-epsilon* 0.001
+ "The distance within which two planar contours or a contour and an
+ image are considered in the same plane")
+
+(defvar *display-format* "~,3F"
+ "The format string used for display of z values for contours, in the
+ filmstrip, the easel, and possibly elsewhere.")
+
+(defvar *fg-gray-level* 0.0
+ "The foreground gray level for all the Prism control panels - user
+ settable as different gray levels might work better for different people.")
+
+(defvar *bg-gray-level* 0.75
+ "The background gray level for all the Prism control panels - user
+ settable as different gray levels might work better for different people.")
+
+(defvar *border-style* :raised
+ "The default border style, should be coordinated with the previous
+ parameters in order to look OK.")
+
+(defvar *small-font* 'sl:helvetica-medium-12
+ "Used for smaller buttons, etc. e.g. on beam panel")
+
+(defvar *medium-font* 'sl:helvetica-medium-14
+ "Used for larger buttons, e.g. on patient panel")
+
+(defvar *couch-lat-lower* -75.0 "Lower limit for couch lateral
+motion, configurable to allow for extended SSD treatments")
+
+(defvar *couch-lat-upper* 75.0 "Upper limit for couch lateral
+motion, configurable to allow for extended SSD treatments")
+
+(defvar *couch-long-lower* -75.0 "Lower limit for couch longitudinal
+motion, configurable to allow for odd calibrations of some CT sim systems")
+
+(defvar *couch-long-upper* 75.0 "Upper limit for couch longitudinal
+motion, configurable to allow for odd calibrations of some CT sim systems")
+
+;;;-------------------------------------
+;;; configurable globals - per system
+;;;-------------------------------------
+
+(defvar *immob-devices* '(("No immob dev" none)
+ ("Mask" mask)
+ ("Alpha cradle" alpha-cradle)
+ ("Plaster shell" plaster-shell))
+ "Table for popup menu in patient panel")
+
+(defvar *digitizer-devices* '(("none" "/dev/digit"))
+ "Association list of digitizer device filenames for various hosts")
+
+(defvar *spooler-command* "lp -c -d"
+ "The command string to spool a chart file or a file of plotter
+commands. The -c flag instructs the spooler to make a copy of the
+file in the spooling directory. The -d flag indicates that the name
+of a destination printer or plotter is to follow. This name is
+appended to the end of this command string, which is then executed.")
+
+(defvar *plotters* '(("ps184" ps-plot)
+ ("PS File only" ps-plot)
+ ("hp7550a" hp7550a-plot)
+ ("dj455c" hp455c-plot)
+ ("HP File only" hp7550a-plot))
+ "The available plotter queue names as known by the system's print
+spooler, and plot types for each.")
+
+(defvar *postscript-printers* '("ps146b" "ps184" "ps136" "File Only"))
+
+(defvar *hardcopy-header* '("Radiation Oncology Department"
+ "University of Washington Medical Center")
+ "The text that appears at the top of every chart and plot.")
+
+(defvar *special-tools*
+ '(("DICOM Transfer" make-dicom-panel)
+ ("Neutron Transfer" make-neutron-panel)
+ ("Import Structures" make-import-structure-set-panel))
+ "Menu text and corresponding function names for the tools panel")
+
+;;;-------------------------------------
+;;; DICOM Parameters -- Configurable via "/radonc/prism/prism.config".
+
+(defvar *dicom-log-dir* "/prismdata/pdr-logs/") ;Transaction record.
+
+;;; Debugging dump written in :Create/:Supersede mode so only most recent
+;;; is preserved. Note that this file gets written into the home directory
+;;; of the Prism user. This is OK since Prism client always runs as a user
+;;; process - never as root.
+(defvar *pdr-data-file* "~/pdr.dat")
+
+;;;-------------------------------------
+;;; End.
diff --git a/prism/src/prism-objects.cl b/prism/src/prism-objects.cl
new file mode 100644
index 0000000..af320a6
--- /dev/null
+++ b/prism/src/prism-objects.cl
@@ -0,0 +1,136 @@
+;;;
+;;; prism-objects
+;;;
+;;; This is the code that defines generic named prism objects that are
+;;; created and manipulated by the various panels. This includes
+;;; objects such as patients, plans, organs, and beams, but not
+;;; contours, which are not named and do not appear in lists.
+;;;
+;;; 16-Sep-1992 I. Kalet created from code in selector-panels
+;;; 15-Oct-1992 I. Kalet add default draw method
+;;; 29-Dec-1992 I. Kalet add <CR> in default draw method message
+;;; 15-Feb-1993 I. Kalet add the bp-y function here - used by several
+;;; panels
+;;; 19-Sep-1996 I. Kalet remove &rest from draw method
+;;; 10-Jun-1997 I. Kalet add default method for display-color and
+;;; new-color
+;;; 1-Feb-2003 I. Kalet move default method for name here from view-panels
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------
+
+(defclass generic-prism-object ()
+
+ ((name :type string
+ :accessor name
+ :initarg :name
+ :documentation "The name string for each instance of an
+object, e.g., patient name, or plan name.")
+
+ (new-name :type ev:event
+ :accessor new-name
+ :initform (ev:make-event)
+ :documentation "Announced when the name attribute is
+updated.")
+
+ )
+
+ (:default-initargs :name "Generic Prism object.")
+
+ (:documentation "This is the basic prism object definition for
+objects that will have names and be created and deleted via selector
+panels, and with their own editing panels.")
+
+ )
+
+;;;---------------------------------------
+
+(defmethod (setf name) :after (text (obj generic-prism-object))
+
+ (ev:announce obj (new-name obj) text))
+
+;;;---------------------------------------
+
+(defmethod not-saved ((object generic-prism-object))
+
+ '(new-name))
+
+;;;--------------------------------------
+
+(defmethod name ((obj t))
+
+ "default name for anything"
+
+ "no name")
+
+;;;---------------------------------------
+
+(defmethod draw ((obj t) (v t))
+
+ "DRAW (obj t) (v t)
+
+This is a default or stub method so we can build and use the various
+functions without crashing on not yet implemented draw calls."
+
+ (format t "No DRAW method for class ~A in ~A~%"
+ (class-name (class-of obj))
+ (class-name (class-of v))))
+
+;;;---------------------------------------
+
+(defmethod display-color ((obj t))
+
+ "stub method for reference by selector panels code or other code."
+
+ (format t "No DISPLAY-COLOR method for class ~A~%"
+ (class-name (class-of obj))))
+
+;;;---------------------------------------
+
+(defmethod new-color ((obj t))
+
+ "stub method for reference by selector panels code or other code."
+
+ (format t "No NEW-COLOR method for class ~A~%"
+ (class-name (class-of obj))))
+
+;;;---------------------------------------
+
+(defclass generic-panel ()
+
+ ((deleted :type ev:event
+ :accessor deleted
+ :initform (ev:make-event)
+ :documentation "Announced when the panel is deleted.")
+
+ )
+
+ (:documentation "This is the basic prism panel definition, for
+panels that edit various classes of prism objects.")
+
+ )
+
+;;;---------------------------------------
+
+(defmethod destroy ((p generic-panel))
+
+ "Panels need a destroy method to be called by the
+button-panel-mediator when their button is deselected."
+
+ (ev:announce p (deleted p)))
+
+;;;---------------------------------------
+
+(defun bp-y (start-y button-height n)
+
+ "BP-Y start-y button-height n
+
+allows a 5 pixel spacing and computes the ulc-y pixels for the nth
+button or textline in a panel left side button stack. The first
+button is button 0, which is at start-y."
+
+ (+ start-y (* n (+ button-height 5))))
+
+;;;---------------------------------------
diff --git a/prism/src/prism.cl b/prism/src/prism.cl
new file mode 100644
index 0000000..7c19235
--- /dev/null
+++ b/prism/src/prism.cl
@@ -0,0 +1,124 @@
+;;;
+;;; prism
+;;;
+;;; This module provides a top level function that creates a patient
+;;; panel. If the optional argument is missing, a new patient object
+;;; is created.
+;;;
+;;; 22-Aug-1992 I. Kalet created
+;;; 30-Nov-1992 I. Kalet take out archive panel for now
+;;; 30-Dec-1992 I. Kalet delete views from plans on exit
+;;; 1-Jul-1993 I. Kalet return the right patient instance
+;;; 31-Jul-1993 I. Kalet load slik here.
+;;; 18-Oct-1993 J. Unger add dosecomp invokation and termination.
+;;; 6-Apr-1994 I. Kalet add top level function
+;;; 4-May-1994 J. Unger add load forms for ruler-system and
+;;; polygon-system.
+;;; 13-May-1994 I. Kalet split off load forms to load-prism, load
+;;; therapy machines and user and system config files here.
+;;; 6-Jun-1994 I. Kalet add digitizer initialization
+;;; 7-Jul-1994 J. Unger read config file from *config-directory*
+;;; variable.
+;;; 26-Jan-1995 I. Kalet change digitizer function name from gp8 to
+;;; digit and correct comments above. Also, use new function
+;;; load-therapy-machines instead of referencing *therapy-machines*
+;;; 29-Jan-1997 I. Kalet mods for integrated dose computation -
+;;; therapy machines now load on demand, no beamdose subprocess.
+;;; 21-Jun-1997 BobGian - minor fixups (eliminated redundant vars).
+;;; 19-Sep-1997 BobGian notes here that references to old function
+;;; load-therapy-machines now refer instead to new function
+;;; get-therapy-machine.
+;;; 17-Jun-1998 I. Kalet add another debug hook, a global to hold the
+;;; patient panel for access from a break loop. Also use anaphors in
+;;; loading config files.
+;;; 30-Oct-1998 I. Kalet add read-time conditionals to handle wierd
+;;; HP-UX bug regarding default X host with Allegro 5.0
+;;; 15-Jun-1999 I. Kalet finally change X host determination from
+;;; command line parameter to DISPLAY environment variable.
+;;; 2-Jan-2000 I. Kalet add brachytherapy source catalog file load
+;;; 4-Sep-2000 I. Kalet use localhost for blank host, it works
+;;; everywhere, instead of the wierd HP behavior. It seems that CLX
+;;; and xlib are incompatible with respect to blank or empty strings.
+;;; 11-Mar-2001 I. Kalet add copying of fg-gray-level, bg-gray-level
+;;; and border-style to SLIK to make panel background level user
+;;; configurable. Also add dump-prism-image for convenience.
+;;; 18-Mar-2001 I. Kalet use blank string where possible (linux in
+;;; particular) as local Unix sockets are more efficient and available
+;;; than the loopback path.
+;;; 30-Jul-2003 I. Kalet restore dump-prism-image.
+;;; 25-May-2009 I. Kalet add new variable *prism-version* to
+;;; *features* to allow conditional load of patches etc. in prism.config
+;;; 24-Jun-2009 I. Kalet move dump-prism-image to separate file, not
+;;; really part of the Prism system.
+;;; 13-Nov-2009 I. Kalet parametrize location of prism.config with
+;;; environment variable PRISM_CONFIG_DIRECTORY, use getenv instead of
+;;; sys:getenv, so hopefully will work in other lisps besides ACL.
+;;; 16-Jul-2011 I. Kalet just use value of DISPLAY in prism-top-level
+;;; since prism does too, and sl:initialize parses the host info,
+;;; assuming it includes the display number. This will allow for ssh
+;;; tunneling with non-zero display number.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defvar *patient-panel* nil "The patient panel, for debugging only.")
+
+;;;--------------------------------------
+
+(defun prism (host &optional pat)
+
+ (format t "~%Prism ~A is starting.~%" *prism-version-string*)
+ (push *prism-version* *features*) ;; for patch management
+
+ ;; read in the prism.config file - optional, may not exist
+ (aif (probe-file (merge-pathnames "prism.config"
+ (getenv "PRISM_CONFIG_DIRECTORY")))
+ (load it))
+ ;; read in the .prismrc file - ditto
+ (aif (probe-file (merge-pathnames ".prismrc" (user-homedir-pathname)))
+ (load it))
+ ;; read in the brachytherapy source catalog file - optional, may not exist
+ (aif (probe-file (merge-pathnames "source-catalog" *brachy-database*))
+ (setf *brachy-tables* (get-all-objects it)))
+ (setf sl:*fg-level* *fg-gray-level*)
+ (setf sl:*bg-level* *bg-gray-level*)
+ (setf sl:*default-border-style* *border-style*)
+ (sl:initialize host)
+ (let ((pat-panel (make-patient-panel
+ (or pat (make-instance 'patient))))
+ (digitizer (second (assoc (sl:host) *digitizer-devices*
+ :test #'string-equal))))
+ (setq *patient-panel* pat-panel)
+ (when digitizer (digit-initialize digitizer))
+ (sl:process-events)
+ (setq pat (the-patient pat-panel)) ; might have been replaced
+ ;; delete all the views, since the display will be closed
+ (dolist (pl (coll:elements (plans pat)))
+ (dolist (v (coll:elements (plan-views pl)))
+ (coll:delete-element v (plan-views pl))))
+ (destroy pat-panel)
+ (sl:terminate)
+ (when digitizer (digit-close))
+ (setq *patient-panel* nil)
+ pat))
+
+;;;--------------------------------------
+
+#+allegro
+(defun prism-top-level ()
+
+ "prism-top-level is a function of no arguments, to be used as the
+top-level function in an executable that just runs Prism instead of
+the Common Lisp read-eval-print loop."
+
+ (setf (sys:gsgc-switch :print) nil)
+ (setf (sys:gsgc-switch :stats) nil)
+ (setf (sys:gsgc-switch :verbose) nil)
+
+ (prism (getenv "DISPLAY"))
+ (excl:exit))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/prism.config.example b/prism/src/prism.config.example
new file mode 100644
index 0000000..50cb343
--- /dev/null
+++ b/prism/src/prism.config.example
@@ -0,0 +1,118 @@
+;;;
+;;; prism.config
+;;;
+;;; The global variable configuration file for the University of
+;;; Washington Radiation Oncology Department.
+;;;
+;;; This file sets only those variables that are different from the
+;;; defaults in prism-globals.
+;;;
+
+(in-package :prism)
+
+;; The second entry in each pair in the *digitizer-devices*
+;; association list is simply the device file name of the serial port
+;; to which the digitizer is connected. The prism digitizer code sets
+;; the baud rate, etc.
+
+(setf *digitizer-devices*
+ '(("violin1.radonc.washington.edu" "/dev/ttyS0")
+ ("violin2.radonc.washington.edu" "/dev/ttyS0")
+ ("viola.radonc.washington.edu" "/dev/ttyS0")
+ ("cello.radonc.washington.edu" "/dev/ttyS0")
+ ("bass.radonc.washington.edu" "/dev/ttyS0")
+ ("dosim2.seattlecca.org" "/dev/ttyS0")
+ ))
+
+(setf *fine-grid-size* 0.35)
+(setf *medium-grid-size* 0.5)
+(setf *coarse-grid-size* 1.0)
+
+;;; sys:GETENV is Allegro-specific. Put alternative here for other Lisps.
+(let ((host #+:Allegro (sys:getenv "HOST") #-:Allegro ""))
+ ;;
+ (cond ((search "radonc.washington.edu" host)
+ (setf *postscript-printers* '("ps146b" "ps184" "ps136" "p790"
+ "ps143e" "ps146a" "simjet"
+ "ps136d" "File Only"))
+ (setf *plotters* '(("p790" ps-plot)
+ ("ps184" ps-plot)
+ ("ps146b" ps-plot)
+ ("ps143e" ps-plot)
+ ("ps146a" ps-plot)
+ ("simjet" ps-plot)
+ ("PS File only" ps-plot))))
+ ;;
+ ((search "seattlecca.org" host)
+ (setf *postscript-printers* '("ps146b" "ps184" "ps136" "p790"
+ "scca-bw" "scca-color"
+ "scca-ricoh" "File Only"))
+ (setf *plotters* '(("p790" ps-plot)
+ ("ps184" ps-plot)
+ ("ps146b" ps-plot)
+ ("scca-color" ps-plot)
+ ("scca-bw" ps-plot)
+ ("scca-ricoh" ps-plot)
+ ("PS File only" ps-plot))))
+ ;;
+ (t (error "Bad domain in \"prism.config\" file: ~S" host))))
+
+(setf *plot-sizes* '((small "8.5x11" 19.05 25.4)
+ (wide-small "11x8.5" 25.4 19.05)
+ (ledger "17x11" 40.64 25.4)
+ (large "11x17" 25.4 40.64)
+ (film "14x17" 33.0 40.64)
+ (wide-film "17x14" 40.64 33.0)
+ ))
+
+(setf *easel-size* large)
+
+(setf *fg-gray-level* 1.0) ;; white default foreground
+(setf *bg-gray-level* 0.0) ;; black default background
+(setf *border-style* :flat) ;; no Motif style here!
+
+(setf dicom:*dicom-ae-titles*
+ '(("bass.radonc.washington.edu" "prism-uw-bass")
+ ("bilbo.radonc.washington.edu" "prism-uw-bilbo")
+ ("cello.radonc.washington.edu" "prism-uw-cello")
+ ("eowyn.radonc.washington.edu" "prism-uw-eowyn")
+ ("flute.radonc.washington.edu" "prism-uw-flute")
+ ("gold.radonc.washington.edu" "prism-uw-gold")
+ ("imrt.radonc.washington.edu" "prism-uw-imrt")
+ ("jeeves.radonc.washington.edu" "prism-uw-jeeves")
+ ("mvi.radonc.washington.edu" "prism-uw-mvi")
+ ("ncd1.radonc.washington.edu" "prism-uw-ncd1")
+ ("silver.radonc.washington.edu" "prism-uw-silver")
+ ("viola.radonc.washington.edu" "prism-uw-viola")
+ ("violin1.radonc.washington.edu" "prism-uw-violin1")
+ ("violin2.radonc.washington.edu" "prism-uw-violin2")
+ ("woods.radonc.washington.edu" "prism-uw-woods")))
+
+;;; 19-Sep-03 Set value for minimum leaf gap, which is a constraint
+;;; on Elekta leaf settings. Used by DICOM-RT panel
+(setf *minimum-leaf-gap* 0.7)
+
+;;; Checkpoint directory for individual user.
+(setf *local-database* "~/prismlocal/")
+
+;;; Main clinical patient case files.
+(setf *patient-database* "/prismdata/clinical/cases/")
+
+;;; Clinical shared checkpoint directory
+(setf *shared-database* "/prismdata/clinical/casetemp/")
+
+;;; Clinical images.
+(setf *image-database* "/prismdata/clinical/images/")
+
+;;; Clinical structure-set files.
+(setf *structure-database* "/prismdata/clinical/structures/")
+
+(load "/radonc/prism/pstable")
+
+(load "/radonc/prism/point-calc")
+(add-tool "PointCalc" 'point-calc)
+
+#+allegro
+(setf excl:*tenured-bytes-limit* 100000000)
+
+;;; End.
diff --git a/prism/src/ptvt-expand.cl b/prism/src/ptvt-expand.cl
new file mode 100644
index 0000000..8f2112d
--- /dev/null
+++ b/prism/src/ptvt-expand.cl
@@ -0,0 +1,154 @@
+;;;
+;;; ptvt-expand
+;;;
+;;; The ptvt volume expansion panel, used to get some additional info
+;;; from the user in order to generate a target from a tumor by using
+;;; a built-in version of the Planning Taret Volume Tool.
+;;;
+;;; 27-Apr-1994 J. Unger created.
+;;; 04-May-1994 J. Unger split off linear expansion code to separate module.
+;;; 31-May-1994 J. Unger update to current spec.
+;;; 06-Jun-1994 J. Unger add some lung-specific preprocessing before target
+;;; generation (likely to be temporary - this should be handled by rules).
+;;; 8-Jul-1994 J. Unger have only tumors w/ 2 or more contours in list.
+;;; 13-Sep-2005 I. Kalet call new combined function target-volume, no
+;;; separate functions for initial and boost.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------
+
+(defparameter *ptv-offset* 10 "Distance between components of PTV editor.")
+(defparameter *ptv-button-width* 175 "Width of a button on PTV editor")
+(defparameter *ptv-button-height* 30 "Height of a button on PTV editor")
+(defparameter *ptv-scroll-width* *ptv-button-width*
+ "Width of the PTV editor scrolling lists.")
+(defparameter *ptv-small-scroll-height* (* 2 *ptv-button-height*)
+ "Height of the small PTV editor scrolling list.")
+(defparameter *ptv-large-scroll-height* (* 6 *ptv-button-height*)
+ "Height of the large PTV editor scrolling list.")
+(defparameter *ptv-width* (+ (* 3 *ptv-offset*)
+ (* 2 *ptv-scroll-width*))
+ "Width of the PTV editor")
+(defparameter *ptv-height* (+ (* 2 *ptv-offset*)
+ *ptv-button-height*
+ *ptv-large-scroll-height*)
+ "Height of the PTV editor")
+
+;;;---------------------------------------
+
+(defun make-ptv-expanded-target (immob-dev organs all-tumors)
+
+ "MAKE-PTV-EXPANDED-TARGET immob-dev organs all-tumors
+
+Returns a target instance whose contours are determined by automatic
+generation using the Planning Target Volume Tool. The patient's
+immobilization device, list of organs, and list of tumors are supplied
+to a special purpose panel. Only the tumors that have at least two
+contours are selected as candidates for target volume generation. The
+user selectes a tumor to use for target volume generation, a set of
+critical organs, and a patient outline from the panel, which runs at a
+nested event processing level."
+
+ (sl:push-event-level)
+ (let* ((frm (sl:make-frame *ptv-width* *ptv-height*
+ :title "PRISM PTV Expansion Editor"))
+ (frm-win (sl:window frm))
+ (accept-b (sl:make-exit-button
+ *ptv-scroll-width* *ptv-button-height*
+ :parent frm-win
+ :ulc-x *ptv-offset*
+ :ulc-y (+ (* 3 *ptv-offset*)
+ (* 2 *ptv-button-height*)
+ *ptv-small-scroll-height*)
+ :label "Accept"
+ :bg-color 'sl:blue))
+ (tumor-r (sl:make-readout
+ *ptv-scroll-width* *ptv-button-height*
+ :parent frm-win
+ :ulc-x *ptv-offset*
+ :ulc-y *ptv-offset*
+ :label "Sel Tumor:"
+ :border-width 0))
+ (crit-r (sl:make-readout
+ *ptv-scroll-width* *ptv-button-height*
+ :parent frm-win
+ :ulc-x (+ (* 2 *ptv-offset*) *ptv-scroll-width*)
+ :ulc-y *ptv-offset*
+ :label "Sel Crit Structs:"
+ :border-width 0))
+ (tumor-s (sl:make-radio-scrolling-list
+ *ptv-scroll-width* *ptv-small-scroll-height*
+ :parent frm-win
+ :ulc-x *ptv-offset*
+ :ulc-y (+ *ptv-offset* *ptv-button-height*)))
+ (crit-s (sl:make-scrolling-list
+ *ptv-scroll-width* *ptv-large-scroll-height*
+ :parent frm-win
+ :ulc-x (+ (* 2 *ptv-offset*) *ptv-scroll-width*)
+ :ulc-y (+ *ptv-offset* *ptv-button-height*)))
+ (tumors (remove-if #'(lambda (tum)
+ (> 2 (length (contours tum))))
+ (coll:elements all-tumors)))
+ (tumor-btns nil)
+ (crit-btns nil)
+ (tumor nil)
+ (crit-structs nil)
+ )
+ (dolist (item tumors)
+ (let ((btn (sl:make-list-button tumor-s (name item))))
+ (push btn tumor-btns)
+ (sl:insert-button btn tumor-s)))
+ (setq tumor-btns (reverse tumor-btns))
+ (sl:select-button (first tumor-btns) tumor-s)
+ (setq tumor (first tumors))
+ (dolist (item (coll:elements organs))
+ (let ((btn (sl:make-list-button crit-s (name item))))
+ (push btn crit-btns)
+ (sl:insert-button btn crit-s)))
+ (setq crit-btns (reverse crit-btns))
+ (sl:process-events)
+ (setq tumor
+ (nth (position (find-if #'sl:on tumor-btns) tumor-btns) tumors))
+ (dolist (btn crit-btns)
+ (when (sl:on btn)
+ (push (nth (position btn crit-btns) (coll:elements organs))
+ crit-structs)))
+ (sl:destroy crit-s)
+ (sl:destroy tumor-s)
+ (sl:destroy crit-r)
+ (sl:destroy tumor-r)
+ (sl:destroy accept-b)
+ (sl:destroy frm)
+ (sl:pop-event-level)
+ (sl:acknowledge
+ (append
+ (list "Will generate a target from these parameters: "
+ ""
+ (format nil "Immob dev: ~a" immob-dev)
+ ""
+ (format nil "Tumor name: ~a" (name tumor))
+ (format nil "Tumor site: ~a" (site tumor))
+ (format nil "Tumor t-stage ~a" (t-stage tumor))
+ (format nil "Tumor n-stage ~a" (n-stage tumor))
+ (format nil "Tumor cell-type ~a" (cell-type tumor))
+ (format nil "Tumor region ~a" (region tumor))
+ (format nil "Tumor side ~a" (side tumor))
+ (format nil "Tumor fixed? ~a" (fixed tumor))
+ (format nil "Tumor pulm risk: ~a" (pulm-risk tumor))
+ ""
+ "Critical structures:")
+ (mapcar #'(lambda (cs)
+ (format nil " ~a" (name cs)))
+ crit-structs)))
+ ;; the rule base expects lung cell types to be small-cell or
+ ;; non-small-cell, so change cell-type if it isn't small-cell here.
+ (when (and (equal (site tumor) 'lung)
+ (find (cell-type tumor)
+ '(adenocarcinoma large-cell squamous-cell unclassified)))
+ (setf (cell-type tumor) 'non-small-cell))
+ (target-volume tumor immob-dev crit-structs)))
+
+;;;---------------------------------------
+;;; End.
diff --git a/prism/src/quadtree.cl b/prism/src/quadtree.cl
new file mode 100644
index 0000000..ed06f43
--- /dev/null
+++ b/prism/src/quadtree.cl
@@ -0,0 +1,179 @@
+;;;
+;;; quadtree
+;;;
+;;; This module provides the quadtree representation of a two
+;;; dimensional data structure.
+;;;
+;;; 13-Jun-1998 P. Cho
+;;; 28-Mar-1999 I. Kalet cosmetic and other fixes.
+;;; 03-Feb-2000 BobGian rename NODE -> QNODE for clarity; cosmetic fixes.
+;;; Avoid two global vars by passing/returning info to/from functions.
+;;; 02-Mar-2000 BobGian rename arg in MERGE-NODES for clarity.
+;;; 02-Nov-2000 BobGian function name and argument order changes to make
+;;; consistent with new version of dose-calc used in electron code -
+;;; quadtree function now takes EFLIST and ARG-VEC and calls ENCLOSES?
+;;; explicitly rather than taking closure as enclose-testing function.
+;;; 30-May-2001 BobGian:
+;;; Wrap generic arithmetic with THE-declared types.
+;;; Move DEFSTRUCTs for QNODE and TILE to "dosecomp-decls".
+;;; 03-Jan-2003 BobGian change structures to arrays (inlined accessors
+;;; and new declarations).
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+;;; QUADTREE: generates quadtree structure by subdividing the
+;;; root node until unit node size is reached, then
+;;; merges nodes that are inside the electron field
+;;;=============================================================
+
+(defun quadtree (root current-node-size eflist arg-vec
+ &aux (dim (qnode-dimension root))
+ (dim/2 (* 0.5 dim)) (dim/4 (* 0.25 dim)))
+
+ "quadtree root current-node-size eflist arg-vec
+
+generates quadtree structure by subdividing the root node until unit node
+size is reached, then merges nodes that are inside the boundary EFLIST."
+
+ (declare (type (simple-array t (8)) root)
+ (type (simple-array single-float (#.Argv-Size)) arg-vec)
+ (type list eflist)
+ (type single-float dim dim/2 dim/4)
+ (type fixnum current-node-size))
+
+ (cond ((> current-node-size 1) ; If not leaf, divide root node by 4.
+ (setq current-node-size (ash current-node-size -1))
+
+ ;;Divide parent node by 4
+ ;;1 of Four
+ (setf (qnode-child1 root)
+ (make-qnode (+ (the single-float (qnode-xpos root)) dim/4)
+ (+ (the single-float (qnode-ypos root)) dim/4)
+ dim/2))
+ (quadtree (qnode-child1 root) current-node-size eflist arg-vec)
+
+ ;;2 of Four
+ (setf (qnode-child2 root)
+ (make-qnode (+ (the single-float (qnode-xpos root)) dim/4)
+ (- (the single-float (qnode-ypos root)) dim/4)
+ dim/2))
+ (quadtree (qnode-child2 root) current-node-size eflist arg-vec)
+
+ ;;3 of Four
+ (setf (qnode-child3 root)
+ (make-qnode (- (the single-float (qnode-xpos root)) dim/4)
+ (+ (the single-float (qnode-ypos root)) dim/4)
+ dim/2))
+ (quadtree (qnode-child3 root) current-node-size eflist arg-vec)
+
+ ;;4 of Four
+ (setf (qnode-child4 root)
+ (make-qnode (- (the single-float (qnode-xpos root)) dim/4)
+ (- (the single-float (qnode-ypos root)) dim/4)
+ dim/2))
+ (quadtree (qnode-child4 root) current-node-size eflist arg-vec)
+
+ (merge-qnodes root)) ; Merge siblings if possible
+
+ ;; Leaf node - assign status according to enclosure test.
+ (t (setf (aref arg-vec #.Argv-Enc-X) (qnode-xpos root))
+ (setf (aref arg-vec #.Argv-Enc-Y) (qnode-ypos root))
+ (setf (qnode-status root)
+ (if (encloses? eflist arg-vec)
+ :Inside :Outside)))))
+
+;;;-------------------------------------------------------------
+
+(defun count-qnodes (tree)
+
+ "count-qnodes tree
+
+Returns the number of nodes with status inside."
+
+ (if tree
+ (the fixnum
+ (+ (if (eq (qnode-status tree) :Inside) 1 0)
+ (the fixnum
+ (+ (the fixnum
+ (+ (the fixnum (count-qnodes (qnode-child1 tree)))
+ (the fixnum (count-qnodes (qnode-child2 tree)))))
+ (the fixnum
+ (+ (the fixnum (count-qnodes (qnode-child3 tree)))
+ (the fixnum (count-qnodes (qnode-child4 tree)))))))))
+ 0))
+
+;;;-------------------------------------------------------------
+
+(defun traverse-tree (root tiles nquad &aux child)
+
+ "traverse-tree root tiles nquad
+
+Traverse tree root and store information in an array tiles.
+Note: Merged nodes are represented by square tiles of different
+sizes. Tile-dimension is the half-width of the square tile.
+Returns NQUAD."
+
+ (declare (type (simple-array t (8)) root)
+ (type (simple-array t 1) tiles)
+ (type fixnum nquad))
+
+ (when (eq (qnode-status root) :Inside)
+ (setf (aref tiles nquad)
+ (make-tile (qnode-xpos root)
+ (qnode-ypos root)
+ (* 0.5 (the single-float (qnode-dimension root)))))
+ (setq nquad (the fixnum (1+ nquad))))
+
+ ;; Recurse if children exist.
+ (when (setq child (qnode-child1 root))
+ (setq nquad (traverse-tree child tiles nquad)))
+ (when (setq child (qnode-child2 root))
+ (setq nquad (traverse-tree child tiles nquad)))
+ (when (setq child (qnode-child3 root))
+ (setq nquad (traverse-tree child tiles nquad)))
+ (when (setq child (qnode-child4 root))
+ (setq nquad (traverse-tree child tiles nquad)))
+
+ nquad)
+
+;;;-------------------------------------------------------------
+
+(defun merge-qnodes (parent)
+
+ "merge-qnodes parent
+
+merge nodes that are inside the region, e.g. if all four children are
+inside, their node will be assigned inside and the children
+removed."
+
+ (cond ((and (eq (qnode-status (qnode-child1 parent)) :Inside)
+ (eq (qnode-status (qnode-child2 parent)) :Inside)
+ (eq (qnode-status (qnode-child3 parent)) :Inside)
+ (eq (qnode-status (qnode-child4 parent)) :Inside))
+ (setf (qnode-status parent) :Inside)
+ (setf (qnode-child1 parent) nil)
+ (setf (qnode-child2 parent) nil)
+ (setf (qnode-child3 parent) nil)
+ (setf (qnode-child4 parent) nil))
+
+ ;;If all four children are Outside, their parent will be
+ ;; Outside and their children are removed.
+ ((and (eq (qnode-status (qnode-child1 parent)) :Outside)
+ (eq (qnode-status (qnode-child2 parent)) :Outside)
+ (eq (qnode-status (qnode-child3 parent)) :Outside)
+ (eq (qnode-status (qnode-child4 parent)) :Outside))
+ (setf (qnode-status parent) :Outside)
+ (setf (qnode-child1 parent) nil)
+ (setf (qnode-child2 parent) nil)
+ (setf (qnode-child3 parent) nil)
+ (setf (qnode-child4 parent) nil))
+
+ ;;If the children cannot be merged, leave them alone.
+ ;; Assign their parent :Cantmerge.
+ (t (setf (qnode-status parent) :Cantmerge))))
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/replace-coll.cl b/prism/src/replace-coll.cl
new file mode 100644
index 0000000..d2e54ee
--- /dev/null
+++ b/prism/src/replace-coll.cl
@@ -0,0 +1,134 @@
+;;;
+;;; replace-coll
+;;;
+;;; contains all the methods for the generic function replace-coll
+;;;
+;;; 21-May-1997 I. Kalet move here from collimators.
+;;; 24-Jun-1997 I. Kalet add electron-coll per spec.
+;;;
+
+(in-package :prism)
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll collimator) new-coll-type)
+
+ "REPLACE-COLL old-coll new-coll-type
+
+returns a new collimator of type new-coll-type, with settings matching
+as near as possible the settings from collimator old-coll. The
+default method just creates a new collimator with default values."
+
+ (make-instance new-coll-type))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll collimator)
+ (new-coll-type (eql 'multileaf-coll)))
+
+ "When the new collimator type is multileaf, the vertices of the new
+collimator are obtained by computing the portal of the old one, the
+same for all old collimator types, including electron-coll."
+
+ (make-instance 'multileaf-coll :vertices (portal old-coll)))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll symmetric-jaw-coll)
+ (new-coll-type (eql 'variable-jaw-coll)))
+
+ (let ((hx (* 0.5 (x old-coll)))
+ (hy (* 0.5 (y old-coll))))
+ (make-instance 'variable-jaw-coll
+ :x-sup hx :x-inf hx :y-sup hy :y-inf hy)))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll symmetric-jaw-coll)
+ (new-coll-type (eql 'combination-coll)))
+
+ (let ((hx (* 0.5 (x old-coll))))
+ (make-instance 'combination-coll
+ :x-sup hx :x-inf hx :y (y old-coll))))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll variable-jaw-coll)
+ (new-coll-type (eql 'symmetric-jaw-coll)))
+
+ (make-instance 'symmetric-jaw-coll
+ :x (+ (x-sup old-coll) (x-inf old-coll))
+ :y (+ (y-sup old-coll) (y-inf old-coll))))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll variable-jaw-coll)
+ (new-coll-type (eql 'combination-coll)))
+
+ (make-instance 'combination-coll
+ :x-sup (x-sup old-coll)
+ :x-inf (x-inf old-coll)
+ :y (+ (y-sup old-coll) (y-inf old-coll))))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll combination-coll)
+ (new-coll-type (eql 'symmetric-jaw-coll)))
+
+ (make-instance 'symmetric-jaw-coll
+ :x (+ (x-sup old-coll) (x-inf old-coll))
+ :y (y old-coll)))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll combination-coll)
+ (new-coll-type (eql 'variable-jaw-coll)))
+
+ (let ((hy (* 0.5 (y old-coll))))
+ (make-instance 'variable-jaw-coll
+ :x-sup (x-sup old-coll)
+ :x-inf (x-inf old-coll)
+ :y-sup hy :y-inf hy)))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll electron-coll)
+ (new-coll-type (eql 'symmetric-jaw-coll)))
+
+ (let ((size (cone-size old-coll)))
+ (make-instance 'symmetric-jaw-coll :x size :y size)))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll electron-coll)
+ (new-coll-type (eql 'combination-coll)))
+
+ (let* ((size (cone-size old-coll))
+ (hs (* 0.5 size)))
+ (make-instance 'combination-coll
+ :x-sup hs :x-inf hs :y size)))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll electron-coll)
+ (new-coll-type (eql 'variable-jaw-coll)))
+
+ (let* ((size (* 0.5 (cone-size old-coll))))
+ (make-instance 'variable-jaw-coll
+ :x-sup size :x-inf size
+ :y-sup size :y-inf size)))
+
+;;;---------------------------------------------
+
+(defmethod replace-coll ((old-coll collimator)
+ (new-coll-type (eql 'electron-coll)))
+
+ "When the new collimator type is electron, the vertices of the new
+collimator are obtained by computing the portal of the old one, the
+same for all old collimator types. But since there is no access to
+the list of available cone sizes, the cone size is arbitrarily set to
+the default."
+
+ (make-instance 'electron-coll :vertices (portal old-coll)))
+
+;;;---------------------------------------------
diff --git a/prism/src/scan.cl b/prism/src/scan.cl
new file mode 100644
index 0000000..7e7fb5d
--- /dev/null
+++ b/prism/src/scan.cl
@@ -0,0 +1,1088 @@
+;;;
+;;; scan
+;;;
+;;; Functions which implement scanner.
+;;;
+;;; 09-Feb-1994 D. Nguyen created and adapted file from previous works.
+;;; 16-Oct-1995 D. Nguyen cleaned up code to comply with documentation.
+;;;
+
+(in-package :prism)
+
+(defvar *scan-default-max-dose* 20000)
+
+
+;;; Requires spots file loaded first.
+
+
+;;;--------------------------------------------------
+;;; STRUCTURES USED IN DOSE PSTRUCT SCANNING...
+;;;
+
+(defstruct active-edge
+ "ACTIVE-EDGE structure.
+This structure holds the information needed about an edge currently
+being scanned by the pstruct scanning routines.
+
+ending-y = the y value this edge will terminate at (int).
+delta-x = the change in x value for each single increment in y (float).
+curr-x = the current location on the x axis (float).
+
+bel 7/19/90"
+ (ending-y 0 :type integer)
+ (delta-x 0.0 :type single-float)
+ (curr-x 0.0 :type single-float))
+
+
+(defstruct scan
+ "SCAN structure
+This simple structure is used by the pstruct scanning routines to return a
+strip of points along the x axis... two integers, beginning x and the
+length of the strip are included. Not extraodinarily useful. It is
+assumed that the y and z locations are known.
+
+bel 7/19/90"
+ (min-x 0 :type integer)
+ (max-x 0 :type integer)
+ (len 0 :type integer))
+
+
+(defstruct image-slice
+ "IMAGE-SLICE structure
+This structure is used by the pstruct scanning routines to hold
+information regarding the current state of a single contour slice
+within a pstruct.
+
+max-z, min-z = the range in the z axis this slice covers.
+active-edges = a list of active-edge structures for edges.
+waiting-edges = a list of edges that have NOT yet been activated.
+
+bel 7/19/90"
+ (max-z 0 :type integer)
+ (min-z 0 :type integer)
+ active-edges
+ waiting-edges)
+
+
+(defstruct seg
+ "SEG structure
+This structure contains all of the information to id a plane in the
+3-d image space of interest. It assumes the plane is flat in the x-z
+plane."
+ (min-x 0 :type integer)
+ (max-x 0 :type integer)
+ (y 0 :type integer)
+ (z 0 :type integer))
+
+
+(defstruct (unfin-spot
+ (:print-function
+ (lambda (p s k)
+ (declare (ignore k))
+ (format s "<UNFIN-SPOT ~a>"
+ (unfin-spot-id p)))))
+
+ "UNFIN-SPOT structure.
+This is an internal structure used when building new spots in the
+scanning routines. During this time period each spot is grouped
+with the segments across its leading edge. After the spot is
+finished these segments can be thrown away. <well actually Chris says
+that she needs that information for other routines... I have tried to
+accumulate the segments in the segment accumulator slot but have been
+having trouble because they seem to end up as a linked ring with no end!
+Possibly because of using some deletes instead of removes in the code??>
+
+bel 8/22/90."
+
+ all-segs
+ prev-segs
+ curr-segs
+ peak-dose
+ all-doses
+ voxel-count
+ limit
+ min-box
+ max-box
+ id)
+
+
+;;;
+;;; MACRO ROUTINES...
+;;;
+
+(defun form-edges (conts)
+ "FORM-EDGES
+INPUTS= a list of contours.
+OUTPUTS= a list of vertex pairs of the edges in the contour.
+
+This is a function used by the pstruct scanning routines. It forms
+a list of edges (((x1 y1) (x2 y2)) ((x2 y2) (x3 y3))) from the vertices
+of the contours. The edges are sorted such that the first point is
+below the second point.
+
+bel 7/19/90"
+ (let ((verts (apply 'append
+ (mapcar #'(lambda (con) (pr:vertices con))
+ conts))))
+ (mapcar #'(lambda (v1 v2)
+ (if (< (cadr v1) (cadr v2))
+ (list v1 v2)
+ (list v2 v1)))
+ verts
+ (append (cdr verts) (list (car verts))))))
+
+
+(defmacro activate-edges (ready-edges)
+ "ACTIVATE-EDGES
+INPUTS= list of edges ready to be activated.
+OUTPUTS= list of active-edge structures.
+
+This MACRO is used by the pstruct scanners to initialize active edge
+structures. curr-x is set to the x value of the first (bottom)
+vertex of the edge; delta-x is set to the slope of the edge; and
+ending-y is set to the y value of the second vertex (upper)
+
+bel 7/19/90"
+ `(mapcan #'(lambda (edge)
+ (let ((start-point (car edge))
+ (end-point (cadr edge)))
+ (list (make-active-edge
+ :ending-y (cadr end-point)
+ :delta-x
+ (coerce (/
+ (- (car end-point) (car start-point))
+ (- (cadr end-point) (cadr start-point)))
+ 'single-float)
+ :curr-x (coerce (car start-point) 'single-float)))))
+ ,ready-edges))
+
+
+(defun get-average (nums)
+ "GET-AVERAGE
+INPUTS = a list of numbers
+OUTPUTS = the average of the numbers
+
+cms 11/91"
+ (let ((count 0)
+ (total 0))
+ (dolist (n nums)
+ (setf count (+ 1 count))
+ (setf total (+ total n)))
+ (float (/ total count))))
+
+
+(defun finish-spot (done-spot)
+ "FINISH-SPOT
+INPUTS= a finished spot structure.
+OUTPUT= a spot object.
+
+bel 8/24/90."
+
+ (make-instance 'spot
+ :peak-dose (unfin-spot-peak-dose done-spot)
+ :average-dose (get-average (unfin-spot-all-doses done-spot))
+ :limit (unfin-spot-limit done-spot)
+ :voxel-count (unfin-spot-voxel-count done-spot)
+ :center (mapcar #'half-between
+ (unfin-spot-min-box done-spot)
+ (unfin-spot-max-box done-spot))
+ :all-segs (unfin-spot-all-segs done-spot)))
+
+
+(defmacro init-unfin-spot (new-seg max-seg-dose all-doses lim)
+ "INIT-UNFIN-SPOT
+INPUTS= the new segement of out of bounds points.
+ the max out of bounds dosage.
+ the limit value the segment violated.
+OUTPUT= a unfin-spot structure properly initialized.
+
+bel 8/29/90."
+ `(make-unfin-spot
+ :peak-dose ,max-seg-dose
+ :all-doses ,all-doses
+ :voxel-count (1+ (- (seg-max-x ,new-seg)
+ (seg-min-x ,new-seg)))
+ :limit ,lim
+ :curr-segs (list ,new-seg)
+ :min-box (list
+ (seg-min-x ,new-seg)
+ (seg-y ,new-seg)
+ (seg-z ,new-seg))
+ :max-box (list
+ (seg-max-x ,new-seg)
+ (seg-y ,new-seg)
+ (seg-z ,new-seg))
+ :id (gensym "us")
+ :prev-segs nil))
+
+
+(defmacro update-spot-lists (curr-spots found-spots)
+ "UPDATE-SPOT-LISTS
+INPUTS= the name of a list of current unfin-spots.
+ the name of a list of found spots.
+OUTPUT= Updates the unfin-spots in the current list. Removes unfin-spots
+ from the current list that no longer have any segments on the leading
+ edge. Transforms those unfin-spots into spot objects and adds them to
+ the list of found-spots.
+
+This macro is intended solely for use by the scan-pstruct routine. It updates
+the lists of unfinished cold or hot spots given to it and moves those spots
+that cannot be adjacent to anything in the future (by the fact that no
+new points were found at the current y level) to the found-spots list.
+
+bel 8/29/90."
+ `(setq ,curr-spots
+ (multiple-value-bind
+ (done-spots not-done-yet)
+ (split-sequence #'null
+
+ (mapcar
+ #'(lambda (unfin-spot)
+ (setf (unfin-spot-all-segs unfin-spot)
+ (append (unfin-spot-curr-segs unfin-spot)
+ (unfin-spot-all-segs unfin-spot)))
+ (setf (unfin-spot-prev-segs unfin-spot)
+ (unfin-spot-curr-segs unfin-spot))
+ (setf (unfin-spot-curr-segs unfin-spot) nil)
+ unfin-spot)
+ ,curr-spots)
+
+ :key 'unfin-spot-prev-segs)
+ (setq ,found-spots (append ,found-spots
+ (mapcar 'finish-spot done-spots)))
+ not-done-yet)))
+
+
+(defun advance-edges (act-edges)
+ "ADVANCE-EDGES
+INPUTS= a list of active-edge structures;
+OUTPUTS= a list of active-edge structures incremented in y axis.
+
+This function is used by the pstruct scanners to advance active edges
+up the y axis. All that really happens is that delta-x is added to
+curr-x and the new list returned.
+
+bel 7/19/90"
+ (mapcar #'(lambda (edge)
+ (incf (active-edge-curr-x edge)
+ (active-edge-delta-x edge))
+ edge)
+ act-edges))
+
+
+(defmacro sort-active-edges (edges)
+ "SORT-ACTIVE-EDGES
+INPUTS= a list of active edge structures
+OUTPUT= the same list sorted by increasing current y value.
+
+bel 8/24/90."
+ `(sort ,edges #'< :key #'active-edge-curr-x))
+
+
+(defun start-slice (contours init-y min-z max-z)
+ "START-SLICE
+INPUTS= a list of contours in the current slice;
+ a starting y value;
+ min-z and max-z for depth of slice.
+OUTPUT= an image slice correctly initialized.
+
+This is an initialization routine for a the pstruct scanner. Given
+a contour and a current y value for the *PSTRUCT*, information is
+extracted from the contour to build an initial image slice. In
+particular edges are formed, those ready to be activated are
+activated and put on the active-edges list, those not ready are
+placed on the waiting-edges list. It is assumed that the starting y
+value is less-than-or-equal to any vertices in the contour.
+
+Note also that any horizontile edges are removed at this point since
+the edges at each end of the horizontile one may be used to scan
+the points along the horizontile edge.
+
+bel 7/19/90"
+ (let* ((edges
+ (remove-if #'(lambda (edge)
+ ; eliminate horizontile edges, edges at each end will
+ ; activate instead.
+ (let ((start-point (car edge))
+ (end-point (cadr edge)))
+ (= (cadr end-point) (cadr start-point))))
+ (form-edges contours))))
+
+ (multiple-value-bind
+ (ready-edges not-ready-edges)
+ (split-sequence
+ #'(lambda (y) (= y init-y))
+ edges
+ :key #'cadar)
+
+ (make-image-slice
+ :max-z max-z
+ :min-z min-z
+ :active-edges
+ (sort-active-edges
+ (activate-edges
+ ready-edges))
+ :waiting-edges not-ready-edges))))
+
+
+(defun advance-slice (slice y)
+ "ADVANCE-SLICE
+INPUT= an image-slice structure.
+OUTPUT= The image-slice is directly modified to advance it along
+the y axis. Additionally the image-slice is returned.
+
+The scanning routine advances an image slice once up the y-axis.
+Curr-y is of course incremented; all active edges are advanced;
+those that are completed are removed from the active edge list;
+new edges ready to be activated are and added to the active-edge
+list as well as removed from the waiting-edge list.
+
+The new active edge list is sorted in order to keep the edges in
+left to right order.
+
+Please see the source code for doc on handling special cases.
+
+bel 7/19/90"
+
+;A special case occures with edges that are ending, normally an
+;edge that is ending is removed as the ending y value of the edge
+;is reached. This allows the connecting edge that will start at
+;that y-value to start and be used for that y scan. However, in
+;the case of two edges which connect in a local max point, normal
+;removal of the edges would cause the scanner to ignore the final
+;scan at the top y-value (this is particularly critical if two
+;edges end with a horizontile connecting them at the top, such
+;that an long length of points would not be properly scanned).
+
+;As a result edges are removed prior to their final y when they
+;connect with a new edge. Otherwise the are allowed to remain
+;for one more y-pass to complete the scanning properly.
+ (with-accessors ((active image-slice-active-edges)
+ (waiting image-slice-waiting-edges))
+ slice
+ (multiple-value-bind
+ (ready not-ready)
+ (split-sequence
+ #'(lambda (this-y) (= this-y y))
+ waiting
+ :key #'cadar)
+
+ (setq active
+ (sort-active-edges
+ (append
+ (remove-if #'(lambda (edge)
+ (or (< (active-edge-ending-y edge) y)
+ (and (<= (active-edge-ending-y edge) y)
+ (find (round (active-edge-curr-x edge))
+ ready
+ :key #'caar))))
+ (advance-edges active))
+ (activate-edges ready))))
+ (setq waiting not-ready))
+ slice))
+
+
+(defun scan-strips (slice)
+ "SCAN-STRIPS
+INPUTS= an image slice.
+OUTPUTS= a list of scan strips along the x axis which are included inside the
+pstruct of interest.
+
+This scanning routine accepts an image slice and returns the strips
+which are between the active edges. The slice is NOT advanced.
+
+bel 7/19/90"
+ (with-accessors ((y image-slice-curr-y)
+ (max-z image-slice-max-z)
+ (min-z image-slice-min-z)
+ (active image-slice-active-edges))
+ slice
+ (flet ((scan-strip (start-edge end-edge)
+ (let ((start-x (round (active-edge-curr-x start-edge))))
+ (make-scan
+ :min-x start-x
+ :len (1+ (- (round (active-edge-curr-x end-edge))
+ start-x))
+ :max-x (round (active-edge-curr-x end-edge))))))
+ (mapcar #'scan-strip
+ active
+ (cdr active)))))
+
+
+(defun half-between (minpt maxpt)
+ "HALF-BETWEEN
+INPUTS= a first value
+ a second value such that first <= second.
+OUTPUT= the floating point value 1/2 way between the two inputs.
+
+bel 8/24/90."
+ (+ (/ (coerce (- maxpt minpt) 'single-float) 2.0) minpt))
+
+
+(defun start-all-slices (contours init-y
+ &optional (begin-z
+ (pr:z (car contours))))
+ "START-ALL-SLICES
+INPUTS= a list of contours describing a pstruct.
+ an initial y value to use for starting ready edges.
+ an optional min-z value, beginning z val of current slice.
+OUTPUTS= an initialized list of image-slice structures for the pstruct.
+
+This is the primary initialization routine for SCAN-PSTRUCT. It takes
+each contour, and builds an image slice around it. The min-z and max-z
+values are set such that they equaly divide the distance between the
+contours. The first contour has a min-z equal to its z value, the final
+contour has a max-z equal to its z value.
+
+bel 7/19/90."
+
+ (let ((this-z (pr:z (car contours)))
+ end-z)
+ (multiple-value-bind
+ (conts-at-this-z remaining-conts)
+ (split-sequence
+ #'(lambda (z)
+ (= z this-z))
+ contours
+ :key #'(lambda (cont) (pr:z cont)))
+
+ (cond
+ ((null remaining-conts)
+ (values (list (start-slice conts-at-this-z init-y begin-z this-z))))
+ (t
+ (setq end-z (floor
+ (half-between
+ this-z
+ (pr:z (car remaining-conts)))))
+
+ (values
+ (cons (start-slice conts-at-this-z init-y begin-z end-z)
+ (start-all-slices remaining-conts init-y (1+ end-z)))))))))
+
+
+(defun merge-spots (new-spot existing-spots
+ &key hot)
+ "MERGE-SPOTS
+INPUTS: an unfin-spot struc for a new spot to be merged
+ a list of unfin-spots that already exist
+OUTPUT: A list of unfin-spots with the new segment merged into it.
+
+first find any spots in the list that are adjacent to the new one.
+if there are none, return a list of all of them (new & old).
+if there are 1 or more merge them and return a list of the resulting
+spots.
+
+bel 8/20/90."
+
+ (flet ((adjacent-to-new (seg-list)
+ (some #'(lambda (test-seg)
+ (seg-overlap
+ (car (unfin-spot-curr-segs new-spot))
+ test-seg))
+ seg-list)))
+
+ (multiple-value-bind
+ (adjacent-spots all-the-rest)
+ (split-sequence #'adjacent-to-new
+ existing-spots
+ :key #'unfin-spot-prev-segs)
+
+ (let ((spots-to-merge (cons new-spot adjacent-spots)))
+
+ (setf (unfin-spot-peak-dose new-spot)
+ (cond (hot
+ (apply 'max
+ (mapcar #'unfin-spot-peak-dose spots-to-merge)))
+ (t
+ (apply 'min
+ (mapcar #'unfin-spot-peak-dose spots-to-merge)))))
+
+ (setf (unfin-spot-min-box new-spot)
+ (apply 'mapcar
+ (cons 'min
+ (mapcar #'unfin-spot-min-box spots-to-merge))))
+
+ (setf (unfin-spot-max-box new-spot)
+ (apply 'mapcar
+ (cons 'max
+ (mapcar #'unfin-spot-max-box spots-to-merge))))
+
+ (setf (unfin-spot-voxel-count new-spot)
+ (apply '+ (mapcar 'unfin-spot-voxel-count spots-to-merge)))
+
+ (setf (unfin-spot-all-doses new-spot)
+ (apply 'append (mapcar 'unfin-spot-all-doses spots-to-merge)))
+
+ (setf (unfin-spot-all-segs new-spot)
+ (apply 'append (mapcar 'unfin-spot-all-segs spots-to-merge)))
+
+ (setf (unfin-spot-curr-segs new-spot)
+ (apply 'append (mapcar 'unfin-spot-curr-segs spots-to-merge)))
+
+ (setf (unfin-spot-prev-segs new-spot)
+ (apply 'append (mapcar 'unfin-spot-prev-segs spots-to-merge)))
+
+ (values (cons new-spot all-the-rest))))))
+
+
+(defun seg-overlap (seg1 seg2)
+ "SEG-OVERLAP
+INPUTS= a segment structure.
+ a segment struct from the previous y row.
+OUTPUT= t if segments overlap.
+ nil otherwise.
+
+bel 8/15/90"
+ (if (and
+ (>= (seg-max-x seg1) (1- (seg-min-x seg2)))
+ (<= (seg-min-x seg1) (1+ (seg-max-x seg2)))
+ (>= (seg-z seg1) (1- (seg-z seg2)))
+ (<= (seg-z seg1) (1+ (seg-z seg2))))
+ t
+ nil))
+
+
+(defun split-sequence (test
+ sequence
+ &key (key nil skey))
+ "SPLIT-SEQUENCE
+INPUTS: a test function of 1 argument
+ a sequence of arguments to be tested
+ optional-- :key-- access key function.
+OUTPUT: a sequence formed as if (remove-if-not test sequence) were called.
+ a sequence formed as if (remove-if test sequence) were called.
+
+bel 8/20/90."
+
+ (let (rem-if-not rem-if)
+ (dolist (item sequence)
+ (cond
+ ((apply test (list
+ (if skey (funcall key item)
+ item)))
+ (setq rem-if-not (append rem-if-not (list item))))
+ (t
+ (setq rem-if (append rem-if (list item))))))
+ (values rem-if-not rem-if)))
+
+
+(defmacro unconvert (coordinate size dimension origin)
+ `(+ ,origin (* ,coordinate (/ ,size (- ,dimension 1)))))
+
+
+(defmacro convert (coordinate size dimension origin)
+ `(round (/ (* (- ,dimension 1) (- ,coordinate ,origin)) ,size)))
+
+
+;;;
+;;; scan
+;;; convert-pstruct-to-dosecomp-scheme
+;;; call scan-pstruct
+;;; convert-spot-from-dosecomp-scheme
+;;;
+
+(defun scan (pstruct dose-grid dose-array
+ &key (upper-lim 1000)
+ (lower-lim 0)
+ (dvh-bin-size 0)
+ (max-dose *scan-default-max-dose*))
+ (let* (new-contours
+ (x-origin (pr:x-origin dose-grid))
+ (y-origin (pr:y-origin dose-grid))
+ (z-origin (pr:z-origin dose-grid))
+ (x-dimension (pr:x-dim dose-grid))
+ (y-dimension (pr:y-dim dose-grid))
+ (z-dimension (pr:z-dim dose-grid))
+ (x-size (pr:x-size dose-grid))
+ (y-size (pr:y-size dose-grid))
+ (z-size (pr:z-size dose-grid))
+ center)
+
+ ;; convert contours from patient space to dose-grid space
+ (setf new-contours
+ (mapcar
+ #'(lambda (cont)
+ (make-instance 'pr:contour
+ :z (convert (pr:z cont) z-size z-dimension z-origin)
+ :vertices
+ (mapcar
+ #'(lambda (vertex)
+ (list (convert (first vertex) x-size x-dimension x-origin)
+ (convert (second vertex) y-size y-dimension y-origin)))
+ (pr:vertices cont))))
+ (pr:contours pstruct)))
+
+ ;; function scan-pstruct does the actual scanning work
+ (multiple-value-bind (spots dvh-array total-volume)
+ (scan-pstruct pstruct new-contours dose-array
+ :upper-lim upper-lim
+ :lower-lim lower-lim
+ :dvh-bin-size dvh-bin-size
+ :max-dose max-dose)
+
+ ;; Unconvert spots back to patient space. Ideally, everything about a
+ ;; spot does not get saved and we don't have to unconvert everything.
+
+ (dolist (spot spots)
+ (dolist (seg (all-segs spot))
+ (setf (seg-min-x seg)
+ (unconvert (seg-min-x seg) x-size x-dimension x-origin))
+ (setf (seg-max-x seg)
+ (unconvert (seg-max-x seg) x-size x-dimension x-origin))
+ (setf (seg-y seg)
+ (unconvert (seg-y seg) y-size y-dimension y-origin))
+ (setf (seg-z seg)
+ (unconvert (seg-z seg) z-size z-dimension z-origin)))
+ (setf center (slot-value spot 'center))
+ (rplaca center
+ (unconvert (first center) x-size x-dimension x-origin))
+ (rplaca (cdr center)
+ (unconvert (second center) y-size y-dimension y-origin))
+ (rplaca (cddr center)
+ (unconvert (third center) z-size z-dimension z-origin)))
+
+ (values spots dvh-array total-volume))))
+
+
+(defun scan-pstruct (pstruct contours image
+ &key (upper-lim 1000)
+ (lower-lim 0)
+ (dvh-bin-size 0)
+ (max-dose *scan-default-max-dose*))
+ "SCAN-PSTRUCT
+INPUTS= a pstruct;
+ contours, converted to dose-array indices
+ a 3-d image array, a dose-array;
+ key'd inputs...
+ :upper-lim == a max radiation limit testing for hot spots
+ :lower-lim == a min radiation limit testing for cold spots
+ :dvh-bin-size == bin size for dvh (if desired)
+ :max-dose == determines size of dvh array
+OUTPUTS= a list of spot objects, both hot and cold in a single list;
+ a dvh-array;
+ total volume of pstruct (in voxels), also equal to sum of
+ all the elements in the dvh-array.
+
+This is a complex routine that sorts the contours of pstruct into
+increasing z order, then calls START-ALL-SLICES to intialize image
+slices.
+
+The pstruct specified is then scanned through and spots are assembled
+according to the limits passed. All spots found outside either limit
+are returned as a list at the end.
+
+bel 7/19/90."
+ (flet ((null-slice (slice)
+ (and (null (image-slice-active-edges slice))
+ (null (image-slice-waiting-edges slice)))))
+ (let* ((conts
+ (sort (copy-list contours)
+ #'<
+ :key #'(lambda (cont) (pr:z cont))))
+ (init-y
+ (apply 'min (apply 'append
+ (mapcar #'(lambda (cont)
+ (mapcar #'cadr (pr:vertices cont)))
+ conts))))
+ (init-slices (start-all-slices conts init-y))
+ found-spots
+ hot-spots
+ cold-spots
+ (dvh-array-size (if (> dvh-bin-size 0)
+ (ceiling (/ (1+ max-dose) dvh-bin-size))))
+ (dvh-array (if (> dvh-bin-size 0)
+ (make-array dvh-array-size
+ :element-type 'integer
+ :initial-element 0
+ :adjustable T)))
+ (pstruct-volume 0)
+ (actual-max-dose 0))
+
+ (do ((slices init-slices
+ (remove-if #'null-slice
+ (mapcar #'(lambda (slice)
+ (advance-slice slice (1+ y)))
+ slices)))
+ (y init-y (1+ y)))
+ ((null slices)) ; do this loop until all image slices run out
+ ; of contour edges to follow.
+ (dolist (this-slice slices)
+ ;for each slice...
+ (dolist
+ (strip (remove-duplicates
+ (scan-strips this-slice)
+ :test #'(lambda (edge1 edge2)
+ (and (equal (active-edge-ending-y edge1)
+ (active-edge-ending-y edge2))
+ (equal (active-edge-curr-x edge1)
+ (active-edge-curr-x edge2))))))
+
+ ; get the scan strips between edge pairs
+ ; at the current y value in the slice.
+
+ (do ((z (image-slice-min-z this-slice) (1+ z))
+ (prev-status 0 0)
+ (new-seg () ())
+ (max-seg-dose () ())
+ (all-doses () ()))
+
+ ((> z (image-slice-max-z this-slice)))
+
+;strip is a rectangular patch, length from contour edge to contour edge,
+; depth from min z to max z. We want to scan the length of between
+; the contour edges progressively moving across the z axis.
+
+ (do ((x (scan-min-x strip) (1+ x))
+ (image-value 0))
+ ((> x (scan-max-x strip)))
+
+;here we are scanning along the length of the scan strip, progressing
+; in the x dimension. At each point in the array we just compare or
+; not the value is outside the limits of interest.
+
+;since we know the direction of scan, when we begin to see values outside
+; of the tolerance limits we mark the beginning, then wait to see where
+; it again falls within the tolerance. These one-dimensional segments
+; are represented by a 3-d beginning point and an ending x value. Also
+; maintained are max dosage beyond tolerance values. An flet routine
+; named "init-unfin-spot" below is used to initialize an unfin-spot struct
+; which is passed to merge-spots along with lists of either hot-spots
+; or cold-spots that already exist.
+
+;Merge-spot takes care of clumping these unfin-spots.
+
+;a spot is finished when there are no longer any segments found adjacent
+; to it at the current y scanning level. When a spot is finished the
+; spot object is taken from the unfin-spot structure and placed on the
+; found-spots list. Found-spots is then returned at the end of the
+; routine.
+
+ ;; make sure it's within array bounds
+ ;; (check that array-dimensions are not negative, too)
+
+ (if (and (< x (array-dimension image 0))
+ (>= x 0)
+ (< y (array-dimension image 1))
+ (>= y 0)
+ (< z (array-dimension image 2))
+ (>= z 0))
+ (setq image-value (aref image x y z))
+
+ ;; This used to set it to nil, but I want it
+ ;; to be zero, since I consider this to be
+ ;; getting no dose at all.
+ (setq image-value 0))
+
+ ;; update dvh array if desired. Also increment pstruct
+ ;; volume, and reset actual-max-dose if applicable.
+ (when dvh-array
+ (let* ((pre-index (floor (/ image-value dvh-bin-size)))
+ (index (if (< pre-index dvh-array-size)
+ pre-index
+ (1- dvh-array-size))))
+ (setf (aref dvh-array index)
+ (1+ (aref dvh-array index))))
+ (incf pstruct-volume)
+ (if (> image-value actual-max-dose)
+ (setf actual-max-dose image-value)))
+
+ (cond
+ ((null image-value) ;this point is not in the cube
+ (format t "We've hit a dimension out of bounds~%")
+ (cond
+ ;prev point was normal.
+ ((zerop prev-status) t)
+
+ ;prev point was cold.
+ ;close off existing segment
+ ((minusp prev-status)
+ (setf (seg-max-x new-seg) (1- x))
+ (setq prev-status 0
+ cold-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ lower-lim)
+ cold-spots
+ :hot nil)
+ new-seg nil ;; CMS
+ all-doses nil))
+
+ ;prev point must been hot.
+ (t
+ (setf (seg-max-x new-seg) (1- x))
+ (setq prev-status 0
+ hot-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ upper-lim)
+ hot-spots
+ :hot t)
+ new-seg nil ;;CMS
+ all-doses nil))))
+
+ ;this point cold!
+ ((< image-value lower-lim)
+ (cond
+ ;prior point was in range.
+ ;start a new segment.
+ ((zerop prev-status)
+ (setq prev-status -1
+ new-seg (make-seg :min-x x
+ :y y
+ :z z)
+ max-seg-dose image-value
+ all-doses (list image-value)))
+
+ ;prior point also cold.
+ ;just update max out of tolerance pt.
+ ((minusp prev-status)
+ (setq max-seg-dose
+ (min image-value max-seg-dose)
+ all-doses (cons image-value all-doses)))
+
+ ;prior point must have been hot.
+ ;close existing seg and start a
+ ;new one.
+ (t
+ (setf (seg-max-x new-seg) (1- x))
+ (setq hot-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ upper-lim)
+ hot-spots
+ :hot t)
+ prev-status -1
+ new-seg (make-seg :min-x x
+ :y y
+ :z z)
+ max-seg-dose image-value
+ all-doses (list image-value)))))
+
+ ;this point is hot!
+ ((> image-value upper-lim)
+ (cond
+ ;prior point was in range.
+ ;start a new segment.
+ ((zerop prev-status)
+ (setq prev-status +1
+ new-seg (make-seg :min-x x
+ :y y
+ :z z)
+ max-seg-dose image-value
+ all-doses (list image-value)))
+
+ ;prior point also hot.
+ ;just update max out of tolerance pt.
+ ((plusp prev-status)
+ (setq max-seg-dose
+ (max image-value max-seg-dose)
+ all-doses (cons image-value all-doses)))
+
+ ;prior point must have been cold.
+ ;close existing seg and start a
+ ;new one.
+ (t
+ (setf (seg-max-x new-seg) (1- x))
+ (setq cold-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ lower-lim)
+ cold-spots
+ :hot nil)
+ prev-status +1
+ new-seg (make-seg :min-x x
+ :y y
+ :z z)
+ max-seg-dose image-value
+ all-doses (list image-value)))))
+
+ (t ;this point within limits.
+ (cond
+ ;prev point was too.
+ ((zerop prev-status) t)
+
+ ;prev point was cold.
+ ;close off existing segment
+ ((minusp prev-status)
+ (setf (seg-max-x new-seg) (1- x))
+ (setq prev-status 0
+ cold-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ lower-lim)
+ cold-spots
+ :hot nil)
+ new-seg nil ;;CMS
+ all-doses nil))
+
+ ;prev point must been hot.
+ (t
+ (setf (seg-max-x new-seg) (1- x))
+ (setq prev-status 0
+ hot-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ upper-lim)
+ hot-spots
+ :hot t)
+ new-seg nil ;;CMS
+ all-doses nil))))
+ ) ; terminate cond
+ ) ; should terminate "do x..."
+
+ (cond
+ ((zerop prev-status) t)
+ ((minusp prev-status)
+ (setf (seg-max-x new-seg) (scan-max-x strip))
+ (setq cold-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ lower-lim)
+ cold-spots
+ :hot nil)
+ new-seg nil ;;CMS
+ ))
+ (t
+ (setf (seg-max-x new-seg) (scan-max-x strip))
+ (setq hot-spots (merge-spots
+ (init-unfin-spot
+ new-seg
+ max-seg-dose
+ all-doses
+ upper-lim)
+ hot-spots
+ :hot t)
+ new-seg nil ;;CMS
+ )))
+
+ ) ; should terminate "do z..."
+ ) ;should terminate "dolist seg..."
+ ) ; should terminate "dolist this-slice..."
+
+ (update-spot-lists hot-spots found-spots)
+ (update-spot-lists cold-spots found-spots)
+ )
+
+ (dolist (done-spot (append hot-spots cold-spots))
+ (push (finish-spot done-spot) found-spots))
+
+ (dolist (spot found-spots)
+ (setf (surrounding-pstruct spot) pstruct))
+
+ ;; Right now, save the segments.
+ ;; Ultimately this routine should do something smart with
+ ;; them (like find the diameter and depth, or make contours).
+ ;; (dolist (spot found-spots)
+ ;; (setf (all-segs spot) nil))
+
+ ;; Readjust dvh-array dimension to actual-max-dose.
+ ;; And reset bins to partial volumes.
+ (when dvh-array
+ (let ((actual-array-size (ceiling (/ (1+ actual-max-dose)
+ dvh-bin-size))))
+ (adjust-array dvh-array actual-array-size)
+ (do ((index 0 (1+ index)))
+ ((= index actual-array-size))
+ (setf (aref dvh-array index)
+ (/ (aref dvh-array index) pstruct-volume)))))
+
+ (values found-spots dvh-array pstruct-volume))))
+
+
+;; Assumes hot spots for organs are 5% above tolerated dose and
+;; cold spots for target are below 5% of required dose.
+;; Returns two values:
+;; - a list of all spots
+;; - a list of dvh results, where each result is of the form
+;; (target/organ dvh-array total-volume).
+
+(defun get-spots (plan patient &key (dvh-bin-size 0)
+ (max-dose *scan-default-max-dose*)
+ (beam nil))
+ (let ((dose-grid (pr:dose-grid plan))
+ (dose-array (if (null beam)
+ (pr:grid (pr:sum-dose plan))
+ (pr:grid (pr:result beam))))
+ required-dose
+ tolerance-dose
+ target
+ delta
+ all-spots
+ dvh-results)
+;; CAW @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+; (setf target (pr:prescription-used plan))
+ (setf target (first (coll:elements (targets patient))))
+ (when (eq target nil)
+ (format t "Error: there is not a target defined for ths patient.~%"))
+ (setf required-dose (if (null beam)
+ (pr:required-dose target)
+ (/ (pr:required-dose target)
+ (length (coll:elements (pr:beams plan))))))
+;(setf required-dose 1000)
+;; CAW @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+ (setf delta (* .05 required-dose))
+
+ ;; upper limit for target is a hack, because scanning code does not
+ ;; deal with infinity as an upper limit.
+ (multiple-value-bind (spots dvh-array volume)
+ (scan target dose-grid dose-array
+ :upper-lim most-positive-fixnum
+ :lower-lim (- required-dose delta)
+ :dvh-bin-size dvh-bin-size
+ :max-dose max-dose)
+ (setf all-spots (append all-spots spots))
+ (if (> dvh-bin-size 0)
+ (push (list target dvh-array volume) dvh-results)))
+
+ ;; get spots for each organ.
+ (dolist (organ (coll:elements (pr:anatomy patient)))
+ (setf tolerance-dose (if (null beam)
+ (tolerance-dose organ)
+ (/ (tolerance-dose organ)
+ (length (coll:elements (pr:beams plan))))))
+ (setf delta (* .05 tolerance-dose))
+
+ (multiple-value-bind (spots dvh-array volume)
+ (scan organ dose-grid dose-array
+ :upper-lim (+ tolerance-dose delta)
+ :lower-lim 0
+ :dvh-bin-size dvh-bin-size
+ :max-dose max-dose)
+ (setf all-spots (append all-spots spots))
+ (if (> dvh-bin-size 0)
+ (setf dvh-results (append dvh-results
+ (list (list organ dvh-array volume)))))))
+
+ ;; The following is a hack, because the scan-pstruct code can't
+ ;; deal with infinite upper-limit. Thus, since it can find hot
+ ;; spots in targets at the moment, we must get rid of them.
+ (setf all-spots (remove-if-not #'(lambda (s) (or (high-dose-region? s)
+ (low-dose-region? s)))
+ all-spots))
+ (values all-spots dvh-results)))
+
+
+(defun get-beam-spots (plan patient
+ &key (dvh-bin-size 0)
+ (max-dose *scan-default-max-dose*))
+ (mapcar #'(lambda (beam)
+ (cons beam (get-spots plan patient
+ :dvh-bin-size dvh-bin-size
+ :max-dose max-dose
+ :beam beam)))
+ (coll:elements (pr:beams plan))))
diff --git a/prism/src/selector-panels.cl b/prism/src/selector-panels.cl
new file mode 100644
index 0000000..82e3abb
--- /dev/null
+++ b/prism/src/selector-panels.cl
@@ -0,0 +1,627 @@
+;;;
+;;; selector-panels
+;;;
+;;; the Prism code for composing a scrolling-list, an Add button and a
+;;; bunch of objects, e.g. organs, into a component of a panel, e.g.
+;;; the patient panel or the plan panel.
+;;;
+;;; Requirements:
+;;;
+;;; 1. The object must have a name attribute, a text string, with an
+;;; accessor called name, and a new-name event which is announced when
+;;; the name attribute is updated (so the button text in the
+;;; scrolling-list can update too).
+;;;
+;;; 2. The panel must have a deleted event and a destroy method,
+;;; referring to symbols in the prism package.
+;;;
+;;; These are satisfied if the object class is a subclass of
+;;; generic-prism-object and the panel class is a subclass of
+;;; generic-prism-panel, defined in the prism-objects module.
+;;;
+;;; 3. The object-fn in make-selector-panel is a function that
+;;; constructs a new instance of the object class. Its only parameter
+;;; is a string for the name.
+;;;
+;;; 4. The panel-fn is a function that makes a new panel instance of
+;;; the right type for the object class. Its only parameter is the
+;;; object for which it is to be made.
+;;;
+;;; An additional keyword argument may be supplied to the constructor
+;;; function make-selector-panel, :use-color, if the object class has
+;;; a display-color attribute, whose value is a SLIK color symbol, and
+;;; an event named new-color, that announces the new color of the
+;;; object. If the use-color argument to make-selector-panel is true,
+;;; the objects mediator registers with new-color and keeps the
+;;; foreground color of the button consistent with the object color.
+;;;
+;;; 29-May-1992 I. Kalet started
+;;; 9-Jun-1992 I. Kalet add generic-panel so this file can be loaded
+;;; before the rest of the application code.
+;;; 7-Jul-1992 I. Kalet moved make-new-button to SLIK, renamed
+;;; make-list-button, change be: to ev: and behavior to event
+;;; 8-Aug-1992 I. Kalet change action function for Add button to make
+;;; and insert an object, not a button. Delete prompt-for-string.
+;;; 18-Aug-1992 I. Kalet add destroy method to reclaim X resources,
+;;; and unregister with object set. Also, add code to create buttons
+;;; for objects in initially non-empty object set (at last).
+;;; 22-Aug-1992 I. Kalet fix up generic-panel class so it can be used
+;;; by stub code.
+;;; 16-Sep-1992 I. Kalet move generic object and panel code to
+;;; prism-objects module.
+;;; 02-Jan-1993 I. Kalet make destroy method remove notification for
+;;; new-name event in all the objects. Also, remove notification for
+;;; new-name of object being deleted from object set, i.e., don't
+;;; assume the object is destroyed.
+;;; 6-Aug-1993 I. Kalet now that delete button for scrolling lists is
+;;; finally implemented, need to enable it here.
+;;; 3-Sep-1993 I. Kalet correct error discovered by Kevin Sullivan,
+;;; omitted registration and deregistration for button insertion and
+;;; deletion.
+;;; 23-Jun-1997 I. Kalet add use-color keyword parameter, add search
+;;; functions button-for and object-for, add radio keyword to make
+;;; radio-selector-panel.
+;;; 22-Mar-1999 I. Kalet add a popup-list-sort function, that can be
+;;; used to reorder the objects in the object set, and correspondingly
+;;; the buttons in the button set, without destroying or deleting the
+;;; objects, the buttons or the relationships.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 26-Nov-2000 I. Kalet cosmetics to popup-list-sort
+;;; 2-Dec-2000 I. Kalet move select-1 here from volume-editor.
+;;; 26-Dec-2001 I. Kalet change popup-list-sort to move the remaining
+;;; objects from the original list to the new list even if the user
+;;; did not move them.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------
+
+(defclass selector-panel ()
+
+ ((objects ;; :type coll:collection
+ :accessor objects
+ :initarg :objects
+ :initform (coll:make-collection) ; usually supplied as initarg
+ :documentation "The set of actual objects, e.g., organs,
+that are being selected and added and deleted.")
+
+ (panels ;; :type coll:collection
+ :accessor panels
+ :initform (coll:make-collection) ; initially, no panels
+ :documentation "The set of panels, one for each selected
+object, for editing the object's attributes.")
+
+ (scroll-list ;; :type sl:scrolling-list
+ :accessor scroll-list
+ :documentation "The SLIK scrolling-list widget
+containing the buttons for the organs.")
+
+ (objects-mediator :accessor objects-mediator
+ :documentation "A mediator to connect the object
+set and the selection list. Created by initialization of selector-panel.")
+
+ (panels-mediator :accessor panels-mediator
+ :documentation "A mediator to connect the panel set
+and the selection list. Created by initialization of selector-panel.")
+
+ (add-button ;; :type sl:button
+ :accessor add-button
+ :documentation "The SLIK button the user presses to add
+a new instance of the object.")
+
+ (selector-frame ;; :type sl:frame
+ :accessor selector-frame
+ :documentation "The SLIK frame containing the
+scrolling-list and the Add button.")
+
+ )
+
+ (:documentation "The selector-panel class provides the higher level
+machinery to provide creation, selection, deselection and deletion of
+various sets of objects that are in the Prism patient model, such as
+organs, plans, beams, views, etc.")
+
+ )
+
+;;;---------------------------------------
+
+(defclass objects-mediator ()
+
+ ((objects ;; :type coll:collection
+ :accessor objects
+ :initarg :objects
+ :documentation "A reference to the object set.")
+
+ (scroll-list ;; :type sl:scrolling-list
+ :accessor scroll-list
+ :initarg :scroll-list
+ :documentation "A reference to the scrolling list.")
+
+ (use-color :accessor use-color
+ :initarg :use-color
+ :documentation "A boolean, if true, the mediator should
+make the button fg-color track the value provided by the object's
+new-color event announcement.")
+
+ (button-object-relation ;; :type coll:relation
+ :accessor button-object-relation
+ :initform (coll:make-relation)
+ :documentation "The relation connecting the
+button set with the object set. Referenced here and in the
+panels-mediator.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "A flag for handling circularity.")
+
+ )
+
+ (:documentation "The mediator that connects the object set and the
+scrolling list button set.")
+
+ )
+
+;;;---------------------------------------
+
+(defclass panels-mediator ()
+
+ ((panels ;; :type coll:collection
+ :accessor panels
+ :initarg :panels
+ :documentation "A reference to the panel set.")
+
+ (scroll-list ;; :type sl:scrolling-list
+ :accessor scroll-list
+ :initarg :scroll-list
+ :documentation "A reference to the scrolling list.")
+
+ (button-panel-relation ;; :type coll:relation
+ :accessor button-panel-relation
+ :initform (coll:make-relation)
+ :documentation "The relation connecting the
+selected button set with the panel set.")
+
+ (button-object-relation ;; :type coll:relation
+ :accessor button-object-relation
+ :initarg :button-object-relation
+ :documentation "The relation connecting the
+button set with the object set. Referenced here as well as in the
+objects-mediator class.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "A flag for handling circularity.")
+
+ )
+
+ (:documentation "The mediator that connects the panel set and the
+scrolling list button set.")
+
+ )
+
+;;;---------------------------------------
+
+(defmethod button-for (obj (med objects-mediator))
+
+ (first (coll:projection obj (coll:inverse-relation
+ (button-object-relation med)))))
+
+;;;---------------------------------------
+
+(defmethod button-for (obj (pan selector-panel))
+
+ "button-for obj (pan selector-panel)
+
+returns the button in the selector panel pan corresponding to the
+object obj, or nil if not found."
+
+ (button-for obj (objects-mediator pan)))
+
+;;;---------------------------------------
+
+(defmethod object-for (btn (med objects-mediator))
+
+ (first (coll:projection btn (button-object-relation med))))
+
+;;;---------------------------------------
+
+(defmethod object-for (btn (med panels-mediator))
+
+ (first (coll:projection btn (button-object-relation med))))
+
+;;;---------------------------------------
+
+(defmethod object-for (btn (pan selector-panel))
+
+ "object-for btn (pan selector-panel)
+
+returns the object in the selector panel pan corresponding to the
+button btn, or nil if not found."
+
+ (object-for btn (objects-mediator pan)))
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((sp selector-panel)
+ &rest other-initargs
+ &key width height
+ object-fn panel-fn
+ use-color radio
+ &allow-other-keys)
+
+ "This method creates the panel with the scrolling list and Add
+button."
+
+ (let* ((sf (apply 'sl:make-frame width height other-initargs))
+ (win (sl:window sf))
+ (fh (sl:font-height (sl:font sf)))
+ (bh (+ fh 10)) ; this is for the Add button
+ (scr (apply (if radio 'sl:make-radio-scrolling-list
+ 'sl:make-scrolling-list)
+ width (- height bh 20) ;; leave room for Add button
+ :parent win
+ :ulc-x 0 :ulc-y (+ bh 20)
+ :enable-delete t
+ other-initargs))
+ (b (apply 'sl:make-button (- width 20) bh ; a little margin
+ :parent win
+ :button-type :momentary
+ :ulc-x 10 :ulc-y 10 ; based on margins above
+ other-initargs))) ; should contain a :label parameter
+ (setf (selector-frame sp) sf
+ (scroll-list sp) scr
+ (add-button sp) b)
+ (setf (objects-mediator sp) (make-instance 'objects-mediator
+ :objects (objects sp)
+ :scroll-list scr
+ :object-fn object-fn
+ :use-color use-color)) ;; pass through
+ (setf (panels-mediator sp) (make-instance 'panels-mediator
+ :panels (panels sp)
+ :scroll-list scr
+ :panel-fn panel-fn
+ ;; and we need a reference to the
+ ;; newly created button-object
+ ;; relation in the other mediator
+ :button-object-relation
+ (button-object-relation
+ (objects-mediator sp))))
+ (ev:add-notify sp (sl:button-on b)
+ #'(lambda (pan bt) ;; action for Add button
+ (let ((obj (funcall object-fn ""))) ; no name yet
+ (coll:insert-element obj (objects pan))
+ (sl:select-button (button-for obj pan)
+ (scroll-list pan)))
+ ;; do the following in case the button-release
+ ;; X event got discarded by the object-fn
+ (setf (sl:on bt) nil)))))
+
+;;;---------------------------------------
+
+(defun make-selector-panel (width height label object-set
+ object-fn panel-fn
+ &rest other-initargs)
+
+ "make-selector-panel width height label object-set object-fn panel-fn
+ &rest other-initargs
+
+returns an instance of a selector-panel, with objects in the provided
+object-set, and buttons for each. The :use-color and :radio
+parameters are in the other-initargs, if provided."
+
+ (apply 'make-instance 'selector-panel
+ :width width :height height
+ :objects object-set
+ :label label
+ :object-fn object-fn :panel-fn panel-fn
+ other-initargs))
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((om objects-mediator)
+ &rest initargs
+ &key object-fn &allow-other-keys)
+
+ "Sets up the initial relation between the object set and the scroll
+list."
+
+ (declare (ignore initargs))
+
+ ;; add buttons to scroll list for objects initially in object set
+ (let ((scr (scroll-list om))
+ (obj-list (coll:elements (objects om))))
+ (setf (busy om) t) ;; don't create more objects indirectly...
+ (dolist (obj obj-list)
+ (let ((b (sl:make-list-button scr (name obj))))
+ (ev:add-notify b (new-name obj)
+ #'(lambda (bt ob nm)
+ (declare (ignore ob))
+ (setf (sl:label bt) nm)))
+ (when (use-color om)
+ (setf (sl:fg-color b) (display-color obj))
+ (ev:add-notify b (new-color obj)
+ #'(lambda (bt ob col)
+ (declare (ignore ob))
+ (setf (sl:fg-color bt) col))))
+ (sl:insert-button b scr)
+ (coll:insert-element (list b obj) (button-object-relation om))))
+ (setf (busy om) nil))
+
+ ;; register with object set
+ (ev:add-notify om (coll:inserted (objects om))
+ #'(lambda (omed oset obj)
+ (declare (ignore oset))
+ (when (not (busy omed))
+ (setf (busy omed) t)
+ (let* ((scr (scroll-list omed))
+ ;; we assume there is a name reader
+ ;; function for the new object
+ (b (sl:make-list-button scr (name obj))))
+ ;; when object name changes update the
+ ;; button label in the scrolling-list
+ (ev:add-notify b (new-name obj)
+ #'(lambda (l a nm)
+ (declare (ignore a))
+ (setf (sl:label l) nm)))
+ (when (use-color omed)
+ (setf (sl:fg-color b) (display-color obj))
+ (ev:add-notify b (new-color obj)
+ #'(lambda (bt ob col)
+ (declare (ignore ob))
+ (setf (sl:fg-color bt) col))))
+ (sl:insert-button b scr)
+ (coll:insert-element (list b obj)
+ (button-object-relation omed)))
+ (setf (busy omed) nil))))
+ (ev:add-notify om (coll:deleted (objects om))
+ #'(lambda (omed oset obj)
+ (declare (ignore oset))
+ (when (not (busy omed))
+ (setf (busy omed) t)
+ (let ((b (button-for obj omed)))
+ (ev:remove-notify b (new-name obj))
+ (if (use-color omed)
+ (ev:remove-notify b (new-color obj)))
+ (sl:delete-button b (scroll-list omed))
+ (coll:delete-element (list b obj)
+ (button-object-relation omed)))
+ (setf (busy omed) nil))))
+
+ ;; register with scroll list
+ (ev:add-notify om (sl:inserted (scroll-list om))
+ #'(lambda (omed sc b)
+ (declare (ignore sc))
+ (when (not (busy omed))
+ (setf (busy omed) t)
+ (let ((obj (funcall object-fn (sl:label b))))
+ (coll:insert-element obj (objects omed))
+ ;; when object name changes update the
+ ;; button label in the scrolling-list
+ (ev:add-notify b (new-name obj)
+ #'(lambda (bt ob nm)
+ (declare (ignore ob))
+ (setf (sl:label bt) nm)))
+ (when (use-color omed)
+ (setf (sl:fg-color b) (display-color obj))
+ (ev:add-notify b (new-color obj)
+ #'(lambda (bt ob col)
+ (declare (ignore ob))
+ (setf (sl:fg-color bt) col))))
+ (coll:insert-element (list b obj)
+ (button-object-relation omed)))
+ (setf (busy omed) nil))))
+ (ev:add-notify om (sl:deleted (scroll-list om))
+ #'(lambda (omed sc b)
+ (declare (ignore sc))
+ (when (not (busy omed))
+ (setf (busy omed) t)
+ (let ((obj (object-for b omed)))
+ (ev:remove-notify b (new-name obj))
+ (if (use-color omed)
+ (ev:remove-notify b (new-color obj)))
+ (coll:delete-element obj (objects omed))
+ (coll:delete-element (list b obj)
+ (button-object-relation omed)))
+ (setf (busy omed) nil)))))
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((pm panels-mediator)
+ &rest initargs
+ &key panel-fn &allow-other-keys)
+
+ "Sets up the initial relation between the panel set and the scroll
+list."
+
+ (declare (ignore initargs))
+
+ ;; register with panel set: note that we do not register with
+ ;; (inserted (panels pm)) because this should not happen outside the
+ ;; mediator, though there is no neat way to enforce it.
+ (ev:add-notify pm (coll:deleted (panels pm))
+ #'(lambda (pm a pan)
+ (declare (ignore a))
+ (when (not (busy pm))
+ (setf (busy pm) t)
+ (let ((b (first (coll:projection
+ pan (coll:inverse-relation
+ (button-panel-relation pm))))))
+ (sl:deselect-button b (scroll-list pm))
+ (coll:delete-element (list b pan)
+ (button-panel-relation pm)))
+ (setf (busy pm) nil))))
+
+ ;; register with scroll list
+ (ev:add-notify pm (sl:selected (scroll-list pm))
+ #'(lambda (pm sc b)
+ (declare (ignore sc))
+ (when (not (busy pm))
+ (setf (busy pm) t)
+ (let* ((obj (object-for b pm))
+ (p (funcall panel-fn obj)))
+ (coll:insert-element p (panels pm))
+ (coll:insert-element (list b p)
+ (button-panel-relation pm))
+ (ev:add-notify pm (deleted p)
+ #'(lambda (pm pan)
+ (coll:delete-element
+ pan (panels pm)))))
+ (setf (busy pm) nil))))
+ (ev:add-notify pm (sl:deselected (scroll-list pm))
+ #'(lambda (pm a b)
+ (declare (ignore a))
+ (when (not (busy pm))
+ (setf (busy pm) t)
+ (let ((pan (first (coll:projection
+ b (button-panel-relation pm)))))
+ (coll:delete-element (list b pan)
+ (button-panel-relation pm))
+ (destroy pan))
+ (setf (busy pm) nil)))))
+
+;;;----------------------------------------
+
+(defmethod destroy ((sp selector-panel))
+
+ "Deselects all the buttons to remove the panels, then destroys the
+components."
+
+ (sl:destroy (add-button sp))
+ (let* ((scr (scroll-list sp))
+ (om (objects-mediator sp))
+ (objs (objects om)))
+ (mapc #'(lambda (b)
+ (sl:deselect-button b scr)
+ (let ((ob (object-for b om)))
+ (ev:remove-notify b (new-name ob))
+ (if (use-color om)
+ (ev:remove-notify b (new-color ob)))))
+ (sl:buttons scr))
+ ;; unregister from the scrolling list before destroying it
+ (ev:remove-notify om (sl:inserted scr))
+ (ev:remove-notify om (sl:deleted scr))
+ (sl:destroy scr)
+ (ev:remove-notify om (coll:inserted objs))
+ (ev:remove-notify om (coll:deleted objs)))
+ (sl:destroy (selector-frame sp)))
+
+;;;------------------------------------------
+
+(defun select-1 (sel-pan)
+
+ "a helper function that turns on the first button in the selector
+panel sel-pan and returns t if there are any, otherwise returns nil"
+
+ (let* ((scr-list (scroll-list sel-pan))
+ (btn-list (sl:buttons scr-list)))
+ (when btn-list
+ (sl:select-button (first btn-list) scr-list)
+ (return-from select-1 t))))
+
+;;;------------------------------------------
+
+(defun popup-listsort (panel)
+
+ "popup-listsort panel
+
+Provides an interactive panel for reordering the objects in the object
+set of selector-panel panel, and also reordering the corresponding
+buttons in the scrolling list of the selector-panel."
+
+ (sl:push-event-level)
+ (let* ((ppf (symbol-value *small-font*))
+ (bth 25) ;; button and textline height for small font
+ (btw 120) ;; regular button and textline width
+ (dx 10) ;; left margin
+ (top-y 10)
+ (scr-ht 210) ;; the height of the scrolling lists
+ (width (+ dx btw 10 btw 10))
+ (height (+ top-y bth 10 scr-ht 10 bth 10))
+ (sortpanel (sl:make-frame width height
+ :title "List Sort Panel"))
+ (pp-win (sl:window sortpanel))
+ (old-rdt (sl:make-readout btw bth :font ppf
+ :info "Old list"
+ :ulc-x dx :ulc-y top-y
+ :parent pp-win))
+ (new-rdt (sl:make-readout btw bth :font ppf
+ :info "New list"
+ :ulc-x (+ dx btw 10) :ulc-y top-y
+ :parent pp-win))
+ (old-scr (sl:make-scrolling-list btw scr-ht :font ppf
+ :ulc-x dx
+ :ulc-y (+ top-y bth 10)
+ :parent pp-win))
+ (new-scr (sl:make-scrolling-list btw scr-ht :font ppf
+ :ulc-x (+ dx btw 10)
+ :ulc-y (+ top-y bth 10)
+ :parent pp-win))
+ (sbw (+ 10 (clx:text-width ppf "Accept")))
+ (left-x (round (/ (- width (* 2 sbw) 10) 2)))
+ (accept-b (sl:make-exit-button sbw bth :font ppf
+ :label "Accept" :parent pp-win
+ :ulc-x left-x
+ :ulc-y (- height bth 10)
+ :bg-color 'sl:green))
+ (cancel-b (sl:make-exit-button sbw bth :font ppf
+ :label "Cancel" :parent pp-win
+ :ulc-x (+ left-x sbw 10)
+ :ulc-y (- height bth 10)))
+ (obj-set (objects panel))
+ (scr (scroll-list panel))
+ (old-oblist (copy-list (coll:elements obj-set)))
+ new-oblist)
+ (mapc #'(lambda (bm)
+ (sl:make-and-insert-list-button old-scr (name bm)))
+ old-oblist)
+ ;; when buttons are pressed, move objects and
+ ;; buttons from one list to the other.
+ (ev:add-notify old-oblist (sl:selected old-scr)
+ #'(lambda (oblist oscr bt)
+ (declare (ignore oblist))
+ (let* ((index (position bt (sl:buttons oscr)))
+ (obj (nth index old-oblist))
+ (btlabel (sl:label bt)))
+ (setf new-oblist (append new-oblist (list obj))
+ old-oblist (remove obj old-oblist))
+ (sl:delete-button bt oscr)
+ (sl:make-and-insert-list-button new-scr btlabel))))
+ (ev:add-notify new-oblist (sl:selected new-scr)
+ #'(lambda (oblist nscr bt)
+ (declare (ignore oblist))
+ (let* ((index (position bt (sl:buttons nscr)))
+ (obj (nth index new-oblist))
+ (btlabel (sl:label bt)))
+ (setf old-oblist (append old-oblist (list obj))
+ new-oblist (remove obj new-oblist))
+ (sl:delete-button bt nscr)
+ (sl:make-and-insert-list-button old-scr btlabel))))
+ (ev:add-notify obj-set (sl:button-on accept-b)
+ #'(lambda (coll btn)
+ (declare (ignore btn))
+ (let ((tmplist (append new-oblist old-oblist)))
+ ;; replace old list in coll with new list
+ ;; of same objects, and replace list of
+ ;; buttons in scrolling list with the same
+ ;; buttons in new order.
+ (progn
+ (setf (coll:elements coll) tmplist)
+ (sl:reorder-buttons
+ scr
+ (mapcar #'(lambda (ob)
+ (find (name ob) (sl:buttons scr)
+ :key #'sl:label))
+ tmplist))))))
+ (sl:process-events)
+ (sl:destroy old-rdt)
+ (sl:destroy new-rdt)
+ (sl:destroy old-scr)
+ (sl:destroy new-scr)
+ (sl:destroy accept-b)
+ (sl:destroy cancel-b)
+ (sl:destroy sortpanel))
+ (sl:pop-event-level))
+
+;;;----------------------------------------
+;;; End.
diff --git a/prism/src/spots.cl b/prism/src/spots.cl
new file mode 100644
index 0000000..8ecf8d6
--- /dev/null
+++ b/prism/src/spots.cl
@@ -0,0 +1,202 @@
+;;;
+;;; spots
+;;;
+;;; Functions which implement spot routines.
+;;;
+;;; ??-Jul-1990 B. Lockyear created file.
+;;; ??-Nov-1991 C. Sweeney added average-dose slot,
+;;; added physical-volume slot,
+;;; changed surrounding-volume to surrounding-pstruct
+;;; for clarity,
+;;; changed underbars to hyphens,
+;;; added pstruct-form slot and reader method,
+;;; added placement-info slot and placement-info
+;;; function, also placement-info structure,
+;;; fixed low and high-dose-region? to return the
+;;; right thing for organs and targets.
+;;; 09-Feb-1994 D. Nguyen adapted file for autoplan package.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+;;;
+;;; FINAL SPOT OBJECT CLASS RETURNED BY SCANNER...
+;;;
+
+(defclass spot ()
+
+ ((peak-dose :type float
+ :initarg :peak-dose
+ :accessor peak-dose)
+
+ (limit :type float
+ :initarg :limit
+ :accessor limit)
+
+ (average-dose :type float
+ :initarg :average-dose
+ :accessor average-dose)
+
+ (dist-to-target :type float
+ :accessor dist-to-target)
+
+ (physical-volume :type float
+ :accessor physical-volume)
+
+ (voxel-count :type float
+ :initarg :voxel-count
+ :accessor voxel-count)
+
+ (center :initarg :center
+ :accessor center)
+
+ (surrounding-pstruct :initarg :surrounding-pstruct
+ :accessor surrounding-pstruct)
+
+ (all-segs :initarg :all-segs
+ :accessor all-segs
+ :documentation "All segments of the spot.")
+
+ (placement-info :initarg :placement-info
+ :accessor placement-info
+ :documentation "Holds an assoc list of (beam
+placement-info).")
+
+ (pstruct-form :initarg :pstruct-form
+ :accessor pstruct-form
+ :documentation "Holds the pstruct form of the spot,
+contours and all.")))
+
+;;;
+;;; Methods
+;;;
+
+(defmethod center ((spot spot))
+
+ (let ((c (slot-value spot 'center)))
+ (values (first c) (second c) (third c))))
+
+(defmethod pstruct-form ((spot spot))
+
+ "Reader function which derives a pstruct from the segments of a spot."
+
+ (let (color curr-z next-z min-x max-x
+ curr-y next-y left-pts right-pts conts)
+ (if (slot-boundp spot 'pstruct-form)
+ (slot-value spot 'pstruct-form)
+ (setf (slot-value spot 'pstruct-form)
+ (progn
+ ;; sort segs into increasing z and within that, increasing y values
+ (setf (all-segs spot)
+ (sort (all-segs spot)
+ #'(lambda (seg1 seg2)
+ (cond ((equal (round (seg-z seg1))
+ (round (seg-z seg2)))
+ (when (< (seg-y seg1)
+ (seg-y seg2))))
+ ((< (round (seg-z seg1))
+ (round (seg-z seg2))))
+ (t nil)))))
+ ;; hot spots are red, cold spots are blue
+ (setf color (if (high-dose-region? spot)
+ 'sl:red
+ 'sl:blue))
+ ;; go thru all segments, and for each z plane, make list of
+ ;; points on the left and points on the right, which form
+ ;; left and right sides of the spot contour. Approximate by
+ ;; assuming top and bottom is flat.
+ (dolist (seg (all-segs spot))
+ ;; round off z`s to make things easier
+ (setf next-z (float (round (seg-z seg))))
+ (setf next-y (seg-y seg))
+ (cond ((equal curr-z next-z)
+ (cond ((equal curr-y next-y)
+;; *****************************************************************
+ (format t "test case curr-y = next-y~%")
+ (setf min-x (seg-min-x seg)
+ max-x (seg-max-x seg)))
+;; @@@ (pr:lo-hi-compare min-x (seg-min-x seg) max-x)
+;; @@@ (pr:lo-hi-compare min-x (seg-max-x seg) max-x))
+;; *****************************************************************
+
+ (t (setf left-pts (cons (list min-x curr-y) left-pts))
+ (setf right-pts (cons (list max-x curr-y)
+ right-pts))
+ (setf curr-y next-y
+ min-x (seg-min-x seg)
+ max-x (seg-max-x seg)))))
+ (t
+ (when curr-z
+ (setf conts
+ (cons (make-instance 'pr:contour
+ :z curr-z
+ :vertices (if (or left-pts right-pts)
+ (append left-pts
+ (reverse right-pts))
+ (list (list min-x curr-y)))
+ :display-color color)
+ conts)))
+ (setf curr-z next-z
+ curr-y (seg-y seg)
+ min-x (seg-min-x seg)
+ max-x (seg-max-x seg)
+ left-pts nil
+ right-pts nil))))
+ ;; make last contour
+ (when (and min-x max-x curr-y)
+ (setf left-pts (cons (list min-x curr-y) left-pts))
+ (setf right-pts (cons (list min-x curr-y) right-pts)))
+ (setf conts
+ (cons (make-instance 'pr:contour
+ :z curr-z
+ :vertices (append left-pts (reverse right-pts))
+ :display-color color)
+ conts))
+ (make-instance 'pr:pstruct
+ :contours conts
+ :display-color color ))))))
+
+(defmethod high-dosep ((organ pr:organ) limit peak)
+ (< limit peak))
+
+(defmethod high-dosep ((target pr:target) limit peak)
+ (declare (ignore limit peak))
+ nil) ; can't have high-dose-regions in targets
+
+(defmethod low-dosep ((target pr:target) limit peak)
+ (> limit peak))
+
+(defmethod low-dosep ((organ pr:organ) limit peak)
+ (declare (ignore limit peak))
+ nil) ; can't have low-dose-regions in organs
+
+(defun high-dose-region? (spot)
+ (high-dosep (surrounding-pstruct spot) (limit spot) (peak-dose spot)))
+
+(defun low-dose-region? (spot)
+ (low-dosep (surrounding-pstruct spot) (limit spot) (peak-dose spot)))
+
+(defmethod physical-volume ((spot spot))
+ (pr:physical-volume (pstruct-form spot)))
+
+;;;#+ignore
+;;;(defun dose-voxel-volume (plan)
+;;; (let ((dimensions (array-dimensions (slot-value plan 'dose-array)))
+;;; (lengths (slot-value plan 'dose-array-size)))
+;;; (abs (apply '* (mapcar '/ lengths dimensions)))))
+
+(defclass irradiated-region ()
+ ((surrounding-pstruct :initarg :surrounding-pstruct
+ :accessor surrounding-pstruct)
+
+ ;; holds the pstruct form of the region (contours and all)
+ (pstruct-form :initarg :pstruct-form
+ :accessor pstruct-form)
+ ))
+
+(defmethod physical-volume ((reg irradiated-region))
+ (pr:physical-volume (pstruct-form reg)))
+
+;;;-----------------------------------------------------
+;;; End.
diff --git a/prism/src/table-lookups.cl b/prism/src/table-lookups.cl
new file mode 100644
index 0000000..d844aab
--- /dev/null
+++ b/prism/src/table-lookups.cl
@@ -0,0 +1,775 @@
+;;;
+;;; table-lookups
+;;;
+;;; This module contains code related to fast table lookup using mapping
+;;; vectors (an idea first suggested by Steve Sutlief). It is generic in
+;;; that it is not specialized to a particular application in PRISM.
+;;;
+;;; 13-Mar-1998 BobGian created from code in therapy-machines and dose-info.
+;;; 22-May-1998 BobGian rearrange order of defns to improve logical flow.
+;;; 22-Jun-1998 BobGian bug-fix in BUILD-MAPPER - fencepost error in mapper
+;;; array allocation and initialization.
+;;; 26-Jun-1998 BobGian modification to macro INTERPOLATE-DELTA; reimplement
+;;; mapping-vector table-lookups to handle fencepost cases correctly;
+;;; also fix bug in 2D-LOOKUP-INT (array indices swapped).
+;;; 03-Jul-1998 BobGian fix indentation to fit within 80 cols; lowercase.
+;;; 20-Jul-1998 BobGian optimize a few more array declarations and accessors.
+;;; 03-Feb-2000 BobGian cosmetic fixes (case regularization, right margin).
+;;; 08-Feb-2000 BobGian more cosmetic cleanup.
+;;; 02-Mar-2000 BobGian case normalization in CONVERT-ARRAY.
+;;; 30-May-2001 BobGian wrap generic arithmetic with THE-declared types
+;;; and add type decls to cause inlining of ROUND function.
+;;; 27-Feb-2003 BobGian - add THE declarations for better inlining.
+;;; 15-Mar-2003 BobGian add THE decls - allows TRUNCATE to inline.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 25-Jun-2004 BobGian - add documentation to clarify array types.
+;;; 29-Jun-2004 BobGian: BUILD-MAPPER -> "therapy-machines.cl" (simplifies
+;;; dependencies).
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+;;; Macros used in Table-Lookup functions.
+
+(defmacro 2d-aref (arr idx1 idx2)
+
+ `(aref (the (simple-array single-float 1)
+ (svref (the (simple-array t 1) ,arr) (the fixnum ,idx1)))
+ (the fixnum ,idx2)))
+
+;;;-------------------------------------------------------------
+
+(defmacro 3d-aref (arr idx1 idx2 idx3)
+
+ `(aref (the (simple-array single-float 1)
+ (svref (the (simple-array t 1)
+ (svref (the (simple-array t 1) ,arr) (the fixnum ,idx1)))
+ (the fixnum ,idx2)))
+ (the fixnum ,idx3)))
+
+;;;-------------------------------------------------------------
+;;; Linear Interpolation function. Bi- or Tri-linear interpolation is done
+;;; by using this function to interpolate the outputs from interpolating on
+;;; other dimensions, as implemented in the xxx-LOOKUP functions above.
+;;; New, memory-minimalizing version.
+
+(defmacro interpolate-delta (input1 arg input2 value1 value2)
+
+ ;; Interpolates between VALUE1 and VALUE2 according to fractional distance
+ ;; ARG is between INPUT1 and INPUT2. Must have INPUT1 < INPUT2 and
+ ;; INPUT1 <= ARG.
+
+ ;; INPUT1, ARG, and INPUT2 must be compile-time SYMBOLS to avoid
+ ;; multiple evaluation. They must also be declared SINGLE-FLOAT in the
+ ;; containing form. VALUE1 and VALUE2 are always compile-time FORMS,
+ ;; but they are evaluated once only so no problem.
+
+ `(/ (+ (* (the single-float ,value2)
+ (- (the single-float ,arg)
+ (the single-float ,input1)))
+ (* (the single-float ,value1)
+ (- (the single-float ,input2)
+ (the single-float ,arg))))
+ (- (the single-float ,input2)
+ (the single-float ,input1))))
+
+;;;-------------------------------------------------------------
+;;; Slot 0 for input/output; 1,2 for mapper parameters.
+
+(defmacro 1d-lookup (mapping-vector arg1 input1 mapper1 output)
+
+ ;; MAPPING-VECTOR: Small-Float array
+ ;; ARG1: Small-Float number
+ ;; INPUT1: Small-Float array
+ ;; MAPPER1: Type-T array [fixnum contents]
+ ;; OUTPUT: Small-Float array [single-level table]
+ ;;
+ ;; Values in INPUT1 array must be monotonic increasing.
+ ;; Ditto fixnum values in MAPPER1.
+
+ `(progn
+ (setf (aref (the (simple-array single-float (3)) ,mapping-vector) 0)
+ (the single-float ,arg1))
+ (1d-lookup-int ,mapping-vector ,input1 ,mapper1 ,output)
+ (aref (the (simple-array single-float (3)) ,mapping-vector) 0)))
+
+;;;-------------------------------------------------------------
+;;; Slots 0,1 for input/output; 2,3,4,5 for mapper parameters.
+
+(defmacro 2d-lookup (mapping-vector arg1 arg2 input1 input2
+ mapper1 mapper2 output)
+
+ ;; MAPPING-VECTOR: Small-Float array
+ ;; ARG1: Small-Float number
+ ;; ARG2: Small-Float number
+ ;; INPUT1: Small-Float array
+ ;; INPUT2: Small-Float array
+ ;; MAPPER1: Type-T array [fixnum contents]
+ ;; MAPPER2: Type-T array [fixnum contents]
+ ;; OUTPUT: Type-T array [double-level table]
+ ;;
+ ;; Values in INPUT1 and INPUT2 arrays must be monotonic increasing.
+ ;; Ditto fixnum values in MAPPER1 and MAPPER2.
+
+ `(progn
+ (setf (aref (the (simple-array single-float (6)) ,mapping-vector) 0)
+ (the single-float ,arg1))
+ (setf (aref (the (simple-array single-float (6)) ,mapping-vector) 1)
+ (the single-float ,arg2))
+ (2d-lookup-int ,mapping-vector ,input1 ,input2 ,mapper1 ,mapper2 ,output)
+ (aref (the (simple-array single-float (6)) ,mapping-vector) 0)))
+
+;;;-------------------------------------------------------------
+;;; Slots 0,1,2 for input/output; 3,4,5,6,7,8 for mapper parameters.
+
+(defmacro 3d-lookup (mapping-vector arg1 arg2 arg3 input1 input2 input3
+ mapper1 mapper2 mapper3 output)
+
+ ;; MAPPING-VECTOR: Small-Float array
+ ;; ARG1: Small-Float number
+ ;; ARG2: Small-Float number
+ ;; ARG3: Small-Float number
+ ;; INPUT1: Small-Float array
+ ;; INPUT2: Small-Float array
+ ;; INPUT3: Small-Float array
+ ;; MAPPER1: Type-T array [fixnum contents]
+ ;; MAPPER2: Type-T array [fixnum contents]
+ ;; MAPPER3: Type-T array [fixnum contents]
+ ;; OUTPUT: Type-T array [triple-level table]
+ ;;
+ ;; Values in INPUT1, INPUT2, and INPUT3 arrays must be monotonic increasing.
+ ;; Ditto fixnum values in MAPPER1, MAPPER2, and MAPPER3.
+
+ `(progn
+ (setf (aref (the (simple-array single-float (9)) ,mapping-vector) 0)
+ (the single-float ,arg1))
+ (setf (aref (the (simple-array single-float (9)) ,mapping-vector) 1)
+ (the single-float ,arg2))
+ (setf (aref (the (simple-array single-float (9)) ,mapping-vector) 2)
+ (the single-float ,arg3))
+ (3d-lookup-int ,mapping-vector ,input1 ,input2 ,input3
+ ,mapper1 ,mapper2 ,mapper3 ,output)
+ (aref (the (simple-array single-float (9)) ,mapping-vector) 0)))
+
+;;;=============================================================
+;;; Functions for construction of mapping-vectors and associated tables.
+
+(defun convert-array (in-array &aux (dim1 0) (dim2 0) (dim3 0)
+ (dims (array-dimensions in-array))
+ (dimnum (length dims)))
+
+ (declare (type (simple-array t *) in-array)
+ (type fixnum dim1 dim2 dim3 dimnum))
+
+ (cond ((= dimnum 1)
+ (setq dim1 (first dims))
+ (do ((arr1 (make-array dim1 :element-type 'single-float))
+ (val 0.0)
+ (idx1 0 (the fixnum (1+ idx1))))
+ ((= idx1 dim1)
+ arr1)
+ (declare (type (simple-array single-float 1) arr1)
+ (type fixnum idx1))
+ (setq val (svref (the (simple-array t 1) in-array) idx1))
+ (unless (typep val 'single-float)
+ (error "CONVERT-ARRAY [1] Bad data in input: ~S at ~D" val idx1))
+ (setf (aref arr1 idx1) (the single-float val))))
+
+ ((= dimnum 2)
+ (setq dim1 (first dims)
+ dim2 (second dims))
+ (do ((arr1 (make-array dim1 :element-type t))
+ (val 0.0)
+ (idx1 0 (the fixnum (1+ idx1))))
+ ((= idx1 dim1)
+ arr1)
+ (declare (type (simple-array t 1) arr1)
+ (type fixnum idx1))
+ (do ((arr2 (make-array dim2 :element-type 'single-float))
+ (idx2 0 (the fixnum (1+ idx2))))
+ ((= idx2 dim2)
+ (setf (svref arr1 idx1) arr2))
+ (declare (type (simple-array single-float 1) arr2)
+ (type fixnum idx2))
+ (setq val (aref (the (simple-array t 2) in-array) idx1 idx2))
+ (unless (typep val 'single-float)
+ (error "CONVERT-ARRAY [2] Bad data in input: ~S at ~D,~D"
+ val idx1 idx2))
+ (setf (aref arr2 idx2) (the single-float val)))))
+
+ (t (setq dim1 (first dims)
+ dim2 (second dims)
+ dim3 (third dims))
+ (do ((arr1 (make-array dim1 :element-type t))
+ (val 0.0)
+ (idx1 0 (the fixnum (1+ idx1))))
+ ((= idx1 dim1)
+ arr1)
+ (declare (type (simple-array t 1) arr1)
+ (type fixnum idx1))
+ (do ((arr2 (make-array dim2 :element-type t))
+ (idx2 0 (the fixnum (1+ idx2))))
+ ((= idx2 dim2)
+ (setf (svref arr1 idx1) arr2))
+ (declare (type (simple-array t 1) arr2)
+ (type fixnum idx2))
+ (do ((arr3 (make-array dim3 :element-type 'single-float))
+ (idx3 0 (the fixnum (1+ idx3))))
+ ((= idx3 dim3)
+ (setf (svref arr2 idx2) arr3))
+ (declare (type (simple-array single-float 1) arr3)
+ (type fixnum idx3))
+ (setq val (aref (the (simple-array t 3) in-array)
+ idx1 idx2 idx3))
+ (unless (typep val 'single-float)
+ (error "CONVERT-ARRAY [3] Bad data in input: ~S at ~D,~D,~D"
+ val idx1 idx2 idx3))
+ (setf (aref arr3 idx3) (the single-float val))))))))
+
+;;;=============================================================
+;;; Fast table lookup using mapping-vectors.
+;;; Slot 0 for input/output; 1,2 for mapper parameters.
+
+(defun 1d-lookup-int (mapping-vector input1 mapper1 output
+ &aux (maxindex 0) (idx1- 0) (idx1= 0) (idx1+ 0)
+ (val1- 0.0) (val1= 0.0) (val1+ 0.0))
+
+ ;; MAPPING-VECTOR: Small-Float array
+ ;; INPUT1: Small-Float array
+ ;; MAPPER1: Type-T array [fixnum contents]
+ ;; OUTPUT: Small-Float array [single-level table]
+ ;;
+ ;; Values in INPUT1 array must be monotonic increasing.
+ ;; Ditto fixnum values in MAPPER1.
+
+ (declare (type (simple-array single-float 1) input1 output)
+ (type (simple-array single-float (3)) mapping-vector)
+ (type (simple-array t 1) mapper1)
+ (type single-float val1- val1= val1+)
+ (type fixnum maxindex idx1- idx1= idx1+))
+
+ (let ((arg1 (aref mapping-vector 0)))
+ (declare (type single-float arg1))
+ (setf (aref mapping-vector 0)
+ (cond
+ ((<= arg1 (the single-float (aref input1 0)))
+ (aref output 0))
+
+ ((>= arg1
+ (the single-float
+ (aref input1
+ (setq maxindex
+ (the fixnum (1- (array-total-size input1)))))))
+ (aref output maxindex))
+
+ (t (setq idx1=
+ (svref mapper1
+ (the fixnum
+ (round (the single-float
+ (* (the single-float
+ (aref mapping-vector 1))
+ (- arg1
+ (the single-float
+ (aref mapping-vector 2)))))))))
+
+ (cond ((= idx1= 0)
+ (setq idx1- 0
+ idx1+ 1
+ val1- (aref input1 0)
+ val1+ (aref input1 1)))
+
+ ((= idx1= maxindex)
+ (setq idx1- (the fixnum (1- maxindex))
+ idx1+ maxindex
+ val1- (aref input1 idx1-)
+ val1+ (aref input1 idx1+)))
+
+ (t (setq idx1- (the fixnum (1- idx1=))
+ idx1+ (the fixnum (1+ idx1=))
+ val1- (aref input1 idx1-)
+ val1= (aref input1 idx1=)
+ val1+ (aref input1 idx1+))
+ (cond ((< arg1 val1-)
+ (error "1D-LOOKUP-INT [1]"))
+ ((= arg1 val1-)
+ (setq idx1+ idx1-))
+ ((< arg1 val1=)
+ (setq idx1+ idx1=
+ val1+ val1=))
+ ((= arg1 val1=)
+ (setq idx1- (setq idx1+ idx1=)))
+ ((< arg1 val1+)
+ (setq idx1- idx1=
+ val1- val1=))
+ ((= arg1 val1+)
+ (setq idx1- idx1+))
+ (t (error "1D-LOOKUP-INT [2]")))))
+
+ (cond ((= idx1- idx1+)
+ (aref output idx1-))
+ (t (interpolate-delta val1- arg1 val1+
+ (aref output idx1-)
+ (aref output idx1+))))))))
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; Slots 0,1 for input/output; 2,3,4,5 for mapper parameters.
+
+(defun 2d-lookup-int (mapping-vector input1 input2 mapper1 mapper2 output
+ &aux (maxindex 0) (idx1- 0) (idx1= 0) (idx1+ 0)
+ (idx2- 0) (idx2= 0) (idx2+ 0) (val1- 0.0) (val1= 0.0)
+ (val1+ 0.0) (val2- 0.0) (val2= 0.0) (val2+ 0.0))
+
+ ;; MAPPING-VECTOR: Small-Float array
+ ;; INPUT1: Small-Float array
+ ;; INPUT2: Small-Float array
+ ;; MAPPER1: Type-T array [fixnum contents]
+ ;; MAPPER2: Type-T array [fixnum contents]
+ ;; OUTPUT: Type-T array [double-level table]
+ ;;
+ ;; Values in INPUT1 and INPUT2 arrays must be monotonic increasing.
+ ;; Ditto fixnum values in MAPPER1 and MAPPER2.
+
+ (declare (type (simple-array single-float 1) input1 input2)
+ (type (simple-array single-float (6)) mapping-vector)
+ (type (simple-array t 1) mapper1 mapper2 output)
+ (type single-float val1- val1= val1+ val2- val2= val2+)
+ (type fixnum maxindex idx1- idx1= idx1+ idx2- idx2= idx2+))
+
+ (let ((arg1 (aref mapping-vector 0))
+ (arg2 (aref mapping-vector 1)))
+ (declare (type single-float arg1 arg2))
+
+ (cond
+ ((<= arg1 (the single-float (aref input1 0)))
+ (setq idx1- (setq idx1+ 0)))
+
+ ((>= arg1
+ (the single-float
+ (aref input1
+ (setq maxindex
+ (the fixnum (1- (array-total-size input1)))))))
+ (setq idx1- (setq idx1+ maxindex)))
+
+ (t (setq idx1= (svref mapper1
+ (the fixnum
+ (round (the single-float
+ (* (the single-float
+ (aref mapping-vector 2))
+ (- arg1
+ (the single-float
+ (aref mapping-vector 4)))))))))
+
+ (cond ((= idx1= 0)
+ (setq idx1- 0
+ idx1+ 1
+ val1- (aref input1 0)
+ val1+ (aref input1 1)))
+
+ ((= idx1= maxindex)
+ (setq idx1- (the fixnum (1- maxindex))
+ idx1+ maxindex
+ val1- (aref input1 idx1-)
+ val1+ (aref input1 idx1+)))
+
+ (t (setq idx1- (the fixnum (1- idx1=))
+ idx1+ (the fixnum (1+ idx1=))
+ val1- (aref input1 idx1-)
+ val1= (aref input1 idx1=)
+ val1+ (aref input1 idx1+))
+ (cond ((< arg1 val1-)
+ (error "2D-LOOKUP-INT [1]"))
+ ((= arg1 val1-)
+ (setq idx1+ idx1-))
+ ((< arg1 val1=)
+ (setq idx1+ idx1=
+ val1+ val1=))
+ ((= arg1 val1=)
+ (setq idx1- (setq idx1+ idx1=)))
+ ((< arg1 val1+)
+ (setq idx1- idx1=
+ val1- val1=))
+ ((= arg1 val1+)
+ (setq idx1- idx1+))
+ (t (error "2D-LOOKUP-INT [2]")))))))
+
+ (cond
+ ((<= arg2 (the single-float (aref input2 0)))
+ (setq idx2- (setq idx2+ 0)))
+
+ ((>= arg2
+ (the single-float
+ (aref input2
+ (setq maxindex
+ (the fixnum (1- (array-total-size input2)))))))
+ (setq idx2- (setq idx2+ maxindex)))
+
+ (t (setq idx2= (svref mapper2
+ (the fixnum
+ (round (the single-float
+ (* (the single-float
+ (aref mapping-vector 3))
+ (- arg2
+ (the single-float
+ (aref mapping-vector 5)))))))))
+
+ (cond ((= idx2= 0)
+ (setq idx2- 0
+ idx2+ 1
+ val2- (aref input2 0)
+ val2+ (aref input2 1)))
+
+ ((= idx2= maxindex)
+ (setq idx2- (the fixnum (1- maxindex))
+ idx2+ maxindex
+ val2- (aref input2 idx2-)
+ val2+ (aref input2 idx2+)))
+
+ (t (setq idx2- (the fixnum (1- idx2=))
+ idx2+ (the fixnum (1+ idx2=))
+ val2- (aref input2 idx2-)
+ val2= (aref input2 idx2=)
+ val2+ (aref input2 idx2+))
+ (cond ((< arg2 val2-)
+ (error "2D-LOOKUP-INT [3]"))
+ ((= arg2 val2-)
+ (setq idx2+ idx2-))
+ ((< arg2 val2=)
+ (setq idx2+ idx2=
+ val2+ val2=))
+ ((= arg2 val2=)
+ (setq idx2- (setq idx2+ idx2=)))
+ ((< arg2 val2+)
+ (setq idx2- idx2=
+ val2- val2=))
+ ((= arg2 val2+)
+ (setq idx2- idx2+))
+ (t (error "2D-LOOKUP-INT [4]")))))))
+
+ (setf (aref mapping-vector 0)
+ (cond
+ ((and (= idx1- idx1+) (= idx2- idx2+))
+ (2d-aref output idx1+ idx2+))
+
+ ((= idx1- idx1+)
+ (let ((plane1 (svref output idx1+)))
+ (declare (type (simple-array single-float 1) plane1))
+ (interpolate-delta val2- arg2 val2+
+ (aref plane1 idx2-)
+ (aref plane1 idx2+))))
+
+ ((= idx2- idx2+)
+ (interpolate-delta val1- arg1 val1+
+ (2d-aref output idx1- idx2+)
+ (2d-aref output idx1+ idx2+)))
+
+ (t (let ((plane1- (svref output idx1-))
+ (plane1+ (svref output idx1+)))
+ (declare (type (simple-array single-float 1) plane1- plane1+))
+ (interpolate-delta
+ val2- arg2 val2+
+ (interpolate-delta val1- arg1 val1+
+ (aref plane1- idx2-)
+ (aref plane1+ idx2-))
+ (interpolate-delta val1- arg1 val1+
+ (aref plane1- idx2+)
+ (aref plane1+ idx2+))))))))
+
+ nil)
+
+;;;-------------------------------------------------------------
+;;; Slots 0,1,2 for input/output; 3,4,5,6,7,8 for mapper parameters.
+
+(defun 3d-lookup-int (mapping-vector input1 input2 input3 mapper1 mapper2
+ mapper3 output &aux (maxindex 0) (idx1- 0) (idx1= 0)
+ (idx1+ 0) (idx2- 0) (idx2= 0) (idx2+ 0) (idx3- 0)
+ (idx3= 0) (idx3+ 0) (val1- 0.0) (val1= 0.0) (val1+ 0.0)
+ (val2- 0.0) (val2= 0.0) (val2+ 0.0) (val3- 0.0)
+ (val3= 0.0) (val3+ 0.0))
+
+ ;; MAPPING-VECTOR: Small-Float array
+ ;; INPUT1: Small-Float array
+ ;; INPUT2: Small-Float array
+ ;; INPUT3: Small-Float array
+ ;; MAPPER1: Type-T array [fixnum contents]
+ ;; MAPPER2: Type-T array [fixnum contents]
+ ;; MAPPER3: Type-T array [fixnum contents]
+ ;; OUTPUT: Type-T array [triple-level table]
+ ;;
+ ;; Values in INPUT1, INPUT2, and INPUT3 arrays must be monotonic increasing.
+ ;; Ditto fixnum values in MAPPER1, MAPPER2, and MAPPER3.
+
+ (declare (type (simple-array single-float 1) input1 input2 input3)
+ (type (simple-array single-float (9)) mapping-vector)
+ (type (simple-array t 1) mapper1 mapper2 mapper3 output)
+ (type single-float val1- val1= val1+ val2- val2= val2+
+ val3- val3= val3+)
+ (type fixnum maxindex idx1- idx1= idx1+ idx2- idx2= idx2+
+ idx3- idx3= idx3+))
+
+ (let ((arg1 (aref mapping-vector 0))
+ (arg2 (aref mapping-vector 1))
+ (arg3 (aref mapping-vector 2)))
+ (declare (type single-float arg1 arg2 arg3))
+
+ (cond
+ ((<= arg1 (the single-float (aref input1 0)))
+ (setq idx1- (setq idx1+ 0)))
+
+ ((>= arg1
+ (the single-float
+ (aref input1
+ (setq maxindex
+ (the fixnum (1- (array-total-size input1)))))))
+ (setq idx1- (setq idx1+ maxindex)))
+
+ (t (setq idx1= (svref mapper1
+ (the fixnum
+ (round (the single-float
+ (* (the single-float
+ (aref mapping-vector 3))
+ (- arg1
+ (the single-float
+ (aref mapping-vector 6)))))))))
+
+ (cond ((= idx1= 0)
+ (setq idx1- 0
+ idx1+ 1
+ val1- (aref input1 0)
+ val1+ (aref input1 1)))
+ ;;
+ ((= idx1= maxindex)
+ (setq idx1- (the fixnum (1- maxindex))
+ idx1+ maxindex
+ val1- (aref input1 idx1-)
+ val1+ (aref input1 idx1+)))
+ ;;
+ (t (setq idx1- (the fixnum (1- idx1=))
+ idx1+ (the fixnum (1+ idx1=))
+ val1- (aref input1 idx1-)
+ val1= (aref input1 idx1=)
+ val1+ (aref input1 idx1+))
+ (cond ((< arg1 val1-)
+ (error "3D-LOOKUP-INT [1]"))
+ ((= arg1 val1-)
+ (setq idx1+ idx1-))
+ ((< arg1 val1=)
+ (setq idx1+ idx1=
+ val1+ val1=))
+ ((= arg1 val1=)
+ (setq idx1- (setq idx1+ idx1=)))
+ ((< arg1 val1+)
+ (setq idx1- idx1=
+ val1- val1=))
+ ((= arg1 val1+)
+ (setq idx1- idx1+))
+ (t (error "3D-LOOKUP-INT [2]")))))))
+
+ (cond
+ ((<= arg2 (the single-float (aref input2 0)))
+ (setq idx2- (setq idx2+ 0)))
+
+ ((>= arg2
+ (the single-float
+ (aref input2
+ (setq maxindex (the fixnum
+ (1- (array-total-size input2)))))))
+ (setq idx2- (setq idx2+ maxindex)))
+
+ (t (setq idx2= (svref mapper2
+ (the fixnum
+ (round (the single-float
+ (* (the single-float
+ (aref mapping-vector 4))
+ (- arg2
+ (the single-float
+ (aref mapping-vector 7)))))))))
+
+ (cond ((= idx2= 0)
+ (setq idx2- 0
+ idx2+ 1
+ val2- (aref input2 0)
+ val2+ (aref input2 1)))
+
+ ((= idx2= maxindex)
+ (setq idx2- (the fixnum (1- maxindex))
+ idx2+ maxindex
+ val2- (aref input2 idx2-)
+ val2+ (aref input2 idx2+)))
+
+ (t (setq idx2- (the fixnum (1- idx2=))
+ idx2+ (the fixnum (1+ idx2=))
+ val2- (aref input2 idx2-)
+ val2= (aref input2 idx2=)
+ val2+ (aref input2 idx2+))
+ (cond ((< arg2 val2-)
+ (error "3D-LOOKUP-INT [3]"))
+ ((= arg2 val2-)
+ (setq idx2+ idx2-))
+ ((< arg2 val2=)
+ (setq idx2+ idx2=
+ val2+ val2=))
+ ((= arg2 val2=)
+ (setq idx2- (setq idx2+ idx2=)))
+ ((< arg2 val2+)
+ (setq idx2- idx2=
+ val2- val2=))
+ ((= arg2 val2+)
+ (setq idx2- idx2+))
+ (t (error "3D-LOOKUP-INT [4]")))))))
+
+ (cond
+ ((<= arg3 (the single-float (aref input3 0)))
+ (setq idx3- (setq idx3+ 0)))
+
+ ((>= arg3
+ (the single-float
+ (aref input3
+ (setq maxindex (the fixnum
+ (1- (array-total-size input3)))))))
+ (setq idx3- (setq idx3+ maxindex)))
+
+ (t (setq idx3= (svref mapper3
+ (the fixnum
+ (round (the single-float
+ (* (the single-float
+ (aref mapping-vector 5))
+ (- arg3
+ (the single-float
+ (aref mapping-vector 8)))))))))
+
+ (cond ((= idx3= 0)
+ (setq idx3- 0
+ idx3+ 1
+ val3- (aref input3 0)
+ val3+ (aref input3 1)))
+
+ ((= idx3= maxindex)
+ (setq idx3- (the fixnum (1- maxindex))
+ idx3+ maxindex
+ val3- (aref input3 idx3-)
+ val3+ (aref input3 idx3+)))
+
+ (t (setq idx3- (the fixnum (1- idx3=))
+ idx3+ (the fixnum (1+ idx3=))
+ val3- (aref input3 idx3-)
+ val3= (aref input3 idx3=)
+ val3+ (aref input3 idx3+))
+ (cond ((< arg3 val3-)
+ (error "3D-LOOKUP-INT [5]"))
+ ((= arg3 val3-)
+ (setq idx3+ idx3-))
+ ((< arg3 val3=)
+ (setq idx3+ idx3=
+ val3+ val3=))
+ ((= arg3 val3=)
+ (setq idx3- (setq idx3+ idx3=)))
+ ((< arg3 val3+)
+ (setq idx3- idx3=
+ val3- val3=))
+ ((= arg3 val3+)
+ (setq idx3- idx3+))
+ (t (error "3D-LOOKUP-INT [6]")))))))
+
+ (setf (aref mapping-vector 0)
+ (cond
+ ((and (= idx1- idx1+) (= idx2- idx2+) (= idx3- idx3+))
+ (3d-aref output idx1+ idx2+ idx3+))
+
+ ((and (= idx2- idx2+) (= idx3- idx3+))
+ (interpolate-delta val1- arg1 val1+
+ (3d-aref output idx1- idx2+ idx3+)
+ (3d-aref output idx1+ idx2+ idx3+)))
+
+ ((and (= idx1- idx1+) (= idx3- idx3+))
+ (let ((plane1 (svref output idx1+)))
+ (declare (type (simple-array t 1) plane1))
+ (interpolate-delta val2- arg2 val2+
+ (2d-aref plane1 idx2- idx3+)
+ (2d-aref plane1 idx2+ idx3+))))
+
+ ((and (= idx1- idx1+) (= idx2- idx2+))
+ (let ((plane2 (svref (the (simple-array t 1) (svref output idx1+))
+ idx2+)))
+ (declare (type (simple-array single-float 1) plane2))
+ (interpolate-delta val3- arg3 val3+
+ (aref plane2 idx3-)
+ (aref plane2 idx3+))))
+
+ ((= idx1- idx1+)
+ (let* ((plane1 (svref output idx1+))
+ (plane2- (svref plane1 idx2-))
+ (plane2+ (svref plane1 idx2+)))
+ (declare (type (simple-array t 1) plane1)
+ (type (simple-array single-float 1) plane2- plane2+))
+ (interpolate-delta val3- arg3 val3+
+ (interpolate-delta val2- arg2 val2+
+ (aref plane2- idx3-)
+ (aref plane2+ idx3-))
+ (interpolate-delta val2- arg2 val2+
+ (aref plane2- idx3+)
+ (aref plane2+ idx3+)))))
+
+ ((= idx2- idx2+)
+ (let ((plane2-
+ (svref (the (simple-array t 1) (svref output idx1-))
+ idx2+))
+ (plane2+
+ (svref (the (simple-array t 1) (svref output idx1+))
+ idx2+)))
+ (declare (type (simple-array single-float 1) plane2- plane2+))
+ (interpolate-delta val3- arg3 val3+
+ (interpolate-delta val1- arg1 val1+
+ (aref plane2- idx3-)
+ (aref plane2+ idx3-))
+ (interpolate-delta val1- arg1 val1+
+ (aref plane2- idx3+)
+ (aref plane2+ idx3+)))))
+
+ ((= idx3- idx3+)
+ (let ((plane1- (svref output idx1-))
+ (plane1+ (svref output idx1+)))
+ (declare (type (simple-array t 1) plane1- plane1+))
+ (interpolate-delta
+ val2- arg2 val2+
+ (interpolate-delta val1- arg1 val1+
+ (2d-aref plane1- idx2- idx3+)
+ (2d-aref plane1+ idx2- idx3+))
+ (interpolate-delta val1- arg1 val1+
+ (2d-aref plane1- idx2+ idx3+)
+ (2d-aref plane1+ idx2+ idx3+)))))
+
+ (t (let ((plane1- (svref output idx1-))
+ (plane1+ (svref output idx1+)))
+ (declare (type (simple-array t 1) plane1- plane1+))
+ (let ((plane2-- (svref plane1- idx2-))
+ (plane2-+ (svref plane1- idx2+))
+ (plane2+- (svref plane1+ idx2-))
+ (plane2++ (svref plane1+ idx2+)))
+ (declare (type (simple-array single-float 1)
+ plane2-- plane2-+ plane2+- plane2++))
+ (interpolate-delta
+ val3- arg3 val3+
+ (interpolate-delta
+ val2- arg2 val2+
+ (interpolate-delta val1- arg1 val1+
+ (aref plane2-- idx3-)
+ (aref plane2+- idx3-))
+ (interpolate-delta val1- arg1 val1+
+ (aref plane2-+ idx3-)
+ (aref plane2++ idx3-)))
+ (interpolate-delta
+ val2- arg2 val2+
+ (interpolate-delta val1- arg1 val1+
+ (aref plane2-- idx3+)
+ (aref plane2+- idx3+))
+ (interpolate-delta val1- arg1 val1+
+ (aref plane2-+ idx3+)
+ (aref plane2++ idx3+))))))))))
+
+ nil)
+
+;;;=============================================================
+;;; End.
diff --git a/prism/src/tape-measure.cl b/prism/src/tape-measure.cl
new file mode 100644
index 0000000..d923016
--- /dev/null
+++ b/prism/src/tape-measure.cl
@@ -0,0 +1,313 @@
+;;;
+;;; tape-measure
+;;;
+;;; A tape measure can appear in a view and manipulated by the user.
+;;; It has a length, can be stretched and contracted, and moved.
+;;;
+;;; 1-Feb-1994 I. Kalet split off from old contour editor code and
+;;; reorganized as an independent entity.
+;;; 28-Feb-1994 I. Kalet continue filling in details
+;;; 06-Jun-1994 J. Unger work on implementation; make usable by either a
+;;; planar editor or a view.
+;;; 16-Jun-1994 J. Unger finish implementation.
+;;; 24-Jun-1994 I. Kalet really finish implementation.
+;;; 11-Jul-1994 J. Unger finish up impl, but this is a temporary impl,
+;;; since there are still some design decisions to be made.
+;;; 10-May-1997 I. Kalet use new global *ruler-color* for initial
+;;; color of the tape measure. Redesign to eliminate dependency on
+;;; planar editor or other "owner".
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;;
+
+(in-package :prism)
+
+;;;-----------------------------------
+
+(defparameter *tape-disk-radius* 3 "The radius of the grab disk on
+either end of the tape measure, in pixels.")
+
+(defparameter *tape-tic-length* 6 "The length of each tic on the tape
+measure, in pixels.")
+
+;;;-----------------------------------
+
+(defclass tape-measure ()
+
+ ((picture :accessor picture
+ :initarg :picture
+ :documentation "The picture in which this tape measure is
+drawn. Must be provided as an initialization argument.")
+
+ (scale :type single-float
+ :accessor scale
+ :initarg :scale
+ :documentation "The pixels per cm from model space to
+picture space.")
+
+ (origin :type list
+ :accessor origin
+ :initarg :origin
+ :documentation "A two element list, the x and y pixel
+coordinates of the origin of model space on the picture.")
+
+ (x1 :type single-float
+ :accessor x1
+ :initarg :x1
+ :documentation "End 1 x coordinate in model space, e.g. cm.")
+
+ (y1 :type single-float
+ :accessor y1
+ :initarg :y1
+ :documentation "End 1 y coordinate in model space, e.g. cm.")
+
+ (x2 :type single-float
+ :accessor x2
+ :initarg :x2
+ :documentation "End 2 x coordinate in model space, e.g. cm.")
+
+ (y2 :type single-float
+ :accessor y2
+ :initarg :y2
+ :documentation "End 2 y coordinate in model space, e.g. cm.")
+
+ (spine ;; :type sl:segment
+ :accessor spine
+ :documentation "The spine of the ruler, a pickable object.")
+
+ (end1 ;; :type sl:circle
+ :accessor end1
+ :documentation "One end of the ruler, a pickable object.")
+
+ (end2 ;; :type sl:circle
+ :accessor end2
+ :documentation "The other end of the ruler, a pickable object.")
+
+ (new-length :type ev:event
+ :accessor new-length
+ :initform (ev:make-event)
+ :documentation "Announced when the tape measure's
+length changes.")
+
+ (refresh :type ev:event
+ :accessor refresh
+ :initform (ev:make-event)
+ :documentation "Announced when the tape measure changes
+and the picture should be redrawn.")
+
+ (deleted :type ev:event
+ :accessor deleted
+ :initform (ev:make-event)
+ :documentation "Announced when the tape measure has
+received a button 2 input on its spine, signalling to delete it.")
+
+ )
+
+ (:documentation "A tape measure can appear in a view or planar editor,
+and can be stretched and contracted by the user. If its length
+changes it announces new-length.")
+
+ )
+
+;;;-----------------------------------
+
+(defun make-tape-measure (&rest initargs)
+
+ (apply #'make-instance 'tape-measure initargs))
+
+;;;-----------------------------------
+
+(defun draw-tape-measure-tics (tpm)
+
+ "draw-tape-measure-tics tpm
+
+Draws tape measure tpm into its owner's picture."
+
+ (clx:draw-segments (sl:pixmap (picture tpm))
+ (sl:color (spine tpm))
+ (compute-tics (x1 tpm) (y1 tpm)
+ (x2 tpm) (y2 tpm)
+ (scale tpm)
+ (first (origin tpm))
+ (second (origin tpm))
+ *tape-tic-length*)))
+
+;;;-----------------------------------
+
+(defun tape-length (tape)
+
+ "tape-length tape
+
+returns the length of the tape measure."
+
+ (distance (x1 tape) (y1 tape) (x2 tape) (y2 tape)))
+
+;;;-----------------------------------
+
+(defun rescale-tape (tape)
+
+ "rescale-tape tape
+
+Resets the coordinates of the tape's spine and endpoints, based upon
+the current origin and scale of the tape's owner."
+
+ (let* ((sp (spine tape))
+ (e1 (end1 tape))
+ (e2 (end2 tape))
+ (x-orig (first (origin tape)))
+ (y-orig (second (origin tape)))
+ (scl (scale tape))
+ (x1-pix (pix-x (x1 tape) x-orig scl))
+ (y1-pix (pix-y (y1 tape) y-orig scl))
+ (x2-pix (pix-x (x2 tape) x-orig scl))
+ (y2-pix (pix-y (y2 tape) y-orig scl)))
+ (setf (sl:x1 sp) x1-pix (sl:y1 sp) y1-pix
+ (sl:x2 sp) x2-pix (sl:y2 sp) y2-pix
+ (sl:x-center e1) x1-pix (sl:y-center e1) y1-pix
+ (sl:x-center e2) x2-pix (sl:y-center e2) y2-pix)))
+
+;;;-----------------------------------
+
+(defmethod (setf scale) :after (new-scale (tp tape-measure))
+
+ "Updates the model space coordinates of the tape measure, since its
+pixel space coordinates don't change."
+
+ (let ((sp (spine tp))
+ (x-orig (first (origin tp)))
+ (y-orig (second (origin tp))))
+ (setf (x1 tp) (cm-x (sl:x1 sp) x-orig new-scale)
+ (y1 tp) (cm-y (sl:y1 sp) y-orig new-scale)
+ (x2 tp) (cm-x (sl:x2 sp) x-orig new-scale)
+ (y2 tp) (cm-y (sl:y2 sp) y-orig new-scale))
+ (ev:announce tp (new-length tp) (tape-length tp))))
+
+;;;-----------------------------------
+
+(defmethod (setf origin) :after (new-origin (tp tape-measure))
+
+ "Updates the model space coordinates of the tape measure, since its
+pixel space coordinates don't change."
+
+ (let ((sp (spine tp))
+ (x-orig (first new-origin))
+ (y-orig (second new-origin))
+ (ppcm (scale tp)))
+ (setf (x1 tp) (cm-x (sl:x1 sp) x-orig ppcm)
+ (y1 tp) (cm-y (sl:y1 sp) y-orig ppcm)
+ (x2 tp) (cm-x (sl:x2 sp) x-orig ppcm)
+ (y2 tp) (cm-y (sl:y2 sp) y-orig ppcm))))
+
+;;;-----------------------------------
+
+(defmethod initialize-instance :after ((tp tape-measure) &rest initargs)
+
+ "Makes the pickable objects for the tape measure and defines the
+action functions for them."
+
+ (declare (ignore initargs))
+ (let* ((scale (scale tp))
+ (x-origin (first (origin tp)))
+ (y-origin (second (origin tp)))
+ (x1-pix (pix-x (x1 tp) x-origin scale))
+ (y1-pix (pix-y (y1 tp) y-origin scale))
+ (x2-pix (pix-x (x2 tp) x-origin scale))
+ (y2-pix (pix-y (y2 tp) y-origin scale))
+ (pic (picture tp))
+ )
+ (setf
+ (spine tp) (sl:make-segment tp x1-pix y1-pix x2-pix y2-pix
+ :color (sl:color-gc *ruler-color*)
+ :tolerance 2)
+ (end1 tp) (sl:make-circle tp x1-pix y1-pix
+ :radius *tape-disk-radius*
+ :color (sl:color-gc *ruler-color*)
+ :filled t)
+ (end2 tp) (sl:make-circle tp x2-pix y2-pix
+ :radius *tape-disk-radius*
+ :color (sl:color-gc *ruler-color*))
+ )
+ (sl:add-pickable-obj (spine tp) pic)
+ (sl:add-pickable-obj (end1 tp) pic)
+ (sl:add-pickable-obj (end2 tp) pic)
+ ;;; NOTE NOTE NOTE NOTE NOTE
+ ;;; ------------------------
+ ;;; In the case form below, the "1" clause has a call to INTERNAL
+ ;;; slik code. This issue needs to be resolved in the final impl.
+ ;;; ------------------------
+ ;;; NOTE NOTE NOTE NOTE NOTE
+ (ev:add-notify tp (sl:selected (spine tp))
+ #'(lambda (tp sp code x y)
+ (case code
+ (1 ;; this is currently a call to unexported
+ ;; code in slik
+ (setf (sl::last-x sp) x (sl::last-y sp) y))
+ (2 (destroy tp))
+ (3 (let ((new-col (sl:color-gc
+ (sl:popup-color-menu))))
+ (when new-col
+ (setf (sl:color (spine tp)) new-col
+ (sl:color (end1 tp)) new-col
+ (sl:color (end2 tp)) new-col)
+ (ev:announce tp (refresh tp))))
+ (setf (sl:active sp) nil)))))
+ (ev:add-notify tp (sl:motion (end1 tp))
+ #'(lambda (tp e1 xp yp state)
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (let* ((ppcm (scale tp))
+ (sp (spine tp)))
+ (sl:update-pickable-object e1 xp yp)
+ (setf (sl:x1 sp) xp
+ (sl:y1 sp) yp)
+ (setf (x1 tp)
+ (cm-x xp (first (origin tp)) ppcm))
+ (setf (y1 tp)
+ (cm-y yp (second (origin tp)) ppcm))
+ (ev:announce tp (refresh tp))
+ (ev:announce tp (new-length tp)
+ (tape-length tp))))))
+ (ev:add-notify tp (sl:motion (end2 tp))
+ #'(lambda (tp e2 xp yp state)
+ (when (member :button-1
+ (clx:make-state-keys state))
+ (let* ((ppcm (scale tp))
+ (sp (spine tp)))
+ (sl:update-pickable-object e2 xp yp)
+ (setf (sl:x2 sp) xp
+ (sl:y2 sp) yp)
+ (setf (x2 tp)
+ (cm-x xp (first (origin tp)) ppcm))
+ (setf (y2 tp)
+ (cm-y yp (second (origin tp)) ppcm))
+ (ev:announce tp (refresh tp))
+ (ev:announce tp (new-length tp)
+ (tape-length tp))))))
+ (ev:add-notify tp (sl:motion (spine tp))
+ #'(lambda (tp sp xp yp state)
+ (when (member :button-1 (clx:make-state-keys state))
+ (let* ((ppcm (scale tp))
+ (x-orig (first (origin tp)))
+ (y-orig (second (origin tp))))
+ (sl:update-pickable-object sp xp yp)
+ (sl:update-pickable-object (end1 tp)
+ (sl:x1 sp)
+ (sl:y1 sp))
+ (sl:update-pickable-object (end2 tp)
+ (sl:x2 sp)
+ (sl:y2 sp))
+ (setf (x1 tp) (cm-x (sl:x1 sp) x-orig ppcm)
+ (y1 tp) (cm-y (sl:y1 sp) y-orig ppcm)
+ (x2 tp) (cm-x (sl:x2 sp) x-orig ppcm)
+ (y2 tp) (cm-y (sl:y2 sp) y-orig ppcm))
+ (ev:announce tp (refresh tp))))))
+ ))
+
+;;;-----------------------------------
+
+(defmethod destroy ((tp tape-measure))
+
+ (sl:remove-pickable-objs tp (picture tp))
+ (ev:announce tp (deleted tp)))
+
+;;;-----------------------------------
+;;; End.
diff --git a/prism/src/target-volume.cl b/prism/src/target-volume.cl
new file mode 100644
index 0000000..e8e77a8
--- /dev/null
+++ b/prism/src/target-volume.cl
@@ -0,0 +1,194 @@
+;;;
+;;; target-volume
+;;;
+;;; Target-volume creates boost and initial target-volumes from a tumor
+;;; volume for treatment planning.
+;;;
+;;; 14-Apr-1991 S. Kromhout-Schiro - rewritten from target-vol2. to
+;;; reflect use of rules instead of table of margins.
+;;; 25-Nov-1991 S. Kromhout-Schiro Added nstage ruler function,
+;;; changed root-mean-square algorithm to root-of-sum-of-squares,
+;;; (x,y,z) margins and decremental margins incorporated in tv
+;;; algorithm, list-squared, and npms functions added.
+;;; 26-Nov-1991 S. Kromhout-Schiro Changed boost-contours so that
+;;; contours are calculated as tumor plus probabilistic margins.
+;;; Overlap with critical organs is subtracted if critical organs are
+;;; given as a parameter to the function call.
+;;; 1-May-1992 S. Kromhout-Schiro Added chi-sq function.
+;;; 28-Apr-1993 I. Kalet update to current Prism system and clean up
+;;; 30-Jul-1993 I. Kalet finish cleanup.
+;;; 22-Mar-1994 J. Unger change some parameters in code per MAS -- see
+;;; 'MAS/JMU-2/3/94' below.
+;;; 28-Mar-1994 J. Unger cleanup remove-overlap some.
+;;; 29-Mar-1994 J. Unger move this code from :prism to :ptvt package.
+;;; 4-May-1994 J. Unger split target-volume into initial-target-volume
+;;; and boost-target-volume. Each returns only a single target-volume.
+;;; 31-May-1994 J. Unger if the computed margins in initial-target-volume &
+;;; boost-target-volume are nil, then return a target with no contours.
+;;; 3-Jul-1997 BobGian update NEARLY-xxx -> poly:NEARLY-xxx .
+;;; 14-Oct-1997 BobGian update call to VERTEX-LIST-DIFFERENCE.
+;;; 13-Sep-2005 I. Kalet remove generate-margins, combine initial and
+;;; boost target functions, use Graham inference code instead of RULER.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------
+
+(defvar *chi-sq-factor* 1.88 ; <-- MAS/JMU-2/3/94
+
+"The 75 percentile value of chi-square for 2 degrees of freedom")
+
+;;;----------------------------------------
+
+(defun rms (l1 l2 l3)
+
+ "RMS l1 l2 l3
+
+returns a list whose elements are each the square root of the sums of
+the squares of each of the elements of the lists l1, l2 and l3."
+
+ (mapcar #'(lambda (a b c)
+ (sqrt (+ (* a a) (* b b) (* c c))))
+ l1 l2 l3))
+
+;;;----------------------------------------
+
+(defun copy-contour (pstr old-z new-z)
+
+ "COPY-CONTOUR pstr old-z new-z
+
+returns a contour with vertices from the contour in pstr that is at
+old-z but with the new contour z set to new-z."
+
+ (make-instance 'pr::contour
+ :z new-z
+ :vertices (dolist (c (pr::contours pstr))
+ (when (poly:nearly-equal (pr::z c) old-z)
+ (return (pr::vertices c))))))
+
+;;;----------------------------------------
+
+(defun expand-volume (vol margin-list)
+
+ "EXPAND-VOLUME vol margin-list
+
+Returns a list of contours generated from the contours of pstruct vol
+by the specified margins."
+
+ (let ((min-z (apply #'min (mapcar #'pr::z (pr::contours vol))))
+ (max-z (apply #'max (mapcar #'pr::z (pr::contours vol)))))
+
+ (append (list (copy-contour vol min-z (- min-z (third margin-list)))
+ (copy-contour vol max-z (+ max-z (third margin-list))))
+ (mapcar #'(lambda (c)
+ (make-instance 'pr::contour
+ :z (pr::z c)
+ :vertices
+ (poly:scale-contour (pr::vertices c)
+ margin-list)))
+ (pr::contours vol)))))
+
+;;;----------------------------------------
+
+(defun match-contour-z (con org)
+
+ "MATCH-CONTOUR-Z con org
+
+returns the first contour in the list of contours of pstruct org whose
+z matches the z of contour con. Returns nil if no match."
+
+ (find con (pr::contours org)
+ :test #'(lambda (c1 c2)
+ (poly:nearly-equal (pr::z c1) (pr::z c2)))))
+
+;;;----------------------------------------
+
+(defun contour-difference (c1 c2 &optional c3)
+
+ "CONTOUR-DIFFERENCE c1 c2 &optional c3
+
+Given two contour objects, c1 and c2, returns a list of contour objects
+ which enclose the region of space that remains when c2 is subtracted
+ from c1."
+
+ (mapcar #'(lambda (v)
+ (make-instance 'pr::contour :z (pr::z c1) :vertices v))
+ ;;
+ ;; Argument contour orientation NOT guaranteed to be CCW.
+ ;; Let VERTEX-LIST-DIFFERENCE check it to be safe [opt 4th arg = NIL].
+ ;;
+ (poly:vertex-list-difference
+ (pr::vertices c1)
+ (pr::vertices c2)
+ (and c3 (pr::vertices c3)))))
+
+;;;----------------------------------------
+
+(defun remove-overlap (con organ-list tumor)
+
+ "REMOVE-OVERLAP con organ-list tumor
+
+Subtracts off the overlap with contour con from any of the contours in
+the pstructs of organ-list. If organ-list is empty, con is returned
+unchanged. The tumor is supplied to the call to contour-difference
+to minimize the chance that the result of the the subtraction cuts
+across the tumor (see poly:VERTEX-LIST-DIFFERENCE documentation)."
+
+ (let ((result (list con))
+ (tumor-con (match-contour-z con tumor)))
+ (dolist (org organ-list result)
+ (unless (equalp (pr::name org) "PATIENT OUTLINE")
+ (let ((co (match-contour-z (first result) org)))
+ (when co
+ (setf result
+ (reduce #'append
+ (mapcar #'(lambda (res)
+ (contour-difference res co tumor-con))
+ result)))))))))
+
+;;;----------------------------------------
+
+(defun target-volume (tumor immob &optional organ-list)
+
+ "TARGET-VOLUME tumor immob &optional organ-list
+
+returns a Prism target instance by expanding the contours in tumor, an
+instance of Prism class tumor, accounting for immobilization by the
+device specified by immob, a symbol specifying an immobilization
+device or nil for no immob. dev. If organ-list is provided the
+volumes of those organ instances will be excluded from the target volume."
+
+ ;; (declare (special tumor))
+
+ (inf:replace-assert-value 'site tumor (site tumor))
+ (inf:replace-assert-value 'immob-type immob)
+ (let* ((setup-m (inf:with-answer (setup-error ?y ?x)
+ (if (eql ?y tumor)
+ (return ?x))))
+ (tumor-m (inf:with-answer (tumor-movement ?y ?x)
+ (if (eql ?y tumor)
+ (return ?x))))
+ (pt-m (inf:with-answer (pt-movement ?y ?x)
+ (if (eql ?y tumor)
+ (return ?x))))
+ ;;chi-squared times sqrt of sums of squares of above margins
+ ;; = list of prob x, y, z values
+ (prob-m (mapcar #'(lambda (m) (* m *chi-sq-factor*))
+ (rms setup-m tumor-m pt-m))))
+ (make-instance 'target
+ :target-type (if organ-list "boost" "initial")
+ :name "Planning Target Volume"
+ :site (site tumor)
+ :how-derived "Planning target volume tool"
+ :contours
+ (when prob-m ;; could be no rules for this site!
+ (if organ-list ;; optionally take out overlap with critical organs
+ (reduce #'append
+ (mapcar #'(lambda (con)
+ (remove-overlap con organ-list tumor))
+ (expand-volume tumor prob-m)))
+ (expand-volume tumor prob-m))))))
+
+;;;----------------------------------------
+;;; End.
diff --git a/prism/src/therapy-machines.cl b/prism/src/therapy-machines.cl
new file mode 100644
index 0000000..032d3d1
--- /dev/null
+++ b/prism/src/therapy-machines.cl
@@ -0,0 +1,819 @@
+;;;
+;;; therapy-machines
+;;;
+;;; This module contains the definition of the therapy-machine class.
+;;; The data for each of the therapy machines used in Prism are
+;;; contained in text files, one per therapy-machine instance, like
+;;; the patient case data. Thus the data can be read in and a
+;;; therapy machine created by using get-all-objects as in the
+;;; prism-db functions.
+;;;
+;;; 29-Dec-1992 I. Kalet from old prism
+;;; 15-Apr-1993 I. Kalet change reader for collimator from coll-type
+;;; 22-Apr-1993 I. Kalet add wedge support
+;;; 24-Aug-1993 J. Unger remove plural 's' from particle types.
+;;; 22-Oct-1993 J. Unger change names of Clinac therapy machine instances
+;;; to conform to Beam data File Description report (TR-93-08-01).
+;;; 01-Nov-1993 J. Unger add SL20-18MV machine (penumbra = 1.0 for now).
+;;; 16-Nov-1993 J. Unger add CNTS machine.
+;;; 03-Mar-1994 J. Unger add tray factor to therapy machine definition.
+;;; 10-May-1994 J. Unger enhance object def as discussed in spec.
+;;; 13-May-1994 I. Kalet move globals to prism-globals
+;;; 13-May-1994 J. Unger add #'string-equal to get-therapy-machine.
+;;; 1-Jun-1994 J. Jacky Actual machine data now in therapy-machines.dat
+;;; 23-Jun-1994 I. Kalet add type single-float to energy.
+;;; 23-Jun-1994 J. Jacky move scale-angle in from charts.cl
+;;; 25-Jun-1994 J. Jacky correct scale-angle when lower limit is
+;;; retrograde
+;;; 27-Jun-1994 I. Kalet change "NO WEDGE" to lower case.
+;;; 24-Aug-1994 J. Unger add inverse-scale-angle defun.
+;;; 26-Jan-1995 I. Kalet add slots for dose computation support data,
+;;; comments. Change readers to accessors for beam utility. Move
+;;; *therapy-machines* here - not global, really internal to this
+;;; module. Makes this module not depend on prism-globals and
+;;; therefore can more easily be used in beam data utility. Add
+;;; load-therapy-machines function.
+;;; 18-Oct-1995 I. Kalet further mods for accomodating electron
+;;; collimators, stereotactic radiosurgery beams (srs) and transfer
+;;; data.
+;;; 9-Jan-1996 I. Kalet split collim-info stuff to separate file, add
+;;; defaults for wedge list and other stuff.
+;;; 2-Feb-1997 I. Kalet redo get-therapy-machine to load on demand
+;;; rather than have all loaded at startup. Also change
+;;; get-therapy-machine-list to list all available machines, not just
+;;; the loaded ones, by reading the index file, machine.index. Make
+;;; *therapy-machine-database* the default, not the current directory.
+;;; 5-Jun-1997 I. Kalet change name of collimator slot to
+;;; collimator-type, change from peek-char to read with eof detection
+;;; in get-therapy-machine-list.
+;;; 30-Jun-1997 I. Kalet change default for wedge-rot-angles to
+;;; single-float value.
+;;; 28-Aug-1997 BobGian modified comments in get-therapy-machine to
+;;; pave way for new Lisp dose calculation.
+;;; 17-Sep-1997 I. Kalet Modify get-therapy-machine and
+;;; get-therapy-machine-list for new machine name and file name
+;;; scheme. Add ident slot to hold short string to identify data set.
+;;; 19-Sep-1997 BobGian notes here that references to old function
+;;; load-therapy-machines now refer instead to new function
+;;; get-therapy-machine.
+;;; 15-Oct-1997 BobGian implement new wedge-info scheme.
+;;; 26-Oct-1997 I. Kalet make wedge-id semantics more abstract, return
+;;; machine index list in same order as in the file.
+;;; 22-Jan-1998 BobGian update to major revision using direct-mapping table
+;;; lookups and specialized multidimensional array access. Modify
+;;; get-therapy-machine accordingly and add convert-array and build-mapper
+;;; to build appropriate dose-info objects when reading in new machine.
+;;; Add new slots for mapper-arrays to wedge-info class defn.
+;;; 09-Mar-1998 BobGian update convert-array, build-mapper, and
+;;; get-therapy-machine to conform with changes in dose calc.
+;;; 13-Mar-1998 BobGian move mapper-vector code partially to dose-info
+;;; (portion which depends on specific dose/wedge-info slots) and rest
+;;; to new file: table-lookups (application-independent portion).
+;;; Also move wedge-info defclass and slot-type method to dose-info.
+;;; Wedge-related functions which access therapy-machine object slots
+;;; remain here.
+;;; 28-Apr-1998 BobGian move build-mapper-tables here from dose-info to
+;;; resolve dependency conflict.
+;;; 11-Jun-1998 I. Kalet downcase a bunch of names while checking
+;;; correctness of get-therapy-machine.
+;;; 18-Dec-1998 I. Kalet modifications to get-therapy-machine for
+;;; electrons.
+;;; 9-Feb-1999 I. Kalet add machine-postprocess to call
+;;; build-mapper-tables for photons, default to nothing, generic
+;;; function to allow for other postprocessing of machine data on
+;;; loading.
+;;; 6-Jul-1999 I. Kalet put erf stuff for electron beams here rather
+;;; than in electron-dose, as it is potentially more general.
+;;; 3-Feb-2000 BobGian optimize error-function table referencing: convert
+;;; from general to special single-float array in machine-postprocess
+;;; method for electron-dose-info, rewrite error-function to access
+;;; table via argument rather than global variable, add declarations.
+;;; 2-Mar-2000 BobGian correct datatype of single-float constant 1000.0
+;;; in function error-function.
+;;; 25-Apr-2000 BobGian add Irreg-specific constructors/convertors to
+;;; build-mapper-tables.
+;;; 26-Apr-2000 BobGian fix build-mapper-tables to allow for optional
+;;; Irreg slots. Remove HVL Irreg tables.
+;;; 5-Feb-2001 I. Kalet revised use of ident slot for PDR, the Prism
+;;; DICOM-RT client, add tray-accessory-code for same reason.
+;;; 01-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 27-Jun-2004 BobGian - remove all irreg-related slots:
+;;; PSF-TABLE-VECTOR, PSF-RADIUS-MAPPER, PSF-RADII, PSF-TABLE,
+;;; OAF-TABLE-VECTOR, OAF-RADIUS-MAPPER, OAF-RADII, OAF-TABLE.
+;;; 1-Jul-2004 BobGian BUILD-MAPPER -> INTERPOLATE-MAPPER (more descriptive).
+;;; Discovered bug in it - fencepost error in generating mapping array.
+;;; 9-Jul-2004 BobGian: Finish fix to INTERPOLATE-MAPPER bug - array resizing
+;;; on too-large-array caused rare boundary clash resulting in missing data
+;;; bin. Fix was to remove resizing - bin size determined solely by data.
+;;; Scale-factor for float->integer conversion changed 1.0e4 -> 1.0e3.
+;;; Too large value causes over-large array allocation as inaccuracies in
+;;; floating-point arithmetic when scaled lead to very small GCDs and thus
+;;; very small bin sizes, causing array size overflow. For example, using
+;;; 1.0e6 caused array of size 26,000,000 to be requested (max is 16 Meg).
+;;; Tried range of values - 1.0e3, 1.0e4, and 1.0e5 all gave identical
+;;; results. 1.0e3 seems safest and still allows mapper to work with tables
+;;; measured to 1/1000 of a centimeter (or 1/100 of a millimeter).
+;;; 31-Jan-2005 AMSimms - corrected use of Allegro specific coercions, now
+;;; using coerce explicitly.
+;;; 22-Jun-2007 I. Kalet fix declaration in machine-postprocess
+;;;
+
+(in-package :prism)
+
+;;;=============================================================
+
+(defvar *therapy-machines* nil
+ "The list of actual therapy machine instances, which grows as needed
+by reading in data from the therapy machines files.")
+
+(defvar *therapy-machine-list* nil
+ "The list of therapy machine names, which is initialized from the
+index file the first time get-therapy-machine-list references it.")
+
+(defvar *machine-supp-list* nil
+ "The list of old or decommissioned therapy machine names, which is
+initialized from the machine name supplemental file the first time it
+is referenced.")
+
+(defvar *erf-table* nil
+ "The table of precomputed values for the error function, used in the
+electron dose code, and loaded once, on demand.")
+
+;;;=============================================================
+
+(defclass therapy-machine ()
+
+ ((name :type string
+ :initarg :name
+ :accessor name
+ :documentation "A unique short string identifying which
+particular machine this data set is for. This is a generic name, like
+CLINAC2500-6MV, not a name identifying when the data were measured or
+different actual measurements. That information is in the comments slot.")
+
+ (ident :type list
+ :initarg :ident
+ :accessor ident
+ :documentation "A list of three strings, used by the
+DICOM-RT client: a unique short string identifying the particular
+machine to the machine DICOM-RT server, the AE title for this
+machine's DICOM-RT server, and the IP address of the DICOM-RT server")
+
+ (comments :type list
+ :initarg :comments
+ :accessor comments
+ :documentation "A list of strings of comments about the
+current data set. Could be used to note details about changes in the
+data, like date taken, reference depth for tpr data and other tables, etc.")
+
+ (particle :initarg :particle
+ :accessor particle
+ :documentation "Symbol, one of, e.g., photon, neutron, electron")
+
+ (energy :type single-float
+ :initarg :energy
+ :accessor energy
+ :documentation "The nominal beam energy, in MeV")
+
+ (penumbra :type single-float
+ :initarg :penumbra
+ :accessor penumbra
+ :documentation "The approximate penumbra width in cm,
+i.e., distance from 90 percent of central axis dose to 10 percent.")
+
+ (cal-distance :type single-float
+ :initarg :cal-distance
+ :accessor cal-distance
+ :documentation "The nominal source to axis distance
+for this machine, in cm, typically 100.0 cm for photon linacs.")
+
+ (tray-factor :type single-float
+ :initarg :tray-factor
+ :accessor tray-factor
+ :documentation "The transmittance of the blocking tray for
+this machine. Total opacity is 0.0, and total transmittance is 1.0.")
+
+ (tray-accessory-code :initarg :tray-accessory-code
+ :accessor tray-accessory-code
+ :documentation "The code used by the DICOM-RT
+client to identify the use of the blocking tray in a treatment field.")
+
+ (gantry-scale :type single-float
+ :initarg :gantry-scale
+ :accessor gantry-scale
+ :documentation "Gantry angle scale factor.")
+
+ (gantry-offset :type single-float
+ :initarg :gantry-offset
+ :accessor gantry-offset
+ :documentation "Gantry angle offset.")
+
+ (turntable-scale :type single-float
+ :initarg :turntable-scale
+ :accessor turntable-scale
+ :documentation "Turntable angle scale factor.")
+
+ (turntable-offset :type single-float
+ :initarg :turntable-offset
+ :accessor turntable-offset
+ :documentation "Turntable angle offset.")
+
+ (turntable-negative-flag :type (member nil t)
+ :initarg :turntable-negative-flag
+ :accessor turntable-negative-flag
+ :documentation "Turntable angle negative flag.")
+
+ (turntable-upper-limit :type single-float
+ :initarg :turntable-upper-limit
+ :accessor turntable-upper-limit
+ :documentation "Upper limit of turntable motion.")
+
+ (turntable-lower-limit :type single-float
+ :initarg :turntable-lower-limit
+ :accessor turntable-lower-limit
+ :documentation "Lower limit of turntable motion.")
+
+ (collimator-scale :type single-float
+ :initarg :collimator-scale
+ :accessor collimator-scale
+ :documentation "Collimator angle scale factor.")
+
+ (collimator-offset :type single-float
+ :initarg :collimator-offset
+ :accessor collimator-offset
+ :documentation "Collimator angle offset.")
+
+ (collimator-upper-limit :type single-float
+ :initarg :collimator-upper-limit
+ :accessor collimator-upper-limit
+ :documentation
+ "Upper limit of collimator rotation.")
+
+ (collimator-lower-limit :type single-float
+ :initarg :collimator-lower-limit
+ :accessor collimator-lower-limit
+ :documentation
+ "Lower limit of collimator rotation.")
+
+ (collimator-negative-flag :type (member nil t)
+ :initarg :collimator-negative-flag
+ :accessor collimator-negative-flag
+ :documentation
+ "Collimator angle negative flag.")
+
+ (collimator-type :initarg :collimator-type
+ :accessor collimator-type
+ :documentation "Symbol naming one of the
+collimator types, e.g., symmetric-jaw-coll")
+
+ ;; Change to collimator-data to be consistent with others below?
+ (collimator-info ;; :type a collimator-info object
+ :initarg :collimator-info
+ :accessor collimator-info
+ :documentation "Collimator-info object, with
+collimator-specific attributes and values.")
+
+ (wedge-rot-scale :type single-float
+ :initarg :wedge-rot-scale
+ :accessor wedge-rot-scale
+ :documentation "Wedge rotation angle scale factor.")
+
+ (wedge-rot-offset :type single-float
+ :initarg :wedge-rot-offset
+ :accessor wedge-rot-offset
+ :documentation "Wedge rotation angle offset.")
+
+ (wedge-rot-print-flag :type (member nil t)
+ :initarg :wedge-rot-print-flag
+ :accessor wedge-rot-print-flag
+ :documentation "Indicates whether to print
+wedge rotation information on chart or not.")
+
+ (wedges :type list
+ :initarg :wedges
+ :accessor wedges
+ :documentation "A list of wedge-info objects, one for each
+wedge the machine can use.")
+
+ (dose-data :initarg :dose-data
+ :accessor dose-data
+ :documentation "A dose-info object with slots and
+contents that depend on the type of machine, photon, electron etc.")
+
+ (transfer-data :initarg :transfer-data
+ :accessor transfer-data
+ :documentation "The information needed to write out a
+file or files of beam parameters to be sent to a computer controlled
+accelerator.")
+
+ )
+
+ (:default-initargs :comments nil :tray-factor 1.0 :wedges nil
+ :wedge-rot-scale 1.0
+ :wedge-rot-offset 0.0
+ :wedge-rot-print-flag nil
+ :transfer-data nil)
+
+ (:documentation "Therapy-machine describes a particular external
+radiation source - its properties, rather than the settings of the
+adjustable parameters of treatment. A plan may have several beams all
+of which use the same therapy machine, or which use different ones.
+The slots of a machine object should not be updated by Prism planning
+code but should be updated by a separate machine data management
+program.")
+
+ )
+
+;;;--------------------------------------------------
+
+(defmethod slot-type ((obj therapy-machine) slotname)
+
+ (case slotname
+ ((collimator-info dose-data transfer-data) :object)
+ (wedges :object-list)
+ (otherwise :simple)))
+
+;;;--------------------------------------------------
+
+(defun make-therapy-machine (&rest initargs)
+
+ "make-therapy-machine &rest initargs
+
+Returns a therapy machine object with the specified initialization args."
+
+ (apply #'make-instance 'therapy-machine initargs))
+
+;;;--------------------------------------------------
+
+(defun get-machine-filename (mach-name indexdir)
+
+ "get-machine-filename mach-name indexdir
+
+returns the filename for the machine whose name is MACH-NAME.
+First checks the machine index, then the supplemental list. In the
+supplemental list it first checks if the equivalent generic name has
+an associated filename, and if not, uses the supplemental filename.
+If the therapy-machine list is not yet read in, INDEXDIR is used as
+the directory for the index files."
+
+ (if (find mach-name (get-therapy-machine-list indexdir)
+ :test #'equal)
+ (second (assoc mach-name *therapy-machine-list* :test #'equal))
+ (let ((supp-entry (assoc mach-name
+ (or *machine-supp-list*
+ (setq *machine-supp-list*
+ (get-index-list "machine.supp"
+ indexdir nil)))
+ :test #'equal)))
+ (if supp-entry
+ (if (equal (second supp-entry) "") (third supp-entry)
+ (second (assoc (second supp-entry)
+ *therapy-machine-list*
+ :test #'equal)))))))
+
+;;;--------------------------------------------------
+
+(defun get-therapy-machine (mach-name database indexdir)
+
+ "get-therapy-machine mach-name database indexdir
+
+returns the therapy machine instance named by the string MACH-NAME.
+If it is not already loaded into Prism, it is retrieved from the
+database specified by database, a directory name or pathname, and kept
+in working memory. The MACH-NAME string is used as a key to look up the
+data file name in the machine list, and if it is not found there the
+supplemental list is used. The index files are assumed to be in the
+directory specified by indexdir, also a directory name or pathname."
+
+ (or (find mach-name *therapy-machines* :key #'name :test #'equal)
+ ;;
+ (find (second (assoc mach-name
+ (or *machine-supp-list*
+ (setq *machine-supp-list*
+ (get-index-list "machine.supp"
+ indexdir nil)))
+ :test #'equal))
+ *therapy-machines*
+ :key #'name :test #'equal)
+ ;;
+ ;; Read in new machine and convert all dose-related tables to structure
+ ;; required by direct-mapped specialized-array dose computation system.
+ (let* ((machine-obj (first (get-all-objects
+ (merge-pathnames
+ (get-machine-filename mach-name indexdir)
+ database))))
+ (dose-info-obj (dose-data machine-obj)))
+ ;;
+ (machine-postprocess dose-info-obj machine-obj)
+ (push machine-obj *therapy-machines*)
+ ;;
+ machine-obj)))
+
+;;;--------------------------------------------------
+
+(defmethod machine-postprocess ((dose-info-obj t) machine-obj)
+
+ (declare (ignore machine-obj))
+ nil)
+
+;;;--------------------------------------------------
+
+(defmethod machine-postprocess ((dose-info-obj photon-dose-info) machine-obj)
+
+ (build-mapper-tables dose-info-obj machine-obj))
+
+;;;--------------------------------------------------
+
+(defmethod machine-postprocess ((dose-info-obj electron-dose-info) machine-obj)
+
+ (declare (ignore machine-obj))
+
+ (unless (arrayp *erf-table*)
+ (with-open-file (strm (merge-pathnames "erf.tab"
+ *therapy-machine-database*)
+ :direction :input)
+ (let* ((old-erf-table (read strm))
+ (new-erf-table (make-array (array-total-size old-erf-table)
+ :element-type 'single-float)))
+ (declare (type (simple-array t (#.erf-table-size))
+ old-erf-table)
+ (type (simple-array single-float (#.erf-table-size))
+ new-erf-table))
+ (dotimes (idx #.erf-table-size)
+ (declare (type fixnum idx))
+ (setf (aref new-erf-table idx) (aref old-erf-table idx)))
+ (setq *erf-table* new-erf-table)))))
+
+;;;-----------------------------------------------
+
+(defun error-function (a erf-table)
+
+ "error-function a erf-table
+
+Returns error function value for input A, single-float, via table look-up"
+
+ (declare (type (simple-array single-float (#.erf-table-size)) erf-table)
+ (type single-float a))
+
+ (let ((sign-a (if (< a 0.0) -1.0 1.0)))
+ (declare (type single-float sign-a))
+ (setq a (the single-float (abs a)))
+ (cond ((= a 0.0)
+ 0.0)
+ ((< a 3.0)
+ (* sign-a
+ (the single-float
+ (aref erf-table
+ (the fixnum (round (the single-float (* a 1000.0))))))))
+ (t sign-a))))
+
+;;;--------------------------------------------------
+
+(defun get-therapy-machine-list (indexdir)
+
+ "get-therapy-machine-list indexdir
+
+Returns a list of strings, each one identifying one therapy machine.
+If the special variable *therapy-machine-list* is non-nil it is used,
+otherwise the machine index file in indexdir is read in and
+*therapy-machine-list* is set to the resulting list. The indexdir
+parameter is a pathname identifying the directory in which the machine
+database index is located, so the scheme allows variant mappings of
+official machine names to different data file names e.g., one for
+clinical use and one for testing. If the index is missing or
+inaccessible the function returns nil."
+
+ (mapcar #'first
+ (or *therapy-machine-list*
+ (setq *therapy-machine-list*
+ (nreverse (get-index-list "machine.index" indexdir nil))))))
+
+;;;--------------------------------------------------
+
+(defun wedge-label (wedge-id mach)
+
+ "wedge-label wedge-id mach
+
+Returns the string that labels the wedge specified by WEDGE-ID for
+machine object mach, or a \"No wedge\" label if wedge-id is 0."
+
+ (if (eql wedge-id 0) "No wedge"
+ (name (find wedge-id (wedges mach) :key #'ID))))
+
+;;;--------------------------------------------------
+
+(defun wedge-id-from-name (wedge-name mach)
+
+ "wedge-id-from-name wedge-name mach
+
+returns the wedge id of the wedge whose name is wedge-name in machine
+mach."
+
+ (if (string-equal wedge-name "No wedge") 0
+ (id (find wedge-name (wedges mach)
+ :key #'name :test #'string-equal))))
+
+;;;--------------------------------------------------
+
+(defun wedge-rot-angles (wedge-id mach)
+
+ "wedge-rot-angles wedge-id mach
+
+returns a list of allowable rotation angles for wedge wedge-id in
+machine mach. Each wedge may have different allowed rotation angles."
+
+ (rot-angles (find wedge-id (wedges mach) :key #'id)))
+
+;;;--------------------------------------------------
+
+(defun wedge-names (mach)
+
+ "wedge-names mach
+
+Returns a list of strings labeling the available wedges for machine
+object mach."
+
+ (cons "No wedge" (mapcar #'name (wedges mach))))
+
+;;;--------------------------------------------------
+
+(defun scale-angle (angle scale offset &optional n-flag lower upper)
+
+ "scale-angle angle scale offset &optional n-flag lower upper
+
+Returns a list of two things: the scaled machine rotation angle, and a
+label. The scaled rotation angle (gantry, collim, table, or wedge) is
+computed from angle in the internal Prism coordinate system to the
+machine-specific coordinate system, using scale, offset, n-flag, lower
+and upper, the scaling constants from the beam's therapy machine. The
+label is the string deg if the angle is within range, or if the
+optional upper and lower limit parameters are absent or nil. The
+label is the string *** if limits are specified and the scaled
+rotation angle is out of range for that machine. The scaled machine
+rotation is usually adjusted to lie in the range 0 to 360. The
+optional n-flag argument is the name of the function used to look up a
+boolean flag which determines whether angles in the range 180 to 360
+should be shifted to angles in the range -180 to 0."
+
+;;; Because these are rotations, there is a special case where the lower
+;;; limit represents retrograde motion. For the SL20 turntable, the home
+;;; position is 0, the upper limit is 115 degrees, and the lower limit is
+;;; 229 degress. Actually this lower limit represents a retrograde motion
+;;; back to -131 degrees. These situations are indicated by a lower limit
+;;; that is larger than the upper limit.
+
+ (let* ((as (+ offset (* scale angle)))
+ (am (cond ((< as 0) (if n-flag as (+ as 360)))
+ ((<= 0 as 180) as)
+ ((< 180 as 360) (if n-flag (- as 360) as))
+ ((<= 360 as) (- as 360))))
+ (label (cond ((not lower) "deg") ; no limits specified
+ ((<= lower am upper) ; limits specified, angle
+ ; in range
+ "deg")
+ ((> lower upper) ; retrograde motion - special
+ ; case
+ (let ((ln (- lower 360))
+ (an (if (<= am upper) am (- am 360))))
+ (if (<= ln an upper) "deg" "***")))
+ (t "***")))) ; limits specifed, angle not
+ ; in range
+ (list am label)))
+
+;;;----------------------------------------------------
+
+(defun inverse-scale-angle (angle scale offset)
+
+ "inverse-scale-angle angle scale offset
+
+Scales an angle from a vendor-specific coordinate system back
+to a Prism coordiate system. This is the inverse of scale-angle.
+The inverse-scale'd angle (and no label) is returned."
+
+ (mod (/ (- angle offset) scale)
+ 360.0))
+
+;;;--------------------------------------------------
+;;; Function for building mapping tables.
+;;;--------------------------------------------------
+
+(defun build-mapper-tables (dose-info-obj machine-obj)
+
+ "build-mapper-tables dose-info-obj machine-obj
+
+builds the mapping tables used for fast table lookup in the dose
+calculation by storing the converted arrays and mapper tables into
+tpr-table, etc, slots in the dose-info object in dose-info-obj and
+into profile-table, etc, slots in the wedge-info objects in wedges
+slot of machine-obj."
+
+ ;; Outputfactor tables.
+ (setf (outputfactor-table dose-info-obj)
+ (convert-array (outputfactor-table dose-info-obj)))
+ (multiple-value-bind (of-sf of-ofs of-map)
+ (interpolate-mapper
+ (setf (outputfactor-fieldsizes dose-info-obj)
+ (convert-array (outputfactor-fieldsizes dose-info-obj))))
+ (declare (type (simple-array t 1) of-map)
+ (type single-float of-sf of-ofs))
+ ;; Slot 0 for input/output, other two for these parameters.
+ (let ((of-vec (make-array 3 :element-type 'single-float)))
+ (declare (type (simple-array single-float (3)) of-vec))
+ (setf (aref of-vec 1) of-sf)
+ (setf (aref of-vec 2) of-ofs)
+ (setf (outputfactor-vector dose-info-obj) of-vec))
+ (setf (outputfactor-fss-mapper dose-info-obj) of-map))
+
+ ;; TPR0 tables.
+ (setf (tpr0-table dose-info-obj)
+ (convert-array (tpr0-table dose-info-obj)))
+ (multiple-value-bind (tpr0-sf tpr0-ofs tpr0-map)
+ (interpolate-mapper
+ (setf (tpr0-depths dose-info-obj)
+ (convert-array (tpr0-depths dose-info-obj))))
+ (declare (type (simple-array t 1) tpr0-map)
+ (type single-float tpr0-sf tpr0-ofs))
+ ;; Slot 0 for input/output, other two for these parameters.
+ (let ((tpr0-vec (make-array 3 :element-type 'single-float)))
+ (declare (type (simple-array single-float (3)) tpr0-vec))
+ (setf (aref tpr0-vec 1) tpr0-sf)
+ (setf (aref tpr0-vec 2) tpr0-ofs)
+ (setf (tpr0-table-vector dose-info-obj) tpr0-vec))
+ (setf (tpr0-depth-mapper dose-info-obj) tpr0-map))
+
+ ;; TPR tables.
+ (setf (tpr-table dose-info-obj)
+ (convert-array (tpr-table dose-info-obj)))
+ (multiple-value-bind (tpr-fss-sf tpr-fss-ofs tpr-fss-map)
+ (interpolate-mapper
+ (setf (tpr-fieldsizes dose-info-obj)
+ (convert-array (tpr-fieldsizes dose-info-obj))))
+ (declare (type (simple-array t 1) tpr-fss-map)
+ (type single-float tpr-fss-sf tpr-fss-ofs))
+ (multiple-value-bind (tpr-depth-sf tpr-depth-ofs tpr-depth-map)
+ (interpolate-mapper
+ (setf (tpr-depths dose-info-obj)
+ (convert-array (tpr-depths dose-info-obj))))
+ (declare (type (simple-array t 1) tpr-depth-map)
+ (type single-float tpr-depth-sf tpr-depth-ofs))
+ ;; Slots 0,1 for input/output, rest for these parameters.
+ (let ((tpr-vec (make-array 6 :element-type 'single-float)))
+ (declare (type (simple-array single-float (6)) tpr-vec))
+ (setf (aref tpr-vec 2) tpr-fss-sf)
+ (setf (aref tpr-vec 3) tpr-depth-sf)
+ (setf (aref tpr-vec 4) tpr-fss-ofs)
+ (setf (aref tpr-vec 5) tpr-depth-ofs)
+ (setf (tpr-table-vector dose-info-obj) tpr-vec))
+ (setf (tpr-fss-mapper dose-info-obj) tpr-fss-map)
+ (setf (tpr-depth-mapper dose-info-obj) tpr-depth-map)))
+
+ ;; SPR tables.
+ (setf (spr-table dose-info-obj)
+ (convert-array (spr-table dose-info-obj)))
+ (multiple-value-bind (spr-rad-sf spr-rad-ofs spr-rad-map)
+ (interpolate-mapper
+ (setf (spr-radii dose-info-obj)
+ (convert-array (spr-radii dose-info-obj))))
+ (declare (type (simple-array t 1) spr-rad-map)
+ (type single-float spr-rad-sf spr-rad-ofs))
+ (multiple-value-bind (spr-depth-sf spr-depth-ofs spr-depth-map)
+ (interpolate-mapper
+ (setf (spr-depths dose-info-obj)
+ (convert-array (spr-depths dose-info-obj))))
+ (declare (type (simple-array t 1) spr-depth-map)
+ (type single-float spr-depth-sf spr-depth-ofs))
+ ;; Slots 0,1 for input/output, rest for these parameters.
+ (let ((spr-vec (make-array 6 :element-type 'single-float)))
+ (declare (type (simple-array single-float (6)) spr-vec))
+ (setf (aref spr-vec 2) spr-rad-sf)
+ (setf (aref spr-vec 3) spr-depth-sf)
+ (setf (aref spr-vec 4) spr-rad-ofs)
+ (setf (aref spr-vec 5) spr-depth-ofs)
+ (setf (spr-table-vector dose-info-obj) spr-vec))
+ (setf (spr-radius-mapper dose-info-obj) spr-rad-map)
+ (setf (spr-depth-mapper dose-info-obj) spr-depth-map)))
+
+ ;; OCR tables.
+ (setf (ocr-table dose-info-obj)
+ (convert-array (ocr-table dose-info-obj)))
+ (multiple-value-bind (ocr-fss-sf ocr-fss-ofs ocr-fss-map)
+ (interpolate-mapper
+ (setf (ocr-fieldsizes dose-info-obj)
+ (convert-array (ocr-fieldsizes dose-info-obj))))
+ (declare (type (simple-array t 1) ocr-fss-map)
+ (type single-float ocr-fss-sf ocr-fss-ofs))
+ (multiple-value-bind (ocr-depth-sf ocr-depth-ofs ocr-depth-map)
+ (interpolate-mapper
+ (setf (ocr-depths dose-info-obj)
+ (convert-array (ocr-depths dose-info-obj))))
+ (declare (type (simple-array t 1) ocr-depth-map)
+ (type single-float ocr-depth-sf ocr-depth-ofs))
+ (multiple-value-bind (ocr-fan-sf ocr-fan-ofs ocr-fan-map)
+ (interpolate-mapper
+ (setf (ocr-fanlines dose-info-obj)
+ (convert-array (ocr-fanlines dose-info-obj))))
+ (declare (type (simple-array t 1) ocr-fan-map)
+ (type single-float ocr-fan-sf ocr-fan-ofs))
+ ;; Slots 0,1,2 for input/output, rest for these parameters.
+ (let ((ocr-vec (make-array 9 :element-type 'single-float)))
+ (declare (type (simple-array single-float (9)) ocr-vec))
+ (setf (aref ocr-vec 3) ocr-fss-sf)
+ (setf (aref ocr-vec 4) ocr-depth-sf)
+ (setf (aref ocr-vec 5) ocr-fan-sf)
+ (setf (aref ocr-vec 6) ocr-fss-ofs)
+ (setf (aref ocr-vec 7) ocr-depth-ofs)
+ (setf (aref ocr-vec 8) ocr-fan-ofs)
+ (setf (ocr-table-vector dose-info-obj) ocr-vec))
+ (setf (ocr-fss-mapper dose-info-obj) ocr-fss-map)
+ (setf (ocr-depth-mapper dose-info-obj) ocr-depth-map)
+ (setf (ocr-fanline-mapper dose-info-obj) ocr-fan-map))))
+
+ ;; Wedge tables.
+ (dolist (wdg-info-obj (wedges machine-obj))
+ (setf (profile-table wdg-info-obj)
+ (convert-array (profile-table wdg-info-obj)))
+ (multiple-value-bind (wdg-depth-sf wdg-depth-ofs wdg-depth-map)
+ (interpolate-mapper
+ (setf (profile-depths wdg-info-obj)
+ (convert-array (profile-depths wdg-info-obj))))
+ (declare (type (simple-array t 1) wdg-depth-map)
+ (type single-float wdg-depth-sf wdg-depth-ofs))
+ (multiple-value-bind (wdg-posn-sf wdg-posn-ofs wdg-posn-map)
+ (interpolate-mapper
+ (setf (profile-positions wdg-info-obj)
+ (convert-array (profile-positions wdg-info-obj))))
+ (declare (type (simple-array t 1) wdg-posn-map)
+ (type single-float wdg-posn-sf wdg-posn-ofs))
+ ;; Slots 0,1 for input/output, rest for these parameters.
+ (let ((wdg-vec (make-array 6 :element-type 'single-float)))
+ (declare (type (simple-array single-float (6)) wdg-vec))
+ (setf (aref wdg-vec 2) wdg-depth-sf)
+ (setf (aref wdg-vec 3) wdg-posn-sf)
+ (setf (aref wdg-vec 4) wdg-depth-ofs)
+ (setf (aref wdg-vec 5) wdg-posn-ofs)
+ (setf (profile-table-vector wdg-info-obj) wdg-vec))
+ (setf (profile-depth-mapper wdg-info-obj) wdg-depth-map)
+ (setf (profile-position-mapper wdg-info-obj) wdg-posn-map)))))
+
+;;;-------------------------------------------------------------
+
+(defun interpolate-mapper (scale-array &aux
+ (scale-dim (array-total-size scale-array)))
+
+ (declare (type (simple-array single-float 1) scale-array)
+ (type fixnum scale-dim))
+
+ (cond
+ ((= scale-dim 1)
+ (values 0.0 0.0 (make-array 1 :element-type t :initial-element 0)))
+
+ (t (let* ((offset (aref scale-array 0))
+ (last-val (aref scale-array 1))
+ (gcd-so-far (the fixnum (round (* 1.0e3 (- last-val offset)))))
+ (float-gcd (coerce gcd-so-far 'single-float)))
+ (declare (type single-float offset last-val float-gcd)
+ (type fixnum gcd-so-far))
+ (unless (> gcd-so-far 0)
+ (error "INTERPOLATE-MAPPER [1]"))
+ (do ((idx1 2 (1+ idx1))
+ (next-round-val 0)
+ (this-val 0.0))
+ ((= idx1 scale-dim)
+ ;;
+ (let ((scale-factor (/ 1.0e3 float-gcd))
+ (sz 0))
+ (declare (type single-float scale-factor)
+ (type fixnum sz))
+ (setq sz (1+ (the fixnum
+ (round (/ (* 1.0e3 (- last-val offset))
+ float-gcd)))))
+ (let ((map-array
+ (make-array sz :element-type t :initial-element -1)))
+ (declare (type (simple-array t 1) map-array))
+ (do ((idx2 0 (1+ idx2)))
+ ((= idx2 scale-dim))
+ (declare (type fixnum idx2))
+ (do ((map-array-idx
+ (the fixnum
+ (round (* scale-factor
+ (- (aref scale-array idx2) offset))))
+ (1- map-array-idx)))
+ ((or (< map-array-idx 0)
+ (/= (svref map-array map-array-idx) -1)))
+ (declare (type fixnum map-array-idx))
+ (setf (svref map-array map-array-idx) idx2)))
+ (values scale-factor offset map-array))))
+
+ (declare (type single-float this-val)
+ (type fixnum idx1 next-round-val))
+
+ (setq this-val (aref scale-array idx1)
+ next-round-val (round (* 1.0e3 (- this-val last-val))))
+ (unless (> next-round-val 0)
+ (error "INTERPOLATE-MAPPER [2]"))
+ (setq gcd-so-far (gcd gcd-so-far next-round-val)
+ float-gcd (coerce gcd-so-far 'single-float)
+ last-val this-val))))))
+
+;;;--------------------------------------------------
+;;; End.
diff --git a/prism/src/tools-panel.cl b/prism/src/tools-panel.cl
new file mode 100644
index 0000000..013450d
--- /dev/null
+++ b/prism/src/tools-panel.cl
@@ -0,0 +1,62 @@
+;;;
+;;; tools-panel
+;;;
+;;; implements the RTPT tools menu and action functions
+;;;
+;;; 13-Dec-1993 M. Phillips implemented
+;;; 4-Feb-1994 I. Kalet include gpet function here and add Autoplan
+;;; to tools menu
+;;; 11-Jun-1994 I. Kalet remove PTVT. It is implemented in the Add
+;;; Target function call.
+;;; 13-Jun-1994 I. Kalet change collections symbol to one colon
+;;; 21-Jun-1994 I. Kalet add neutron function to write CNTS plan data
+;;; to a file suitable to transfer to CNTS for automated setup.
+;;; 7-Jul-1994 J. Jacky finish gpet for new Prism dose filenames dose1,2,3
+;;; 7-Jul-1994 J. Jacky change pathname for gpet defaults file
+;;; write the many gpet output files in ./prismlocal
+;;;
+;;; 19-Jul-1994 J. Unger change references to ./prismlocal to references
+;;; to *local-database* instead. Also redo the neutron interface.
+;;; 11-Aug-1994 J. Unger minor mods to run-subprocess.
+;;; 07-Oct-1994 J. Unger provide current display to gpet command line.
+;;; 18-Jun-1998 I. Kalet eliminate DRR from menu, as it will be soon
+;;; implemented as a background image in beams-eye-views.
+;;; 24-Dec-1998 I. Kalet specify ":wait nil" in call to run-subprocess
+;;; 25-Feb-1999 I. Kalet add Mark's import-anatomy panel.
+;;; 25-Oct-1999 I. Kalet take off selections no longer in use.
+;;; 29-Jun-2000 I. Kalet reorganize as data driven from
+;;; *external-tools* global variable
+;;;
+
+(in-package :prism)
+
+;;;-------------------------------------
+
+(defun add-tool (tool-name tool-function)
+
+ "add-tool tool-name tool-function
+
+adds the string tool-name to the special tools menu. The function
+named by symbol tool-function executes when tool-name is selected."
+
+ (push (list tool-name tool-function) *special-tools*))
+
+;;;-------------------------------------
+
+(defun tools-panel (pat)
+
+ "tools-panel pat
+
+provides a menu for the user to select an externally-provided tool for
+immediate execution. Selection of a given button on the tools-panel
+menu will call a function designed to obtain all the necessary
+information and begin program execution. Returns whatever the tool
+function call returns."
+
+ (let ((tool-number (sl:popup-menu (mapcar #'first *special-tools*))))
+ (when tool-number
+ (funcall (nth tool-number (mapcar #'second *special-tools*))
+ pat))))
+
+;;;-------------------------------------
+;;; End.
diff --git a/prism/src/view-graphics.cl b/prism/src/view-graphics.cl
new file mode 100644
index 0000000..1afc0df
--- /dev/null
+++ b/prism/src/view-graphics.cl
@@ -0,0 +1,257 @@
+;;;
+;;; view-graphics
+;;;
+;;; 11-Dec-1992 J. Unger started, from discussions with I. Kalet.
+;;; 13-Dec-1992 J. Unger & I. Kalet update to aggreed upon scheme.
+;;; 22-Dec-1992 I. Kalet remove refs to width and height in SLIK.
+;;; 23-Dec-1992 J. Unger add rectangles-prim code, improve documentation.
+;;; 29-Dec-1992 J. Unger make clx:draw's in draw methods conditional on
+;;; there actually being something to draw.
+;;; 31-Dec-1992 I. Kalet remove image primitive type - not needed
+;;; 4-Jan-1993 J. Unger modify lines-prim to handle multiple sets of
+;;; connected lines.
+;;; 24-Feb-1993 J. Unger move color attribute from subclasses into the
+;;; graphic-primitive base class.
+;;; 23-Jul-1993 I. Kalet add method here for lines-prim in pixmap.
+;;; 2-Feb-1994 J. Unger fix error in segments-prim documentation.
+;;; 10-Mar-1994 I. Kalet change draw method for pixmap into function.
+;;; 29-May-1994 I. Kalet change draw-lines-pix to generic function
+;;; draw-pix.
+;;; 18-Sep-1994 J. Unger add filled attribute to rectangles prim, draw
+;;; function.
+;;; 8-Oct-1996 I. Kalet remove &rest from draw methods, move
+;;; get-segments-prim and get-rectangles-prim here from
+;;; beam-graphics.
+;;; 17-Apr-1998 I. Kalet add draw-pix methods for the rest, and just
+;;; have a single generic draw method.
+;;; 16-Jul-1998 I. Kalet add a visible attribute and support for it.
+;;;
+
+(in-package :prism)
+
+;;;-------------------------------------
+
+(defclass graphic-primitive ()
+
+ ((object :accessor object
+ :initarg :object
+ :documentation "The graphic object from which this
+primitive was generated; eg: an organ, a beam, etc.")
+
+ (color :accessor color
+ :initarg :color
+ :documentation "The color of the low-level graphic
+information, a clx:gcontext.")
+
+ (visible :accessor visible
+ :initform t
+ :documentation "This attribute determines whether the
+graphic primitive actually appears in the view or is ignored.")
+
+ )
+
+ (:documentation "A low-level representation of a graphical object.")
+
+ )
+
+;;;-------------------------------------
+
+(defmethod draw ((gp graphic-primitive) (v view))
+
+ "Defers dispatching on prim type to the draw-pix function."
+
+ (if (visible gp) (draw-pix gp (sl:pixmap (picture v)))))
+
+;;;-------------------------------------
+
+(defclass lines-prim (graphic-primitive)
+
+ ((points :accessor points
+ :initarg :points
+ :documentation "A list of points lists. Each point list
+consists of a series of x y pixel-space pairs, that define the lines
+to be drawn for a given connected loop.")
+
+ )
+
+ (:documentation "A low level representation of a list of sequences
+of connected line segments.")
+
+ )
+
+;;;-------------------------------------
+
+(defun make-lines-prim (points color &rest other-initargs)
+
+ "MAKE-LINES-PRIM points color &rest other-initargs
+
+Returns a lines-prim graphics primitive, with points, color, and other
+initialization attributes appropriately set."
+
+ (apply #'make-instance 'lines-prim
+ :points points :color color other-initargs))
+
+;;;----------------------------------
+
+(defmethod draw-pix ((l lines-prim) px)
+
+ "Draws lines primitive object l into pixmap px."
+
+ (when (points l)
+ (dolist (pts (points l))
+ (clx:draw-lines px (color l) pts))))
+
+;;;-------------------------------------
+
+(defclass segments-prim (graphic-primitive)
+
+ ((points :accessor points
+ :initarg :points
+ :documentation "A sequence of the form {x1 y1 x2 y2}*,
+where each four successive elements defines the two endpoints of a
+line segment.")
+
+ )
+
+ (:documentation "A low level representation of a sequence of
+unconnected line segments.")
+
+ )
+
+;;;-------------------------------------
+
+(defun make-segments-prim (points color &rest other-initargs)
+
+ "MAKE-SEGMENTS-PRIM points color &rest other-initargs
+
+Returns a segments-prim graphics primitive, with points, color, and
+other initialization attributes appropriately set."
+
+ (apply #'make-instance 'segments-prim
+ :points points :color color other-initargs))
+
+;;;-------------------------------------
+
+(defun get-segments-prim (obj v clr)
+
+ "GET-SEGMENTS-PRIM obj v clr
+
+Creates an empty segments graphic primitive for object obj on view v's
+foreground list, with color clr, and returns the created primitive."
+
+ (first (push (make-segments-prim nil clr :object obj)
+ (foreground v))))
+
+;;;-------------------------------------
+
+(defmethod draw-pix ((s segments-prim) px)
+
+ "Draws segments primtive object s into pixmap px."
+
+ (when (points s) (clx:draw-segments px (color s) (points s))))
+
+;;;-------------------------------------
+
+(defclass characters-prim (graphic-primitive)
+
+ ((characters :accessor characters
+ :initarg :characters
+ :documentation "The characters to be drawn.")
+
+ (x :accessor x
+ :initarg :x
+ :documentation "The x coordinate of the left baseline position
+for the first character drawn.")
+
+ (y :accessor y
+ :initarg :y
+ :documentation "The y coordinate of the left baseline position
+for the first character drawn.")
+
+ )
+
+ (:documentation "A low level representation of a sequence of
+characters.")
+
+ )
+
+;;;-------------------------------------
+
+(defun make-characters-prim (characters x y color &rest other-initargs)
+
+ "MAKE-CHARACTERS-PRIM characters x y color &rest other-initargs
+
+Returns a characters-prim graphics primitive, with characters, x, y,
+and color attributes appropriately set."
+
+ (apply #'make-instance 'characters-prim
+ :characters characters :x x :y y :color color other-initargs))
+
+;;;-------------------------------------
+
+(defmethod draw-pix ((c characters-prim) px)
+
+ "Draws characters object c into pixmap px."
+
+ (when (characters c)
+ (clx:draw-glyphs px (color c) (x c) (y c) (characters c))))
+
+;;;-------------------------------------
+
+(defclass rectangles-prim (graphic-primitive)
+
+ ((rectangles :accessor rectangles
+ :initarg :rectangles
+ :documentation "A list of 4-tuples, each of the form
+(ulc-x ulc-y width height), which define the rectangles to be drawn.")
+
+ (filled :accessor filled
+ :initarg :filled
+ :documentation "When nil, causes the rectangles to be drawn
+in a non-filled fashion. Otherwise, causes them to be drawn filled.")
+
+ )
+
+ (:default-initargs :filled nil)
+
+ (:documentation "A low level representation of a sequence of
+unconnected rectangles.")
+
+ )
+
+;;;-------------------------------------
+
+(defun make-rectangles-prim (rects color &rest other-initargs)
+
+ "MAKE-RECTANGLES-PRIM rects color &rest other-initargs
+
+Returns a rectangles-prim graphics primitive, with rects, color, and
+other initialization attributes appropriately set."
+
+ (apply #'make-instance 'rectangles-prim
+ :rectangles rects :color color other-initargs))
+
+;;;-------------------------------------
+
+(defun get-rectangles-prim (obj v clr)
+
+ "GET-RECTANGLES-PRIM obj v clr
+
+Creates an empty rectangles graphic primitive for object obj on view
+v's foreground list, with color clr, and any future rectangles to be
+filled, and returns the created primitive."
+
+ (first (push (make-rectangles-prim nil clr :object obj :filled t)
+ (foreground v))))
+
+;;;-------------------------------------
+
+(defmethod draw-pix ((r rectangles-prim) px)
+
+ "Draws rectangles primitive object r into pixmap px."
+
+ (when (rectangles r)
+ (clx:draw-rectangles px (color r) (rectangles r) (filled r))))
+
+;;;-------------------------------------
+;;; End.
diff --git a/prism/src/view-panels.cl b/prism/src/view-panels.cl
new file mode 100644
index 0000000..5e04627
--- /dev/null
+++ b/prism/src/view-panels.cl
@@ -0,0 +1,706 @@
+;;;
+;;; view-panels
+;;;
+;;; This is the implementation of Prism view-panels. A view-panel is
+;;; the frame that contains the view buttons and other controls.
+;;; When a view-panel is created, the picture which is part of the
+;;; view is mapped as a child window in the panel frame.
+;;;
+;;; 30-Jun-1992 I. Kalet started, from earlier views module
+;;; 31-Jul-1992 I. Kalet use apply to make buttons and stuff, add
+;;; destroy method, and title.
+;;; 22-Aug-1992 I. Kalet add busy bit/mediator code for position
+;;; 16-Sep-1992 I. Kalet use generic-panel base class, add
+;;; remove-notify for (new-pos view)
+;;; 25-Oct-1992 I. Kalet use window, not pixmap to get view size
+;;; 06-Nov-1992 J. Unger reconfigure placement of buttons/textlines,
+;;; add functionality for window/level.
+;;; 30-Nov-1992 J. Unger modify button config to save space.
+;;; 13-Dec-1992 I. Kalet change image-displayed to
+;;; background-displayed
+;;; 21-Dec-1992 I. Kalet coerce view-position, scale to single-float
+;;; 15-Feb-1993 I. Kalet change scale to slider, not textline
+;;; 24-Apr-1993 I. Kalet parametrize button positions, fix doc.
+;;; 5-Nov-1993 I. Kalet disable scale slider if background displayed
+;;; 31-Jan-1994 J. Unger add code for Plot View button.
+;;; 15-Jun-1994 I. Kalet make numeric input textlines check validity
+;;; 12-Jan-1995 I. Kalet cache reference to plan, patient here, pass to
+;;; interactive-make-plot, instead of using back-pointer in view.
+;;; 30-Apr-1997 I. Kalet add name textline to view panel
+;;; 17-Jul-1998 I. Kalet add a button and menu subpanel to select what
+;;; objects are visible in the view, in addition to image on/off
+;;; button.
+;;; 21-Jul-1998 I. Kalet fix error in declutter menu.
+;;; 12-Aug-1998 I. Kalet add action for toggle of background-displayed.
+;;; 11-Mar-1999 I. Kalet change window and level controls to sliderboxes.
+;;; 10-Apr-1999 C. Wilcox added support for interruptable background drr's.
+;;; 4-Mar-2000 I. Kalet added long awaited tape measure in views.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 16-Jul-2000 I. Kalet allow zoom and pan in views, supported by OpenGL.
+;;; 16-Dec-2000 I. Kalet set title to initial value of view name.
+;;; 11-Mar-2001 I. Kalet if BEV, update title when view name changes.
+;;; 17-Mar-2002 I. Kalet change interactive-make-plot to
+;;; make-plot-panel, add a slot for a plot panel, not a dialog box.
+;;; 31-Jul-2002 I. Kalet add oblique-view-panel with rotation dials
+;;; 7-Aug-2002 J. Sager add room-view-panel support
+;;; 19-Aug-2002 J. Sager modify image-button action, since room-views
+;;; need the background displayed always to render.
+;;; 23-Sep-2002 I. Kalet minor mods to clean up, also for room view,
+;;; viewlist panel should reference gl-prims instead of foreground.
+;;; 29-Jan-2003 I. Kalet increase upper limit on scale control.
+;;; 1-Feb-2003 I. Kalet move default method for name to prism-objects.
+;;; 12-May-2003 M. Phillips added button to viewlist-panel that clears
+;;; all objects from view.
+;;; 25-May-2009 I. Kalet remove room-view-panel support
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------------
+
+(defclass view-panel (generic-panel)
+
+ ((view-frame :accessor view-frame
+ :documentation "The SLIK frame that holds all the view
+stuff, including the actual picture, and the controls.")
+
+ (view-for :accessor view-for
+ :initarg :view-for
+ :documentation "The view this panel contains.")
+
+ (plan-of :initarg :plan-of
+ :accessor plan-of
+ :documentation "The plan containing the view.")
+
+ (patient-of :initarg :patient-of
+ :accessor patient-of
+ :documentation "The current patient.")
+
+ (delete-view :accessor delete-view
+ :documentation "The DELETE button, for delete panel.")
+
+ (plot-view :accessor plot-view
+ :documentation "The PLOT VIEW button.")
+
+ (plot-panel :accessor plot-panel
+ :documentation "A temporary storage for the plot
+control panel, no longer a dialog box")
+
+ (name-box :accessor name-box
+ :documentation "Textline for view name.")
+
+ (local-bar-button :accessor local-bar-button
+ :documentation "The button that toggles the
+locator bars in this view.")
+
+ (remote-bar-button :accessor remote-bar-button
+ :documentation "The button that toggles the
+locator bars for this view in the other views if any.")
+
+ (image-button :accessor image-button
+ :documentation "The button that toggles display of
+image data in this view.")
+
+ (fg-button :accessor fg-button
+ :documentation "Brings up a popup menu of objects in the
+view to display them or not on a view by view basis.")
+
+ (viewlist-panel :accessor viewlist-panel
+ :initform nil
+ :documentation "Temporarily holds the list of
+objects visible on the screen.")
+
+ (position-control :accessor position-control
+ :documentation "The control, a textline or
+slider, that displays and sets the position of the view.")
+
+ (busy :accessor busy
+ :initform nil
+ :documentation "The mediator busy bit for controlling updates
+between the view panel controls and the view attributes.")
+
+ (scale-control :accessor scale-control
+ :documentation "A slider that displays and sets the
+scale factor for the view.")
+
+ (window-control :accessor window-control
+ :documentation "The textline that displays and sets
+the window for the view's image.")
+
+ (level-control :accessor level-control
+ :documentation "The textline that displays and sets
+the level for the view's image.")
+
+ (tape-measure-btn :accessor tape-measure-btn
+ :documentation "The Ruler button. Pressing it
+causes a tape measure to appear in the display area.")
+
+ )
+
+ (:documentation "The view-panel class contains the view controls and
+the frame containing them and the view picture.")
+
+ )
+
+;;;-------------------------------------
+
+(defun make-view-panel (v &rest other-initargs)
+
+ (apply #'make-instance
+ (cond ((typep v 'oblique-view) 'oblique-view-panel)
+ (T 'view-panel))
+ :view-for v other-initargs))
+
+;;;-------------------------------------
+
+(defmethod initialize-instance :after ((vp view-panel) &rest initargs)
+
+ (let* ((v (view-for vp))
+ (pic (picture v))
+ (win (sl:window pic))
+ (pic-w (clx:drawable-width win))
+ (pic-h (clx:drawable-height win))
+ (vpf (symbol-value *small-font*))
+ (vf (apply #'sl:make-frame (+ pic-w 140) pic-h
+ :title (name v)
+ initargs))
+ (vw (sl:window vf))
+ (sbw 55) ; small button width
+ (lbw 120) ; large button width
+ (bh 25) ; button height
+ (dx 10) ; left margin
+ (rx (+ dx sbw 10)) ; middle x placement
+ (top-y 8)) ; top button y placement
+ (setf (view-frame vp) vf
+ (delete-view vp) (apply #'sl:make-button sbw bh
+ :parent vw
+ :button-type :momentary
+ :font vpf :label "Del Pan"
+ :ulc-x dx :ulc-y top-y initargs)
+ (plot-view vp) (apply #'sl:make-button sbw bh
+ :parent vw
+ :font vpf :label "Plot"
+ :ulc-x rx :ulc-y top-y initargs)
+ (name-box vp) (apply #'sl:make-textline lbw bh
+ :parent vw
+ :ulc-x dx :ulc-y (bp-y top-y bh 1)
+ :font vpf initargs)
+ (local-bar-button vp) (apply #'sl:make-button sbw bh
+ :parent vw
+ :font vpf :label "Local"
+ :ulc-x dx
+ :ulc-y (bp-y top-y bh 2)
+ initargs)
+ (remote-bar-button vp) (apply #'sl:make-button sbw bh
+ :parent vw
+ :font vpf :label "Remote"
+ :ulc-x rx
+ :ulc-y (bp-y top-y bh 2)
+ initargs)
+ (image-button vp) (apply #'sl:make-button sbw bh
+ :parent vw
+ :font vpf :label "Image"
+ :ulc-x dx
+ :ulc-y (bp-y top-y bh 3)
+ initargs)
+ (fg-button vp) (apply #'sl:make-button sbw bh
+ :parent vw
+ :font vpf :label "Objects"
+ :ulc-x rx
+ :ulc-y (bp-y top-y bh 3)
+ initargs)
+ (position-control vp) (apply #'sl:make-textline lbw bh
+ :parent vw
+ :font vpf :label "Pos: "
+ :ulc-x dx
+ :ulc-y (bp-y top-y bh 4)
+ :numeric t
+ :lower-limit -500.0
+ :upper-limit 500.0
+ initargs)
+ (scale-control vp) (apply #'sl:make-slider lbw bh 5.0 100.0
+ :parent vw
+ :ulc-x dx
+ :ulc-y (bp-y top-y bh 5)
+ initargs)
+ (window-control vp) (apply #'sl:make-sliderbox
+ lbw bh 1.0 2047.0 9999.0
+ :parent vw
+ :font vpf :label "Win: "
+ :ulc-x (- dx 5)
+ :ulc-y (bp-y top-y bh 6)
+ :border-width 0
+ :display-limits nil
+ initargs)
+ (level-control vp) (apply #'sl:make-sliderbox
+ lbw bh 1.0 4095.0 9999.0
+ :parent vw
+ :font vpf :label "Lev: "
+ :ulc-x (- dx 5)
+ :ulc-y (bp-y top-y bh 8)
+ :border-width 0
+ :display-limits nil
+ initargs)
+ (tape-measure-btn vp) (apply #'sl:make-button lbw bh
+ :parent vw
+ :font vpf :label "Ruler"
+ :ulc-x dx
+ :ulc-y (+ (bp-y top-y bh 10) 5)
+ :button-type :momentary
+ initargs))
+ (ev:add-notify vp (sl:button-on (delete-view vp))
+ #'(lambda (panel bt)
+ (declare (ignore bt))
+ (destroy panel)))
+ (ev:add-notify vp (sl:button-on (plot-view vp))
+ #'(lambda (pan bt)
+ (setf (plot-panel pan)
+ (make-plot-panel (view-for pan) vp
+ (plan-of pan)
+ (patient-of pan)))
+ (ev:add-notify pan (deleted (plot-panel pan))
+ #'(lambda (pnl ptpnl)
+ (declare (ignore ptpnl))
+ (setf (plot-panel pnl) nil)
+ (when (not (busy pnl))
+ (setf (busy pnl) t)
+ (setf (sl:on bt) nil)
+ (setf (busy pnl) nil))))))
+ (ev:add-notify vp (sl:button-off (plot-view vp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (plot-panel pan))
+ (setf (busy pan) nil))))
+
+ (setf (sl:info (name-box vp)) (name v))
+ (ev:add-notify vp (sl:new-info (name-box vp))
+ #'(lambda (pan bx inf)
+ (declare (ignore bx))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (name (view-for pan)) inf)
+ (setf (busy pan) nil))))
+ (ev:add-notify vp (new-name v)
+ #'(lambda (pan vw nn)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (name-box pan)) nn)
+ (if (typep vw 'beams-eye-view)
+ (setf (sl:title (view-frame pan)) nn))
+ (setf (busy pan) nil))))
+ (setf (sl:on (local-bar-button vp)) (local-bars-on v))
+ (ev:add-notify v (sl:button-on (local-bar-button vp))
+ #'(lambda (vu pan)
+ (declare (ignore pan))
+ (setf (local-bars-on vu) t)))
+ (ev:add-notify v (sl:button-off (local-bar-button vp))
+ #'(lambda (vu pan)
+ (declare (ignore pan))
+ (setf (local-bars-on vu) nil)))
+ (setf (sl:on (remote-bar-button vp)) t) ; locators are always
+ ; created visible
+ (ev:add-notify v (sl:button-on (remote-bar-button vp))
+ #'(lambda (vu pan)
+ (declare (ignore pan))
+ (ev:announce vu (remote-bars-toggled vu) t)))
+ (ev:add-notify v (sl:button-off (remote-bar-button vp))
+ #'(lambda (vu pan)
+ (declare (ignore pan))
+ (ev:announce vu (remote-bars-toggled vu) nil)))
+ (setf (sl:info (position-control vp)) (view-position v))
+ (ev:add-notify vp (sl:new-info (position-control vp))
+ #'(lambda (pan pc inf)
+ (declare (ignore pc))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (view-position (view-for pan))
+ (coerce (read-from-string inf) 'single-float))
+ (setf (busy pan) nil))))
+ (ev:add-notify vp (new-position v)
+ #'(lambda (pan vw pos)
+ (declare (ignore vw))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:info (position-control pan)) pos)
+ (setf (busy pan) nil))))
+ (setf (sl:setting (scale-control vp)) (scale v))
+ (ev:add-notify vp (sl:value-changed (scale-control vp))
+ #'(lambda (pan sc val)
+ (declare (ignore sc))
+ (let ((vf (view-for pan)))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (scale vf) val)
+ (setf (busy pan) nil)))))
+ (ev:add-notify vp (new-scale v)
+ #'(lambda (pan vw val)
+ (declare (ignore vw))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:setting (scale-control pan)) val)
+ (setf (busy pan) nil))))
+ (setf (sl:setting (window-control vp))
+ (coerce (window v) 'single-float))
+ (ev:add-notify vp (sl:value-changed (window-control vp))
+ #'(lambda (pan wc win)
+ (declare (ignore wc))
+ (setf (window (view-for pan)) (round win))))
+ (setf (sl:setting (level-control vp))
+ (coerce (level v) 'single-float))
+ (ev:add-notify vp (sl:value-changed (level-control vp))
+ #'(lambda (pan lc lev)
+ (declare (ignore lc))
+ (setf (level (view-for pan)) (round lev))))
+ (when (typep (view-for vp) 'beams-eye-view)
+ (setf (image-button v) (image-button vp))
+ ;; we want the side effects from setf drr-state
+ (setf (drr-state v) (drr-state v)) )
+ (setf (sl:on (image-button vp)) (background-displayed v))
+ (ev:add-notify vp (sl:button-on (image-button vp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (view-for pan)) t)
+ (setf (busy pan) nil))))
+ (ev:add-notify vp (sl:button-off (image-button vp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (background-displayed (view-for pan)) nil)
+ (setf (busy pan) nil))))
+ (ev:add-notify vp (sl:button-2-on (image-button vp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (when (typep (view-for pan) 'beams-eye-view)
+ (case (drr-state (view-for pan))
+ ;;'stopped is a noop
+ ('running
+ (setf (drr-state (view-for pan)) 'paused))
+ ('paused
+ (setf (drr-state (view-for pan)) 'running)
+ (drr-bg (view-for pan)))))
+ (setf (busy pan) nil))))
+ (ev:add-notify vp (bg-toggled v)
+ #'(lambda (pan vw)
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (setf (sl:on (image-button pan))
+ (background-displayed vw))
+ (setf (busy pan) nil))))
+ (ev:add-notify vp (sl:button-on (fg-button vp))
+ #'(lambda (pan bt)
+ (setf (viewlist-panel pan)
+ (make-instance 'viewlist-panel
+ :view (view-for pan)))
+ (ev:add-notify pan (deleted (viewlist-panel
+ pan))
+ #'(lambda (pnl vlpnl)
+ (declare (ignore vlpnl))
+ (setf (viewlist-panel pnl) nil)
+ (when (not (busy pnl))
+ (setf (busy pnl) t)
+ (setf (sl:on bt) nil)
+ (setf (busy pnl) nil))))))
+ (ev:add-notify vp (sl:button-off (fg-button vp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (when (not (busy pan))
+ (setf (busy pan) t)
+ (destroy (viewlist-panel pan))
+ (setf (busy pan) nil))))
+ (ev:add-notify vp (sl:button-on (tape-measure-btn vp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (let ((vw (view-for pan)))
+ (unless (tape-measure vw)
+ (let ((center (/ (sl:width (picture vw)) 2))
+ (x-origin (x-origin vw))
+ (y-origin (y-origin vw))
+ (scale (scale vw)))
+ (setf (tape-measure vw)
+ (make-tape-measure
+ :picture (picture vw)
+ :scale scale
+ :origin (list x-origin y-origin)
+ :x1 (cm-x (- center 20) x-origin scale)
+ :y1 (cm-x (- center 20) y-origin scale)
+ :x2 (cm-x (+ center 20) x-origin scale)
+ :y2 (cm-x (+ center 20) y-origin scale)))
+ (setf (sl:label (tape-measure-btn pan))
+ (write-to-string (fix-float
+ (tape-length
+ (tape-measure vw)) 2)))
+ (ev:add-notify pan (new-length (tape-measure vw))
+ #'(lambda (pnl tp len)
+ (declare (ignore tp))
+ (setf (sl:label
+ (tape-measure-btn pnl))
+ (write-to-string
+ (fix-float len 2)))))
+ (ev:add-notify vw (refresh (tape-measure vw))
+ #'(lambda (vu tp)
+ (declare (ignore tp))
+ (display-view vu)))
+ (ev:add-notify pan (deleted (tape-measure vw))
+ #'(lambda (pnl tp)
+ (declare (ignore tp))
+ (let ((vu (view-for pnl)))
+ (setf
+ (sl:label
+ (tape-measure-btn pnl))
+ "Ruler")
+ (setf (tape-measure vu) nil)
+ (display-view vu))))
+ (display-view vw))))))
+ (clx:reparent-window (sl:window pic) vw 140 0)
+ (clx:map-window (sl:window pic))
+ (sl:flush-output)))
+
+;;;--------------------------------------
+
+(defclass oblique-view-panel (view-panel)
+
+ ((azi-dialbox :accessor azi-dialbox
+ :documentation "The dialbox that controls the azimuth
+angle of the view plane.")
+
+ (alt-dialbox :accessor alt-dialbox
+ :documentation "The dialbox that controls the altitude
+angle of the view plane.")
+
+ )
+
+ (:documentation "An oblique view panel has two additional controls,
+to tilt the plane to arbitrary orientations.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((ovp oblique-view-panel) &rest initargs)
+
+ (let* ((vpf (symbol-value *small-font*))
+ (vf (view-frame ovp))
+ (vpw (sl:window vf))
+ (sbw 50) ; small button width
+ (bh 25) ; button height
+ (dx 0) ; left margin
+ (rx (+ dx sbw 20)) ; middle x placement
+ (top-y 8)) ; top button y placement
+ (setf (azi-dialbox ovp)
+ (apply #'sl:make-dialbox 25
+ :parent vpw
+ :font vpf :label "Azi:"
+ :ulc-x dx
+ :ulc-y (+ (bp-y top-y bh 11) 5)
+ initargs))
+ (setf (alt-dialbox ovp)
+ (apply #'sl:make-dialbox 25
+ :parent vpw
+ :font vpf :label "Alt:"
+ :ulc-x rx
+ :ulc-y (+ (bp-y top-y bh 11) 5)
+ initargs))
+ (ev:add-notify ovp (sl:value-changed (azi-dialbox ovp))
+ #'(lambda (pan db newazi)
+ (declare (ignore db))
+ (setf (azimuth (view-for pan)) newazi)))
+ (ev:add-notify ovp (sl:value-changed (alt-dialbox ovp))
+ #'(lambda (pan db newalt)
+ (declare (ignore db))
+ (setf (altitude (view-for pan)) newalt)))
+ (setf (sl:angle (azi-dialbox ovp)) (azimuth (view-for ovp))
+ (sl:angle (alt-dialbox ovp)) (altitude (view-for ovp)))))
+
+;;;--------------------------------------
+
+(defclass viewlist-panel (generic-panel)
+
+ ((view :accessor view
+ :initarg :view
+ :documentation "The view displaying the list of objects.")
+
+ (frame :accessor frame
+ :documentation "The frame containing the panel on the
+display.")
+
+ (oblist :accessor oblist
+ :initarg :oblist
+ :documentation "The list of objects that can be turned on
+and off in the view.")
+
+ (ob-menu :accessor ob-menu
+ :documentation "The scrolling list of names of objects or
+classes to turn on or off.")
+
+ (refresh-fn :accessor refresh-fn
+ :initarg :refresh-fn
+ :initform #'display-view
+ :documentation "The function to call to refresh the
+view after an object is turned on or off.")
+
+ (delete-btn :accessor delete-btn
+ :documentation "The Delete Panel button.")
+
+ (clear-all-btn :accessor clear-all-btn
+ :documentation "The CLEAR-ALL button.")
+
+ )
+
+ (:documentation "The viewlist panel has a scrolling list of buttons,
+one for points and one for each of the other objects in the view, so
+the user can select them for display or no display.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((vlp viewlist-panel)
+ &rest initargs)
+
+ (declare (ignore initargs))
+ (let* ((vw (view vlp))
+ (prims (foreground vw))
+ (oblist (remove-if #'(lambda (obj) (typep obj 'mark))
+ (remove-duplicates
+ (mapcar #'object prims))))
+ (vlpf (symbol-value *small-font*))
+ (mark-prim (find-if #'(lambda (x) (typep x 'mark))
+ prims :key #'object))
+ (other-names (mapcar #'name oblist))
+ (items (if mark-prim ;; Points are lumped
+ (cons "Points" other-names)
+ other-names))
+ (obmenu (sl:make-scrolling-list
+ (+ 40 (apply #'max (mapcar #'(lambda (item)
+ (clx:text-width vlpf item))
+ items)))
+ 300 ;; arbitrary height
+ :items items
+ :font vlpf :mapped nil))
+ (height (+ 65 (sl:height obmenu)))
+ (btw (sl:width obmenu))
+ (frm (sl:make-frame (+ 10 btw) height :title "Display list"))
+ (clear-all-flag nil))
+ (setf (oblist vlp) oblist
+ (frame vlp) frm
+ (ob-menu vlp) obmenu
+ (delete-btn vlp) (sl:make-button btw 25
+ :parent (sl:window frm)
+ :button-type :momentary
+ :font vlpf :label "Del Pan"
+ :ulc-x 5 :ulc-y 5)
+ ;; this button is a toggle to clear/display all objects
+ (clear-all-btn vlp) (sl:make-button btw 25
+ :parent (sl:window frm)
+ :button-type :momentary
+ :font vlpf :label "Clear All"
+ :ulc-x 5 :ulc-y 30))
+ (clx:reparent-window (sl:window obmenu) (sl:window frm) 5 60)
+ (clx:map-window (sl:window obmenu))
+ (clx:map-subwindows (sl:window obmenu))
+ ;; set the initial state of the buttons according to visibility
+ (let ((i 0)
+ (btns (sl:buttons obmenu)))
+ (when mark-prim
+ (if (visible mark-prim)
+ (sl:select-button (nth i btns) obmenu))
+ (incf i))
+ (dolist (ob oblist)
+ (if (visible (find ob prims :key #'object))
+ (sl:select-button (nth i btns) obmenu))
+ (incf i)))
+ (ev:add-notify vlp (sl:button-on (delete-btn vlp))
+ #'(lambda (pan bt)
+ (declare (ignore bt))
+ (destroy pan)))
+ (flet ((declutter-fn (pnl btn scr newset)
+ (let* ((prims (foreground (view pnl)))
+ (offset (if (find-if #'(lambda (x)
+ (typep x 'mark))
+ prims
+ :key #'object)
+ 1 0))
+ (sel (position btn (sl:buttons scr))))
+ (if (and (= offset 1) ;; points present and
+ (= sel 0)) ;; were selected
+ (dolist (gp prims)
+ (if (typep (object gp) 'mark)
+ (setf (visible gp) newset)))
+ (let ((obj (nth (- sel offset)
+ (oblist pnl))))
+ (dolist (gp prims)
+ (if (eq (object gp) obj)
+ (setf (visible gp) newset)))))
+ (funcall (refresh-fn pnl) (view pnl)))))
+ (ev:add-notify vlp (sl:button-on (clear-all-btn vlp))
+ #'(lambda (pan bt)
+ (declare (ignore pan))
+ (dolist (s (sl:buttons obmenu))
+ (if clear-all-flag
+ (sl:select-button s obmenu)
+ (sl:deselect-button s obmenu)))
+ (setf clear-all-flag (not clear-all-flag))
+ (setf (sl:on bt) nil)))
+ (ev:add-notify vlp (sl:selected obmenu)
+ #'(lambda (pan mn btn)
+ (declutter-fn pan btn mn t)))
+ (ev:add-notify vlp (sl:deselected obmenu)
+ #'(lambda (pan mn btn)
+ (declutter-fn pan btn mn nil))))))
+
+;;;--------------------------------------
+
+(defmethod destroy :before ((vlp viewlist-panel))
+
+ (sl:destroy (ob-menu vlp))
+ (sl:destroy (delete-btn vlp))
+ (sl:destroy (clear-all-btn vlp))
+ (sl:destroy (frame vlp)))
+
+;;;--------------------------------------
+
+(defmethod destroy :before ((vp view-panel))
+ ;; ensure that there are not any lingering
+ ;; background jobs for this view-panel
+
+ (when (typep (view-for vp) 'beams-eye-view)
+ (remove-bg-drr (view-for vp))
+ (when (eq 'running (drr-state (view-for vp)))
+ (setf (drr-state (view-for vp)) 'paused))
+ (setf (image-button (view-for vp)) nil))
+
+ (ev:remove-notify vp (new-position (view-for vp)))
+ (ev:remove-notify vp (new-scale (view-for vp)))
+ (ev:remove-notify vp (new-name (view-for vp)))
+ (ev:remove-notify vp (bg-toggled (view-for vp)))
+ (sl:destroy (delete-view vp))
+ (if (sl:on (plot-view vp)) (setf (sl:on (plot-view vp)) nil))
+ (sl:destroy (plot-view vp))
+ (sl:destroy (name-box vp))
+ (sl:destroy (local-bar-button vp))
+ (sl:destroy (remote-bar-button vp))
+ (sl:destroy (image-button vp))
+ (if (sl:on (fg-button vp)) (setf (sl:on (fg-button vp)) nil))
+ (sl:destroy (fg-button vp))
+ (sl:destroy (position-control vp))
+ (sl:destroy (scale-control vp))
+ (sl:destroy (window-control vp))
+ (sl:destroy (level-control vp))
+ (when (tape-measure (view-for vp))
+ (destroy (tape-measure (view-for vp))))
+ (sl:destroy (tape-measure-btn vp))
+ (let* ((win (sl:window (picture (view-for vp))))
+ (root (third (multiple-value-list (clx:query-tree win)))))
+ (clx:unmap-window win)
+ (clx:reparent-window win root 0 0))
+ (sl:destroy (view-frame vp)))
+
+;;;------------------------------------------
+;;; End.
diff --git a/prism/src/views.cl b/prism/src/views.cl
new file mode 100644
index 0000000..bd7eef7
--- /dev/null
+++ b/prism/src/views.cl
@@ -0,0 +1,556 @@
+;;;
+;;; views
+;;;
+;;; This is the implementation of Prism views and view management
+;;; machinery. It includes the view class, and the mediators required
+;;; to maintain the locator bars that reference other views in a given
+;;; view. It does not include the management of the data that
+;;; actually appear in a view, such as the image data or line graphics
+;;; rendering anatomy or beams or other stuff.
+;;;
+;;; 11-Jun-1992 I. Kalet started
+;;; 6-Nov-1992 I. Kalet/J. Unger condense set mediators into one,
+;;; eliminate intersects relation, go direct from view sets to
+;;; mediator sets. Also fix up redraw when view attributes change,
+;;; put window, level with view, not image-2d
+;;; 15-Dec-1992 I. Kalet/J. Unger reorganize refresh announcements and
+;;; events to handle pixmap as double buffer, add update-view function.
+;;; 31-Dec-1992 I. Kalet don't announce refresh-bg on origin or scale
+;;; change, make background attribute a pixmap, not a display list.
+;;; 03-Jan-1993 I. Kalet only announce refresh-bg if background-displayed
+;;; 14-Jan-1992 J. Unger modify add-intersect and delete-intersect to do
+;;; nothing when either of the view parameters are beams eye views.
+;;; 18-Jan-1993 I. Kalet move bev and locator code to separate modules
+;;; 19-Jan-1993 J. Unger modify interactive-make-view to clean up properly
+;;; 15-Feb-1993 I. Kalet init origin so table position is reasonable
+;;; 2-Mar-1993 I. Kalet init background pixmap to black, update
+;;; documentation strings.
+;;; 26-Mar-1993 I. Kalet take out declare ignore initargs for CMUCL
+;;; compatibility
+;;; 2-Apr-1993 I. Kalet more mods for CMUCL
+;;; 24-Apr-1993 I. Kalet add pan, i.e., move view origin with mouse
+;;; 23-Jul-1993 I. Kalet added initial display code, then moved it to
+;;; object-manager module.
+;;; 5-Nov-1993 I. Kalet make pan use right button, not left
+;;; 17-Nov-1993 I. Kalet change view size in interactive-make-view
+;;; from textline to menu.
+;;; 7-Jan-1994 I. Kalet use gensym to provide default view name as
+;;; for other objects
+;;; 28-Jan-1994 I. Kalet move a little bit of code here from locators
+;;; 07-Feb-1994 J. Unger add back pointer to plan to view definition.
+;;; 18-Apr-1994 I. Kalet change erase in display-view to
+;;; display-picture, also add code to synchronize locator grab boxes
+;;; with pan and zoom operations. Move some code to locators module.
+;;; Change origin slot to x-origin and y-origin slots but still
+;;; provide a setf origin method.
+;;; 2-Jun-1994 I. Kalet use constant symbols for view sizes
+;;; 30-Jun-1994 I. Kalet table-position is now at origin so put it in
+;;; middle of all views initially.
+;;; 11-Aug-1994 J. Unger remove minimum size restriction in make-view.
+;;; 28-Nov-1994 J. Unger add destroy method for views.
+;;; 12-Jan-1995 I. Kalet cache table-position in view. It is *not* a
+;;; back pointer and does not change during a prism session. Remove
+;;; plan-of back-pointer.
+;;; 21-Jan-1997 I. Kalet eliminate table-position and references to
+;;; geometry package.
+;;; 30-Apr-1997 I. Kalet remove name textline from
+;;; interactive-make-view - there is now a name textline in the view
+;;; panel.
+;;; 13-May-1998 I. Kalet fix gaff in initialization of a view - only
+;;; set the scale and origin if these slots are unbound.
+;;; 11-Jun-1998 I. Kalet use beam-for keyword in make-view calls, as
+;;; it is the slot name and has an initarg.
+;;; 12-Aug-1998 I. Kalet add event to indicate when
+;;; background-displayed is toggled.
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 4-Mar-2000 I. Kalet add long awaited support for tape measure.
+;;; 16-Jul-2000 I. Kalet add gl-buffer and image-cache for OpenGL support.
+;;; 3-Sep-2000 I. Kalet be more careful about redundant updates when
+;;; background flag toggles.
+;;; 11-Dec-2000 I. Kalet add use-gl flag to avoid crashes in plot code.
+;;; 31-Jul-2002 I. Kalet add oblique-view class
+;;; 5-Aug-2002 J. Sager add room-view class to interactive-make-view
+;;; 20-Aug-2002 J. Sager modify motion notification to change origin for
+;;; room-view class
+;;; 22-Sep-2002 I. Kalet fix up to be consistent with evolving OpenGL support
+;;; 15-Jul-2005 I. Kalet move glflush call in display-view up and
+;;; change it to glfinish to insure immediate screen update.
+;;; 3-Jan-2009 I. Kalet move all OpenGL stuff to room-views, no
+;;; longer using GL for images.
+;;; 25-May-2009 I. Kalet remove all support for room-view.
+;;;
+
+(in-package :prism)
+
+(defvar *default-view-width* 30.0 "Default view width in cm, used to
+determine initial scale.")
+
+;;;----------------------------------------------------
+
+(defclass view (generic-prism-object)
+
+ ((picture :type sl:picture
+ :accessor picture
+ :documentation "The picture part of the view, the frame
+that has the image and graphic data displayed in it along with the
+locator bars.")
+
+ (view-position :type single-float
+ :accessor view-position
+ :initarg :view-position
+ :documentation "The view-position is the x, y or z
+coordinate specifying the position of this view on the axis orthogonal
+to it.")
+
+ (new-position :accessor new-position
+ :initform (ev:make-event)
+ :documentation "Announced when the view-position is
+changed.")
+
+ (x-origin :type fixnum
+ :accessor x-origin
+ :initarg :x-origin
+ :documentation "The origin is a pair of pixel space
+coordinates that specify the location of the modeling space origin or
+projection of the origin to the picture plane.")
+
+ (y-origin :type fixnum
+ :accessor y-origin
+ :initarg :y-origin
+ :documentation "The origin is a pair of pixel space
+coordinates that specify the location of the modeling space origin or
+projection of the origin to the picture plane.")
+
+ (new-origin :accessor new-origin
+ :initform (ev:make-event)
+ :documentation "Announced when the origin of the view
+changes.")
+
+ (scale :type single-float
+ :accessor scale
+ :initarg :scale
+ :documentation "The scale factor in pixels per cm.")
+
+ (new-scale :accessor new-scale
+ :initform (ev:make-event)
+ :documentation "Announced when the scale factor is
+changed.")
+
+ (background-displayed :accessor background-displayed
+ :initarg :background-displayed
+ :documentation "Just an indicator specifying
+whether the background should be included in the view.")
+
+ (bg-toggled :accessor bg-toggled
+ :initform (ev:make-event)
+ :documentation "Announced when background-displayed is
+changed.")
+
+ (window :type fixnum ;; gray scale window
+ :accessor window
+ :initarg :window
+ :documentation "The window and level attributes determine
+what part of the range of image pixel values are assigned the
+intermediate gray level intensities.")
+
+ (level :type fixnum ;; gray scale level
+ :accessor level
+ :initarg :level
+ :documentation "See window.")
+
+ (new-winlev :accessor new-winlev
+ :initform (ev:make-event)
+ :documentation "Announced when either the window or level
+value changes.")
+
+ (foreground :accessor foreground
+ :initarg :foreground
+ :documentation "A list of graphic primitives for all
+the foreground objects displayed in the view, i.e., contours and beam
+portals.")
+
+ (background :accessor background
+ :initarg :background
+ :documentation "A pixmap containing the background
+image.")
+
+ (image-cache :accessor image-cache
+ :initform nil
+ :documentation "The gray scale mapped image pixel
+array, cached so it can be scaled and panned without recomputing the
+mapping.")
+
+ (scaled-image :accessor scaled-image
+ :initform nil
+ :documentation "A scratch array used for pan and zoom
+so we don't generate garbage on repeated operations.")
+
+ (refresh-fg :accessor refresh-fg
+ :initform (ev:make-event)
+ :documentation "Announced when everything in the view
+foreground, i.e., the foreground display list, should be redrawn.")
+
+ (locators ;; :type coll:collection
+ :accessor locators
+ :initform (coll:make-collection)
+ :documentation "The set of locator bars that appear in
+this view.")
+
+ (local-bars-on :accessor local-bars-on
+ :initarg :local-bars-on
+ :documentation "The boolean variable that indicates
+if the locator bars appear in this view.")
+
+ (remote-bars-toggled :type ev:event
+ :accessor remote-bars-toggled
+ :initform (ev:make-event)
+ :documentation "Announced when the locators
+for this view in other views should be turned on or off. The on or
+off value, t or nil, is passed as a parameter.")
+
+ (ptr-loc :type list
+ :accessor ptr-loc
+ :documentation "The location of the screen pointer in the
+window while the left mouse button is down. No need to initialize.")
+
+ (button-down :type (member t nil)
+ :accessor button-down
+ :initform nil
+ :documentation "A flag indicating that the left mouse
+button is down or up, t for down, nil for up.")
+
+ (tape-measure :accessor tape-measure
+ :initform nil
+ :documentation "A cm tape measure that appears in the
+view on demand.")
+
+ )
+
+ (:default-initargs :view-position 0.0 :background nil :foreground nil
+ :background-displayed nil :local-bars-on t
+ :window 500 :level 1024 :use-gl t)
+
+ (:documentation "The view class contains the graphics and the
+locator bars.")
+
+ )
+
+;;;-------------------------------------
+
+(defmethod initialize-instance :after ((v view) &rest initargs
+ &key pic-w pic-h mapped
+ &allow-other-keys)
+ (let* ((p (apply #'sl:make-picture
+ pic-w pic-h :mapped mapped initargs))
+ (w (sl:window p))
+ (width (clx:drawable-width w))
+ (height (clx:drawable-height w))
+ (px (clx:create-pixmap :width width
+ :height height
+ :depth (clx:drawable-depth w)
+ :drawable w)))
+ (setf (picture v) p)
+ (setf (background v) px)
+ ;; make background pixmap initially all black
+ (clx:draw-rectangle (background v) (sl:color-gc 'sl:black)
+ 0 0 width height t)
+ ;; provide a scratch array for pan and zoom
+ (setf (scaled-image v) (make-array (list width height)
+ :element-type
+ '(unsigned-byte 32)))
+ ;; this initial scale and origin only apply as a default
+ (unless (slot-boundp v 'scale)
+ (setf (scale v) (/ (float width) *default-view-width*)))
+ (unless (slot-boundp v 'x-origin)
+ (setf (origin v) (list (round (/ width 2))
+ (round (/ height 2)))))
+ ;; pointer motion with right mouse button down in view moves the
+ ;; view origin, only when background not displayed
+ (ev:add-notify v (sl:button-press p)
+ #'(lambda (vw pic code x y)
+ (declare (ignore pic))
+ (when (= code 3)
+ (setf (button-down vw) t)
+ (setf (ptr-loc vw) (list x y)))))
+ (ev:add-notify v (sl:button-release p)
+ #'(lambda (vw pic code x y)
+ (declare (ignore pic x y))
+ (if (= code 3)
+ (setf (button-down vw) nil))))
+ (ev:add-notify v (sl:motion-notify p)
+ #'(lambda (vw pic x y state)
+ (declare (ignore pic state))
+ (if (button-down vw)
+ (let ((xp (first (ptr-loc vw)))
+ (yp (second (ptr-loc vw))))
+ (setf (origin vw)
+ (list (+ (x-origin vw) (- x xp))
+ (+ (y-origin vw) (- y yp))))
+ (setf (ptr-loc vw) (list x y))))))
+ ))
+
+;;;-------------------------------------
+
+(defmethod display-view ((v view))
+
+ "refresh pixmap and window."
+
+ (let* ((pic (picture v))
+ (px (sl:pixmap pic))
+ (width (clx:drawable-width px))
+ (height (clx:drawable-height px)))
+ ;; copy background to pixmap, or erase pixmap
+ (if (background-displayed v)
+ (clx:copy-area (background v) (sl:color-gc 'sl:white)
+ 0 0 width height px 0 0)
+ (clx:draw-rectangle px (sl:color-gc 'sl:black)
+ 0 0 width height t))
+ ;; paint foreground primitives in pixmap
+ (dolist (prim (foreground v)) (draw prim v))
+ (when (tape-measure v) (draw-tape-measure-tics (tape-measure v)))
+ ;; make pixmap appear in window, refresh grab boxes and border
+ (sl:display-picture pic)
+ ))
+
+;;;--------------------------------------
+
+(defmethod (setf view-position) :after (new-pos (v view))
+
+ "Announce and make entire view regenerate and redraw."
+
+ (ev:announce v (new-position v) new-pos)
+ (ev:announce v (refresh-fg v))
+ (display-view v))
+
+;;;--------------------------------------
+
+(defmethod (setf origin) (new-org (v view))
+
+ "Takes a list, new-org, and puts the values in the right places,
+then announces and makes entire view regenerate and redraw."
+
+ (setf (x-origin v) (first new-org)
+ (y-origin v) (second new-org))
+ (when (tape-measure v) (setf (origin (tape-measure v)) new-org))
+ (ev:announce v (new-origin v) new-org)
+ (ev:announce v (refresh-fg v))
+ (display-view v))
+
+;;;--------------------------------------
+
+(defmethod (setf scale) :after (new-scl (v view))
+
+ "Announce and make entire view regenerate and redraw."
+
+ (when (tape-measure v) (setf (scale (tape-measure v)) new-scl))
+ (ev:announce v (new-scale v) new-scl)
+ (ev:announce v (refresh-fg v))
+ (display-view v))
+
+;;;--------------------------------------
+
+(defmethod (setf window) :after (new-window (v view))
+
+ (declare (ignore new-window))
+ (ev:announce v (new-winlev v))
+ (when (background-displayed v) (display-view v)))
+
+;;;--------------------------------------
+
+(defmethod (setf level) :after (new-level (v view))
+
+ (declare (ignore new-level))
+ (ev:announce v (new-winlev v))
+ (when (background-displayed v) (display-view v)))
+
+;;;--------------------------------------
+
+(defmethod (setf background-displayed) :after (displayed (v view))
+
+ (declare (ignore displayed))
+ (ev:announce v (bg-toggled v))
+ (display-view v))
+
+;;;-------------------------------------
+;;; an :after method for (setf local-bars-on) is provided in the
+;;; locators module
+;;;--------------------------------------
+
+(defun make-view (pic-w pic-h &optional (view-type 'transverse-view)
+ &rest other-initargs)
+
+ (apply #'make-instance view-type :allow-other-keys t
+ :pic-w pic-w :pic-h pic-h other-initargs))
+
+;;;-------------------------------------
+
+(defclass transverse-view (view)
+
+ ()
+
+ (:default-initargs :name "Transverse View")
+
+ (:documentation "The transverse view is a specialization of a view,
+for the x-y plane, in which view-position represents the z coordinate of
+the view.")
+
+ )
+
+;;;-------------------------------------
+
+(defclass coronal-view (view)
+
+ ()
+
+ (:default-initargs :name "Coronal View")
+
+ (:documentation "The coronal view is a specialization of a view,
+for the x-z plane, in which view-position represents the y coordinate of
+the view.")
+
+ )
+
+;;;-------------------------------------
+
+(defclass sagittal-view (view)
+
+ ()
+
+ (:default-initargs :name "Sagittal View")
+
+ (:documentation "The sagittal view is a specialization of a view,
+for the y-z plane, in which view-position represents the x coordinate of
+the view.")
+
+ )
+
+;;;-------------------------------------
+
+(defclass oblique-view (view)
+
+ ((azimuth :type single-float
+ :accessor azimuth
+ :initarg :azimuth
+ :documentation "The azimuthal rotation angle for this view.")
+
+ (altitude :type single-float
+ :accessor altitude
+ :initarg :altitude
+ :documentation "The altitude rotation for this view,
+performed after the azimuth rotation.")
+
+ )
+
+ (:default-initargs :name "Oblique view" :azimuth 0.0 :altitude 0.0)
+
+ (:documentation "An oblique view is one that can be rotated to more
+ or less any arbitrary position, like in the old UWPLAN system.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod (setf azimuth) :after (new-azi (v oblique-view))
+
+ "Announce and make entire view regenerate and redraw."
+
+ (declare (ignore new-azi))
+ (ev:announce v (refresh-fg v))
+ (display-view v))
+
+;;;--------------------------------------
+
+(defmethod (setf altitude) :after (new-alt (v oblique-view))
+
+ "Announce and make entire view regenerate and redraw."
+
+ (declare (ignore new-alt))
+ (ev:announce v (refresh-fg v))
+ (display-view v))
+
+;;;-------------------------------------
+
+(defun interactive-make-view (view-name &key beams)
+
+ "interactive-make-view view-name &key beams
+
+returns a view instance whose basic parameters are specified by the
+user through a dialog box at a nested event processing level."
+
+ (sl:push-event-level)
+ (let* ((size medium) ;; default - constant defined in prism-globals
+ (view-type 'transverse-view)
+ (vbox (sl:make-frame 375 155 :title "New view parameters"))
+ (win (sl:window vbox))
+ (ok-b (sl:make-exit-button 70 30 :parent win
+ :label "Accept"
+ :ulc-x 10 :ulc-y 10
+ :bg-color 'sl:blue))
+ (vsize (sl:make-radio-menu '("Small" "Medium" "Large")
+ :parent win
+ :ulc-x 10 :ulc-y 50))
+ (vmenu (sl:make-radio-menu
+ (if beams '("Transverse" "Coronal" "Sagittal" "Beam's Eye")
+ '("Transverse" "Coronal" "Sagittal" "Oblique"))
+ :parent win
+ :ulc-x 95 :ulc-y 10))
+ (beam-list (sl:make-radio-scrolling-list 150 135 :parent win
+ :ulc-x 215 :ulc-y 10))
+ (beam-choice nil))
+ (sl:select-button 0 vmenu) ; default - transverse
+ (sl:select-button 1 vsize) ; default - medium
+ (ev:add-notify vbox (sl:selected vsize)
+ #'(lambda (l a item)
+ (declare (ignore l a))
+ (setq size (case item
+ (0 small) ;; constants defined in
+ (1 medium) ;; prism-globals
+ (2 large)))))
+ (ev:add-notify vbox (sl:selected vmenu)
+ #'(lambda (l a item)
+ (declare (ignore l a))
+ (setq view-type
+ (case item
+ (0 'transverse-view)
+ (1 'coronal-view)
+ (2 'sagittal-view)
+ (3 (if beams 'beams-eye-view 'oblique-view))))))
+ (dolist (b beams)
+ (sl:insert-button (sl:make-list-button beam-list (name b))
+ beam-list))
+ (when beams
+ (sl:select-button (first (sl:buttons beam-list))
+ beam-list))
+ (sl:process-events)
+ (when (eql view-type 'beams-eye-view) ; do this before the beam-list
+ (setq beam-choice ; is destroyed
+ (find (sl:label (find-if #'sl:on (sl:buttons beam-list)))
+ beams
+ :key #'name)))
+ ;; don't neet to ev:remove-notify: all controls are destroyed anyway
+ (sl:destroy vmenu)
+ (sl:destroy beam-list)
+ (sl:destroy vsize)
+ (sl:destroy ok-b)
+ (sl:destroy vbox)
+ (sl:pop-event-level)
+ (make-view size size view-type
+ :name (if (equal "" view-name) (symbol-name view-type)
+ view-name)
+ :beam-for beam-choice)))
+
+;;;---------------------------------------
+
+(defmethod destroy ((vw view))
+
+ "destroy (vw view)
+
+Deallocates resources associated with a view. The locators are
+destroyed elsewhere."
+
+ (setf (image-cache vw) nil)
+ (clx:free-pixmap (background vw))
+ (sl:destroy (picture vw)))
+
+;;;---------------------------------------
+;;; End.
diff --git a/prism/src/volume-editor.cl b/prism/src/volume-editor.cl
new file mode 100644
index 0000000..65edd4f
--- /dev/null
+++ b/prism/src/volume-editor.cl
@@ -0,0 +1,1120 @@
+;;;
+;;; volume-editor
+;;;
+;;; The volume-editor is a drawing panel used to create and
+;;; modify collections of organs, tumors and targets, plane by plane.
+;;; It also handles points or marks that are not part of a contour, a
+;;; task formerly handled separately by a 3d-point-editor. The common
+;;; code was formerly in a separate module called the easel. The
+;;; revision history of both is merged here.
+;;;
+;;; 10-Jul-1992 I. Kalet start and make many changes
+;;; 2-Jul-1993 I. Kalet eliminate filmstrip ref view.
+;;; 28-Jul-1993 J. Unger add name textline, make empty easel have at
+;;; least one fs frame, redraw other contours in ce for new-scale.
+;;; 31-Jul-1993 I. Kalet announce new-contours when updating the
+;;; contours list in the pstruct being edited.
+;;; 2-Aug-1993 J. Unger change color of contour in ce when organ
+;;; color is changed by user. Fix CCNP bug (blew up if no contour to
+;;; copy), modify color-btn add-notify to change color of ce contour.
+;;; 14-Oct-1993 I. Kalet move name and color to attribute editor, also
+;;; cosmetic fixes in code
+;;; 26-Oct-1993 I. Kalet coerce numeric data from z textline to float,
+;;; and use mini-image-set cache from patient instead of computing
+;;; them here.
+;;; 28-Dec-1993 I. Kalet efficiency mods - eliminate ce-image-cache,
+;;; other extra steps. Add support for larger contour editor with images.
+;;; 10-Mar-1994 I. Kalet fix problem with regenerating NIL for deleted
+;;; contours, change call to draw for pixmaps into function call to
+;;; either draw-lines-pix or draw-image-pix
+;;; 17-Mar-1994 I. Kalet fix CCNP to ignore current plane
+;;; 12-May-1994 I. Kalet update raw image in contour editor to reflect
+;;; gray scale, not really raw image data.
+;;; 17-May-1994 I. Kalet add new-org parameter to new-origin action fn.
+;;; 29-May-1994 I. Kalet split off from old easel to eliminate
+;;; redundant code with point editor.
+;;; 30-May-1994 I. Kalet retain common code in easel, put rest into
+;;; volume-editor, to eliminate redundancy with 3d-point-editor, add
+;;; new-z event to control circularity at this level. Make
+;;; draw-lines-pix into a generic function draw-pix. Set new pan-zoom
+;;; flag, not the image slot in the planar editor.
+;;; 2-Jun-1994 J. Unger add update-case announcement w/ new-contours.
+;;; 5-Jun-1994 J. Unger announce new-contours if the 'delete contour'
+;;; button is pressed.
+;;; 8-Jun-1994 I. Kalet take out grayscale mapping of data for
+;;; autocontour for now, also move attribute editor and buttons down,
+;;; add slice no. register.
+;;; 8-Jan-1995 I. Kalet destroy slice-no textline too.
+;;; 13-Jan-1995 I. Kalet made background pixmap here, so free it here.
+;;; 10-Sep-1995 I. Kalet make *esl-default-pe-scale* a float, not fix
+;;; 21-Jan-1997 I. Kalet eliminate refs to geometry package, use
+;;; macros in misc instead.
+;;; 2-Mar-1997 I. Kalet update calls to NEARLY- functions, change
+;;; title bar to read "Prism volume editor". Change back to making a
+;;; mapped raw image for autocontour in the contour editor, instead
+;;; of unmapped.
+;;; 22-Jun-1997 I. Kalet reduce globals usage, move CCNP button to easel
+;;; from volume-editor, other mods to allow changing volume selected
+;;; within the volume editor. Make scale in PE default, no global,
+;;; get value from PE when needed (this means, make the PE before
+;;; using the scale value).
+;;; 24-Jun-1997 I. Kalet don't use global params, turn on Accept
+;;; button on Delete Contour, move organ, tumor and target selector
+;;; panels here from patient panel, add an immob-dev slot for PTV, add
+;;; a method for planar-editor-vertices, to be used in CCNP action,
+;;; register CCNP action here, needs contours of selected volume, make
+;;; sure filmstrip updates when pstruct added or deleted.
+;;; 3-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx.
+;;; 14-Jan-1998 I. Kalet move a bunch of filmstrip stuff to there, use
+;;; simpler interface to filmstrip, fix copy from nearest plane code.
+;;; 27-Jan-1998 I. Kalet modifications for new organization of
+;;; filmstrip, new names for adding, deleting contours, etc. Also,
+;;; fix up copy contour from nearest plane.
+;;; 4-Jun-1998 I. Kalet make local-make-target default to manual if
+;;; the user presses the Cancel button.
+;;; 25-Jun-1998 I. Kalet move free-pixmap for PE background to :after
+;;; method for destroy. Also protect Copy NP from crash when there
+;;; are no contours to copy.
+;;; 11-Mar-1999 I. Kalet adjustments to accomodate sliderboxes for
+;;; window and level controls instead of textlines.
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 5-Jan-2000 I. Kalet use new index-format parameter in
+;;; make-filmstrip, relax plane match criterion for display.
+;;; 2-Apr-2000 I. Kalet reset slice-no textline to blank when invalid
+;;; slice number is entered.
+;;; 12-Apr-2000 I. Kalet incorporate some of Lee Zeman's work on
+;;; extended automatic contour generation. Shrink button height to
+;;; make room for more controls.
+;;; 9-May-2000 I. Kalet continuing work on extended autocontour.
+;;; 28-May-2000 I. Kalet parametrize small font.
+;;; 27-Jun-2000 I. Kalet parametrize format of display of z values
+;;; 20-Jul-2000 I. Kalet use OpenGL to display images, instead of CLX,
+;;; don't disable pan and zoom in planar editor, modify setf pe-image
+;;; to set new slots for contour-editor to handle magnified image display
+;;; 2-Dec-2000 I. Kalet move select-1 to selector-panels
+;;; 28-Jan-2001 I. Kalet correct coding error in use of textlines for
+;;; zplus and zminus limits, in auto-extend subpanel and
+;;; generate-extended-contours.
+;;; 11-Mar-2001 I. Kalet set initial values of zplus and zminus in
+;;; auto-extend panel based on extrema of image Z values.
+;;; 6-Jan-2002 I. Kalet In CCNP, use nearest from misc instead of
+;;; nearest-z from easel (gone).
+;;; 14-Feb-2002 I. Kalet extend allowed slice numbers to 500
+;;; 22-Feb-2004 I. Kalet merge point editor functionality here, and
+;;; re-merge with easel instead of separate panel and modules. Add
+;;; point sorting, like beam sorting. Move auto-extend-panel code to
+;;; separate module.
+;;;----------------- merged revision history from easel --------------
+;;; 26-Oct-1993 I. Kalet coerce numeric data from z textline to float,
+;;; and use mini-image-set cache from patient instead of computing
+;;; them here.
+;;; 28-Dec-1993 I. Kalet efficiency mods - eliminate ce-image-cache,
+;;; other extra steps. Add support for larger contour editor with images.
+;;; 10-Mar-1994 I. Kalet fix problem with regenerating NIL for deleted
+;;; contours, change call to draw for pixmaps into function call to
+;;; either draw-lines-pix or draw-image-pix
+;;; 17-Mar-1994 I. Kalet fix CCNP to ignore current plane
+;;; 12-May-1994 I. Kalet update raw image in contour editor to reflect
+;;; gray scale, not really raw image data.
+;;; 17-May-1994 I. Kalet add new-org parameter to new-origin action fn.
+;;; 30-May-1994 I. Kalet retain common code, put rest into
+;;; volume-editor, to eliminate redundancy with 3d-point-editor, add
+;;; new-z event to control circularity at this level. Make
+;;; draw-lines-pix into a generic function draw-pix. Set new pan-zoom
+;;; flag, not the image slot in the planar editor.
+;;; 22-Jun-1997 I. Kalet reduce globals usage, move CCNP button here
+;;; from volume-editor, other mods to allow changing volume selected
+;;; within the volume editor. Make scale in PE default, no global,
+;;; get value from PE when needed (this means, make the PE before
+;;; using the scale value).
+;;; 14-Feb-2002 I. Kalet extend allowed slice numbers to 500
+;;;-------------------------------------------------------------------
+;;; 17-May-2004 I. Kalet continuing overhaul. Move update-pstruct to
+;;; autovolume to remove circularity. Add fimlstrip as input to
+;;; make-auto-extend-panel call
+;;; 24-Jan-2005 I. Kalet change make-contour-editor to
+;;; make-planar-editor, and other changes for the overhaul.
+;;; 12-May-2005 I. Kalet finish (setf volume), start on (setf point)
+;;; 25-Aug-2005 I. Kalet continue to finish up loose ends.
+;;; 22-Jun-2007 I. Kalet add action for point selected in planar
+;;; editor - just select the corresponding button in the point selector
+;;; 3-Jan-2009 I. Kalet modify write-pe-background to use
+;;; write-image-clx instead of write-image-gl, remove gl-buffer and
+;;; add a slot for a scratch array for computing pan and zoom.
+;;; 1-Jun-2009 I. Kalet use original images, not mini-images, in filmstrip
+;;; 18-Jun-2009 I. Kalet clean up interface to auto-extend-panel
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------
+
+(defclass volume-editor (generic-panel)
+
+ ((bg-vols :type list
+ :accessor bg-vols
+ :initarg :bg-vols
+ :documentation "All the pstructs appearing in the
+background of the point editor and filmstrip.")
+
+ (images :type list
+ :accessor images
+ :initarg :images
+ :documentation "The image study, a list of image-2D's, to
+serve as backgrounds for the planar editor drawing region and the
+filmstrip frames.")
+
+ (window :type fixnum
+ :accessor window
+ :initarg :window
+ :documentation "The grayscale window width of the image in
+the planar editor's background.")
+
+ (level :type fixnum
+ :accessor level
+ :initarg :level
+ :documentation "The grayscale level value or center of the
+window of the image in the planar editor's background.")
+
+ (pe :type planar-editor
+ :accessor pe
+ :documentation "The planar editor associated with this easel.")
+
+ (fs :type filmstrip
+ :accessor fs
+ :documentation "The filmstrip associated with this easel.")
+
+ (z :type single-float
+ :accessor z
+ :initform 0.0 ;; need an initial value here, does not matter what
+ :documentation "The z coordinate in real space to which the
+easel is set.")
+
+ (new-z :type ev:event
+ :accessor new-z
+ :initform (ev:make-event)
+ :documentation "Announced when the z attribute changes.")
+
+ (z-tln ;; :type sl:textline
+ :accessor z-tln
+ :documentation "The SLIK textline displaying the z value for
+the current editing plane.")
+
+ (slice-no :accessor slice-no
+ :documentation "The textline displaying the CT image
+slice number of the currently displayed image.")
+
+ (busy :type (member t nil)
+ :accessor busy
+ :initform nil
+ :documentation "The flag to control circularity among z
+value, content of z textline, slice-no and index in filmstrip.")
+
+ (pe-image :type image-2D
+ :accessor pe-image
+ :initform nil ;; can't start out with slot unbound
+ :documentation "The image to appear in the background of
+the planar editor at the specified z level. Could be a different size
+than the images in the list.")
+
+ (image-cache :accessor image-cache
+ :initform nil
+ :documentation "A pixel array produced by mapping the
+current background image, if any, using the current window and level
+values. Saves a lot of computing when changing scale or background
+data and recomputing the image is not needed.")
+
+ (scaled-image :accessor scaled-image
+ :documentation "A pixel array used to compute a
+temporary scaled image before writing it to the background clx pixmap.")
+
+ (pe-volume-prims :type list
+ :accessor pe-volume-prims
+ :documentation "A list of graphic primitives
+corresponding to the background contours to appear along with the
+image in the planar editor background at the specified z level.")
+
+ (pe-point-prims :type list
+ :accessor pe-point-prims
+ :documentation "A list of graphic primitives
+corresponding to the background points to appear along with the image
+and contours in the planar editor background at the specified z level.")
+
+ (fr :type sl:frame
+ :accessor fr
+ :documentation "The SLIK frame that contains the easel.")
+
+ (del-pnl-btn ;; :type sl:button
+ :accessor del-pnl-btn
+ :documentation "The delete panel button for the easel
+panel.")
+
+ (window-control :accessor window-control
+ :documentation "The textline that displays and sets
+the window for the current editing plane.")
+
+ (level-control :accessor level-control
+ :documentation "The textline that displays and sets
+the level for the current editing plane.")
+
+ (cpy-pts-btn ;; :type sl:button
+ :accessor cpy-pts-btn
+ :documentation "The copy points from nearest plane
+button.")
+
+ (immob-dev :accessor immob-dev
+ :initarg :immob-dev
+ :documentation "A copy of the immob-dev slot in the
+patient, for use in the PTV tool, and kept consistent by a little one
+way event registration when the panel is created.")
+
+ (organ-coll :accessor organ-coll
+ :initarg :organ-coll
+ :documentation "The collection of anatomic volumes from
+the patient case.")
+
+ (tumor-coll :accessor tumor-coll
+ :initarg :tumor-coll
+ :documentation "The collection of tumor volumes from
+the patient case.")
+
+ (target-coll :accessor target-coll
+ :initarg :target-coll
+ :documentation "The collection of target volumes from
+the patient case.")
+
+ (point-coll :accessor point-coll
+ :initarg :point-coll
+ :documentation "The collection of points from the
+ patient case.")
+
+ (volume :type pstruct
+ :accessor volume
+ :initarg :volume
+ :initform nil
+ :documentation "The contoured volume currently being
+edited. It is represented by data in real space, i.e., coordinates in
+cm, not in pixels.")
+
+ (point :accessor point
+ :initarg :point
+ :initform nil
+ :documentation "The point that is the current editor focus,
+ selected from the points selector panel.")
+
+ (del-con-btn :accessor del-con-btn
+ :documentation "The delete contour button.")
+
+ (extend-btn :accessor extend-btn
+ :documentation "The button that puts up the auto-extend
+subpanel for doing a whole series of autocontouring.")
+
+ (auto-extend-subpanel :accessor auto-extend-subpanel
+ :initform nil
+ :documentation "The subpanel that provides
+entry of data for extended autocontouring.")
+
+ (organ-selector :accessor organ-selector
+ :documentation "The selector panel listing the
+organs in the patient.")
+
+ (tumor-selector :accessor tumor-selector
+ :documentation "The selector panel listing the
+tumor volumes in the patient.")
+
+ (target-selector :accessor target-selector
+ :documentation "The selector panel listing the
+target volumes in the patient.")
+
+ (point-selector :accessor point-selector
+ :documentation "The selector panel listing the
+ points in the patient.")
+
+ )
+
+ (:default-initargs :window 500 :level 1024 :bg-vols nil)
+
+ (:documentation "The volume editor includes everything needed to
+create and edit all the contoured volumes and points of interest in a
+patient, from an image study.")
+
+ )
+
+;;;----------------------------------
+
+(defun write-pe-background (vol-ed)
+
+ "write-pe-background vol-ed
+
+Renders the current image or writes a black pixmap into the planar
+editor background, and draws the graphics primitives from the other
+volumes and the points on top."
+
+ (let* ((im (pe-image vol-ed))
+ (pe (pe vol-ed))
+ (px (background pe)))
+ (if (image-cache vol-ed)
+ (let* ((im-ppcm (pix-per-cm im))
+ (mag (/ (scale pe) im-ppcm))
+ (im-x0 (- (round (* (vx (origin im)) im-ppcm))))
+ (im-y0 (round (* (vy (origin im)) im-ppcm)))
+ (x0 (- im-x0 (/ (x-origin pe) mag)))
+ (y0 (- im-y0 (/ (y-origin pe) mag))))
+ (scale-image (image-cache vol-ed)
+ (scaled-image vol-ed) ;; scratch array to avoid gc
+ mag x0 y0)
+ (sl:write-image-clx (scaled-image vol-ed) px))
+ (clx:draw-rectangle px (sl:color-gc 'sl:black) 0 0
+ (clx:drawable-width px)
+ (clx:drawable-height px) t))
+ (dolist (prim (pe-volume-prims vol-ed)) (draw-pix prim px))
+ (if (and (volume vol-ed) (not (point vol-ed)))
+ (dolist (prim (pe-point-prims vol-ed)) (draw-pix prim px)))))
+
+;;;----------------------------------
+
+(defun compute-volume-prims (vol-ed)
+
+ "compute-volume-prims vol-ed
+
+Computes the graphic primitives for the other-pstructs to be drawn in
+the planar editor background."
+
+ (let* ((pe (pe vol-ed))
+ (xorig (x-origin pe))
+ (yorig (y-origin pe))
+ (ppcm (scale pe))
+ (z (z vol-ed)))
+ (declare (fixnum xorig yorig) (single-float ppcm z))
+ (setf (pe-volume-prims vol-ed)
+ (mapcar #'(lambda (vol)
+ (let ((prim (make-lines-prim
+ nil (sl:color-gc (display-color vol))
+ :object vol)))
+ (dolist (con (contours vol) prim)
+ (when (poly:nearly-equal (z con) z
+ *display-epsilon*)
+ (draw-transverse (vertices con)
+ prim xorig yorig ppcm)))))
+ (bg-vols vol-ed)))))
+
+;;;----------------------------------
+
+(defun compute-point-prims (vol-ed)
+
+ "compute-point-prims vol-ed
+
+computes the graphic primitives for the points to be drawn in the
+planar editor background."
+
+ (let* ((pe (pe vol-ed))
+ (xorig (x-origin pe))
+ (yorig (y-origin pe))
+ (ppcm (scale pe))
+ (z (z vol-ed)))
+ (declare (fixnum xorig yorig) (single-float ppcm z))
+ (setf (pe-point-prims vol-ed)
+ (apply #'append
+ (mapcar #'(lambda (pt)
+ (if (poly:nearly-equal (z pt) z
+ *display-epsilon*)
+ (let* ((color(sl:color-gc (display-color pt)))
+ (s-prim (make-segments-prim
+ nil color :object pt))
+ (c-prim (make-characters-prim
+ (write-to-string (id pt))
+ nil nil color :object pt)))
+ (multiple-value-bind
+ (hatchmarks x-anchor y-anchor)
+ (pixel-point (x pt) (y pt)
+ ppcm xorig yorig)
+ (setf (points s-prim) hatchmarks)
+ (setf (x c-prim) x-anchor)
+ (setf (y c-prim) y-anchor))
+ (list s-prim c-prim))))
+ (coll:elements (point-coll vol-ed)))))))
+
+;;;----------------------------------
+
+(defmethod (setf z) :after (new-z (vol-ed volume-editor))
+
+ "Updates the background image and graphics, also updates the z
+ textline, the slice no. textline, and the contour editor vertices
+ from the current volume."
+
+ (setf (pe-image vol-ed) (find new-z (images vol-ed)
+ :key #'(lambda (img) (vz (origin img)))
+ :test #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*))))
+ (compute-volume-prims vol-ed)
+ (compute-point-prims vol-ed)
+ (write-pe-background vol-ed)
+ (setf (sl:info (z-tln vol-ed)) (format nil *display-format* new-z))
+ (setf (sl:info (slice-no vol-ed)) ;; put up slice number
+ (if (pe-image vol-ed) (id (pe-image vol-ed)) "")) ;; or blank
+ (ev:announce vol-ed (new-z vol-ed) new-z)
+ (setf (vertices (pe vol-ed))
+ (if (volume vol-ed) (aif (find new-z (contours (volume vol-ed))
+ :key #'z
+ :test #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*)))
+ (vertices it))
+ (remove new-z (coll:elements (point-coll vol-ed))
+ :key #'z
+ :test-not #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*))))))
+
+;;;----------------------------------
+
+(defmethod (setf volume) :before (new-vol (vol-ed volume-editor))
+
+ "Disconnects the old volume, if necessary."
+
+ (let ((old-vol (volume vol-ed)))
+ (when old-vol
+ (unless new-vol
+ (setf (contour-mode (pe vol-ed)) nil))
+ (ev:remove-notify vol-ed (new-color old-vol))
+ ;; Find old-vol in organs, tumors or targets and deselect
+ ;; it, if it is in a different collection. Within the same
+ ;; collection, the radio selector panel already does it.
+ ;; This will destroy the old attribute editor for that volume.
+ (unless (eq (type-of old-vol) (type-of new-vol))
+ (let ((sp (typecase old-vol
+ (organ (organ-selector vol-ed))
+ (tumor (tumor-selector vol-ed))
+ (target (target-selector vol-ed)))))
+ (sl:deselect-button (button-for old-vol sp)
+ (scroll-list sp)))))))
+
+;;;----------------------------------
+
+(defmethod (setf volume) :after (new-vol (vol-ed volume-editor))
+
+ "Updates the planar editor background and vertices, and connections
+to the new volume if there is one, after the old one has been
+deselected. The selector panel creates and places the attribute editor."
+
+ (setf (bg-vols vol-ed)
+ (remove new-vol (append (coll:elements (organ-coll vol-ed))
+ (coll:elements (tumor-coll vol-ed))
+ (coll:elements (target-coll vol-ed)))))
+ (compute-volume-prims vol-ed)
+ (compute-point-prims vol-ed)
+ (if new-vol
+ (progn
+ (write-pe-background vol-ed)
+ (setf (color (pe vol-ed)) (sl:color-gc (display-color new-vol)))
+ (ev:add-notify vol-ed (new-color new-vol)
+ #'(lambda (eas vol col)
+ (let ((col-gc (sl:color-gc col)))
+ (setf (color (pe eas)) col-gc)
+ (fs-set-color vol col-gc (fs eas)))))
+ (let ((temp-con (find (z vol-ed) (contours new-vol)
+ :key #'z
+ :test #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*)))))
+ (setf (vertices (pe vol-ed))
+ (if temp-con (vertices temp-con) nil))))
+ (setf (vertices (pe vol-ed)) nil)))
+
+;;;----------------------------------
+
+(defmethod (setf point) :before (new-pt (vol-ed volume-editor))
+
+ "Disconnects the old point, if necessary."
+
+ (let ((old-pt (point vol-ed)))
+ (when old-pt
+ (ev:remove-notify vol-ed (new-color old-pt))
+ (when (not new-pt)
+ ;; going from point to volume, so need to...
+ (setf (contour-mode (pe vol-ed)) t)
+ (sl:deselect-button (button-for old-pt
+ (point-selector vol-ed))
+ (scroll-list (point-selector vol-ed)))))))
+
+;;;----------------------------------
+
+(defmethod (setf point) :after (new-pt (vol-ed volume-editor))
+
+ "Updates the planar editor background and vertices, and connections
+to the new point, if there is one, after the old one has been
+deselected. The selector panel creates and places the attribute editor."
+
+ (compute-point-prims vol-ed)
+ (if new-pt
+ (progn
+ (write-pe-background vol-ed)
+ (setf (color (pe vol-ed)) (sl:color-gc (display-color new-pt)))
+ (ev:add-notify vol-ed (new-color new-pt)
+ #'(lambda (eas pt col)
+ (let ((col-gc (sl:color-gc col)))
+ (setf (color (pe eas)) col-gc)
+ (fs-set-color pt col-gc (fs eas)))))
+ (setf (vertices (pe vol-ed))
+ (remove (z vol-ed) (coll:elements (point-coll vol-ed))
+ :key #'z
+ :test-not #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*)))))
+ (setf (vertices (pe vol-ed)) nil)))
+
+;;;----------------------------------
+
+(defmethod (setf pe-image) :after (new-image (vol-ed volume-editor))
+
+ "sets the image cache to the gray mapped version of the new image,
+or nil, and updates the contour editor with the new image data"
+
+ (setf (image-cache vol-ed)
+ (if new-image (sl:map-image (sl:make-graymap (window vol-ed)
+ (level vol-ed)
+ (range new-image))
+ (pixels new-image))
+ nil))
+ (let ((pe (pe vol-ed)))
+ (if new-image
+ (progn
+ (setf (image pe)
+ ;; without mapping, just (pixels new-image) here, make the
+ ;; type of the image slot in the contour-editor
+ ;; (unsigned-byte 16) and comment out the (setf window) and
+ ;; (setf level) after methods below.
+ ;; With mapping the image slot in the contour editor should
+ ;; be (unsigned-byte 8) and the setf methods are needed.
+ (sl:map-raw-image (pixels new-image)
+ (window vol-ed)
+ (level vol-ed)
+ (range new-image)
+ (image (pe vol-ed))))
+ (setf (img-x0 pe) (- (round (* (vx (origin new-image))
+ (pix-per-cm new-image))))
+ (img-y0 pe) (round (* (vy (origin new-image))
+ (pix-per-cm new-image)))
+ (img-ppcm pe) (pix-per-cm new-image)))
+ (setf (image pe) nil))))
+
+;;;----------------------------------
+;;; the following function should also handle updating the filmstrip images
+;;;----------------------------------
+
+(defun window-level-update (vol-ed)
+
+ "updates the image cache and the displayed image in the planar editor"
+
+ (let ((im (pe-image vol-ed)))
+ (when im
+ (setf (image-cache vol-ed) ;; used for display
+ (sl:map-image (sl:make-graymap (window vol-ed) (level vol-ed)
+ (range im))
+ (pixels im)))
+ (write-pe-background vol-ed)
+ (display-planar-editor (pe vol-ed))
+ (setf (image (pe vol-ed)) ;; used by autocontour
+ (sl:map-raw-image (pixels im) (window vol-ed) (level vol-ed)
+ (range im) (image (pe vol-ed)))))))
+
+;;;----------------------------------
+
+(defmethod (setf window) :after (new-window (vol-ed volume-editor))
+
+ (declare (ignore new-window))
+ (window-level-update vol-ed))
+
+(defmethod (setf level) :after (new-level (vol-ed volume-editor))
+
+ (declare (ignore new-level))
+ (window-level-update vol-ed))
+
+;;;----------------------------------
+
+(defun update-points (pt-pan new-points)
+
+ "update-points pt-pan new-points
+
+Updates the points in the point collection at the current z value in
+the point editor panel pt-pan (old points), from the list of
+new-points which were returned from editing. Each old point for which
+there is a point in new-points with the same ID attribute, is updated
+from the new one. Each old point with no corresponding point on
+new-points (same ID), is deleted from the point collection. Each
+point in new-points with no corresponding old point of the same ID, is
+added to the point collection. This function also maintains the
+scrolling list of buttons in the panel."
+
+ (let* ((point-coll (point-coll pt-pan))
+ (old-points (remove (z pt-pan) (coll:elements point-coll)
+ :key #'z
+ :test-not #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*)))))
+ (dolist (old old-points)
+ (let ((new (find (id old) new-points :key #'id)))
+ ;; don't assign values over if they haven't changed - minimizes
+ ;; screen refreshes & dose pt invalidation triggered by new-loc
+ ;; announcements
+ (if new
+ (progn
+ (unless (poly:nearly-equal (x old) (x new))
+ (setf (x old) (x new)))
+ (unless (poly:nearly-equal (y old) (y new))
+ (setf (y old) (y new)))
+ (unless (poly:nearly-equal (z old) (z new))
+ (setf (z old) (z new)))
+ (unless (string= (name old) (name new))
+ (setf (name old) (name new)))
+ (unless (eq (display-color old) (display-color new))
+ (setf (display-color old) (display-color new))))
+ (coll:delete-element old point-coll))))
+ (dolist (new new-points)
+ (unless (find (id new) old-points :key #'id)
+ (coll:insert-element new point-coll)))))
+
+;;;----------------------------------
+
+(defmethod initialize-instance :after ((vol-ed volume-editor)
+ &rest initargs
+ &key width &allow-other-keys)
+
+ "Initializes the user interface for the volume editor panel."
+
+ (let* ((img-size *easel-size*)
+ (btw 150) ;; button width
+ (bth 25) ;; button height
+ (smf (symbol-value *small-font*)) ;; the value, not the symbol
+ (dx 5) ;; margin and spacing
+ (fsh (+ *mini-image-size* bth)) ;; filmstrip height
+ (frm (apply #'sl:make-frame
+ ;; allow width to be supplied, if not, use default
+ (if width width (+ *easel-size* btw (* 2 dx)))
+ ;; in height, allow for planar editor controls
+ (+ *easel-size* fsh bth (* 2 dx))
+ :font smf :title "Prism Volume Editor" initargs))
+ (frm-win (sl:window frm))
+ (frm-width (sl:width frm))
+ (start-y (+ fsh dx))
+ (del-pnl-b (apply #'sl:make-button (- (/ btw 2) 3) bth
+ :parent frm-win :font smf
+ :ulc-x dx :ulc-y start-y
+ :label "Del Pan"
+ :button-type :momentary
+ initargs))
+ (z-t (apply #'sl:make-textline (- (/ btw 2) 2) bth
+ :parent frm-win :font smf
+ :ulc-x (+ dx (/ btw 2) 2) :ulc-y start-y
+ :label "Z: "
+ :numeric t :lower-limit -100.0 :upper-limit 100.0
+ initargs))
+ (slice-t (apply #'sl:make-textline btw bth
+ :parent frm-win :font smf
+ :ulc-x dx :ulc-y (bp-y start-y bth 1)
+ :label "Slice no: "
+ :numeric t :lower-limit 0 :upper-limit 500
+ initargs))
+ (win-sl (apply #'sl:make-sliderbox
+ btw bth 1.0 2047.0 9999.0
+ :parent frm-win :font smf
+ :label "Win: "
+ :ulc-x (- dx 5) :ulc-y (- (bp-y start-y bth 2) 5)
+ :border-width 0 :display-limits nil
+ initargs))
+ (lev-sl (apply #'sl:make-sliderbox
+ btw bth 1.0 4095.0 9999.0
+ :parent frm-win :font smf
+ :label "Lev: "
+ :ulc-x (- dx 5) :ulc-y (- (bp-y start-y bth 4) 5)
+ :border-width 0 :display-limits nil
+ initargs))
+ (del-con-b (apply #'sl:make-button (- (/ btw 2) 3) bth
+ :parent frm-win :font smf
+ :ulc-x dx :ulc-y (bp-y start-y bth 6)
+ :label "Del Cont" :button-type :momentary
+ initargs))
+ (cpy-b (apply #'sl:make-button (- (/ btw 2) 2) bth
+ :parent frm-win :font smf
+ :ulc-x (+ dx (/ btw 2) 2) :ulc-y (bp-y start-y bth 6)
+ :label "Copy NP" :button-type :momentary
+ initargs))
+ (extend-con-b (apply #'sl:make-button btw bth
+ :parent frm-win :font smf
+ :ulc-x dx :ulc-y (bp-y start-y bth 7)
+ :label "Extended Auto Mode"
+ initargs))
+ (sp-width 150) ;; size parameters for selector panels
+ (sp-height 175)) ;; ...not the same everywhere
+ (setf (fr vol-ed) frm
+ (del-pnl-btn vol-ed) del-pnl-b
+ (z-tln vol-ed) z-t
+ (slice-no vol-ed) slice-t
+ (window-control vol-ed) win-sl
+ (level-control vol-ed) lev-sl
+ (del-con-btn vol-ed) del-con-b
+ (cpy-pts-btn vol-ed) cpy-b
+ (extend-btn vol-ed) extend-con-b)
+ (setf (fs vol-ed)
+ (make-filmstrip (clx:drawable-width frm-win) fsh
+ :parent frm-win
+ :images (images vol-ed)
+ :window (window vol-ed)
+ :level (level vol-ed)
+ :index-format *display-format*))
+ (ev:add-notify vol-ed (sl:button-on del-pnl-b)
+ #'(lambda (vol-ed a)
+ (declare (ignore a))
+ (destroy vol-ed)))
+ (ev:add-notify vol-ed (new-index (fs vol-ed))
+ #'(lambda (vol-ed a fs-z)
+ (declare (ignore a))
+ (unless (busy vol-ed)
+ (setf (busy vol-ed) t)
+ (setf (z vol-ed) fs-z)
+ (setf (busy vol-ed) nil))))
+ (ev:add-notify vol-ed (new-z vol-ed)
+ #'(lambda (vol-ed a zz)
+ (declare (ignore a))
+ (unless (busy vol-ed)
+ (setf (busy vol-ed) t)
+ (setf (index (fs vol-ed)) zz)
+ (setf (busy vol-ed) nil))))
+ (ev:add-notify vol-ed (sl:new-info z-t)
+ #'(lambda (vol-ed a info)
+ (declare (ignore a))
+ (setf (z vol-ed) (coerce (read-from-string info)
+ 'single-float))))
+ (ev:add-notify vol-ed (sl:new-info slice-t)
+ #'(lambda (vol-ed a info)
+ (declare (ignore a))
+ (let* ((sn (read-from-string info))
+ (im (find sn (images vol-ed) :key #'id)))
+ (if im (setf (z vol-ed) (vz (origin im)))
+ (progn
+ (sl:acknowledge "No such slice number")
+ (setf (sl:info (slice-no vol-ed)) ""))))))
+ (setf (sl:setting (window-control vol-ed))
+ (coerce (window vol-ed) 'single-float))
+ (ev:add-notify vol-ed (sl:value-changed (window-control vol-ed))
+ #'(lambda (pan wc win)
+ (declare (ignore wc))
+ (setf (window pan) (round win))))
+ (setf (sl:setting (level-control vol-ed))
+ (coerce (level vol-ed) 'single-float))
+ (ev:add-notify vol-ed (sl:value-changed (level-control vol-ed))
+ #'(lambda (pan lc lev)
+ (declare (ignore lc))
+ (setf (level pan) (round lev))))
+ ;; make up local functions for use with selector panels
+ (flet ((make-vol-panel (vol) ;; works for all three types
+ ;; order here is important - remove old, set new
+ (if (point vol-ed) (setf (point vol-ed) nil))
+ (setf (volume vol-ed) vol)
+ (make-attribute-editor vol
+ :parent frm-win :font smf
+ :width btw
+ :ulc-x dx :ulc-y 485))
+ (make-point-panel (pt)
+ ;; order here is important - remove old, set new
+ (if (volume vol-ed) (setf (volume vol-ed) nil))
+ (setf (point vol-ed) pt)
+ (if (not (poly:nearly-equal (z pt) (z vol-ed)))
+ (setf (z vol-ed) (z pt)))
+ (make-attribute-editor pt
+ :parent frm-win :font smf
+ :width btw
+ :ulc-x dx :ulc-y 485))
+ (local-make-target (name) ;; easier to read if here
+ (let ((choice 0)
+ (tumors (coll:elements (tumor-coll vol-ed))))
+ (when (and tumors
+ (some #'(lambda (tum)
+ (> (length (contours tum)) 1))
+ tumors))
+ (setq choice
+ (sl:popup-menu '("Manual editing with easel"
+ "Tri-Linear expansion"
+ "Planning Target Volume Tool")
+ :title "Target initialization")))
+ (case choice
+ ((0 nil) (make-target name))
+ (1 (make-lin-expanded-target (tumor-coll vol-ed)))
+ (2 (make-ptv-expanded-target (immob-dev vol-ed)
+ (organ-coll vol-ed)
+ (tumor-coll vol-ed))))))
+ (local-make-point (name)
+ (prog1 (make-point name :x 0.0 :y 0.0 :z (z vol-ed)
+ :id (next-mark-id (pe vol-ed)))
+ (incf (next-mark-id (pe vol-ed))))))
+ (setf (organ-selector vol-ed)
+ (make-selector-panel sp-width sp-height
+ "Add an organ" (organ-coll vol-ed)
+ #'make-organ
+ #'make-vol-panel
+ :parent frm-win
+ :use-color t :radio t
+ :ulc-x (- frm-width dx sp-width)
+ :ulc-y start-y))
+ (setf (tumor-selector vol-ed)
+ (make-selector-panel sp-width 125
+ "Add a tumor" (tumor-coll vol-ed)
+ #'make-tumor
+ #'make-vol-panel
+ :parent frm-win
+ :use-color t :radio t
+ :ulc-x (- frm-width dx sp-width)
+ :ulc-y (+ start-y dx sp-height)))
+ (setf (target-selector vol-ed)
+ (make-selector-panel sp-width 125
+ "Add a target" (target-coll vol-ed)
+ #'local-make-target ;; see above
+ #'make-vol-panel
+ :parent frm-win
+ :use-color t :radio t
+ :ulc-x (- frm-width dx sp-width)
+ :ulc-y (+ start-y (* 2 dx) sp-height 125)))
+ (setf (point-selector vol-ed)
+ (make-selector-panel sp-width sp-height
+ "Add a point" (point-coll vol-ed)
+ #'local-make-point
+ #'make-point-panel
+ :parent frm-win
+ :use-color t :radio t
+ :ulc-x (- frm-width dx sp-width)
+ :ulc-y (+ start-y (* 3 dx) sp-height 250))))
+ (flet ((add-pstr (pan coll str)
+ (declare (ignore coll))
+ (push str (bg-vols pan))
+ (dolist (con (contours str))
+ (fs-add-contour str con (fs pan))))
+ (rem-pstr (pan coll str)
+ (declare (ignore coll))
+ (setf (bg-vols pan) (remove str (bg-vols pan)))
+ (compute-volume-prims pan)
+ (write-pe-background pan)
+ (display-planar-editor (pe vol-ed))
+ (dolist (con (contours str))
+ (fs-delete-contour str (z con) (fs pan))))
+ (add-fs-pt (pan coll pt)
+ (declare (ignore pan coll pt))
+ ;; to be done
+ )
+ (rem-fs-pt (pan coll pt)
+ (declare (ignore pan coll pt))
+ ;; to be done
+ ))
+ (ev:add-notify vol-ed (coll:inserted (organ-coll vol-ed)) #'add-pstr)
+ (ev:add-notify vol-ed (coll:inserted (tumor-coll vol-ed)) #'add-pstr)
+ (ev:add-notify vol-ed (coll:inserted (target-coll vol-ed)) #'add-pstr)
+ (ev:add-notify vol-ed (coll:inserted (point-coll vol-ed)) #'add-fs-pt)
+ (ev:add-notify vol-ed (coll:deleted (organ-coll vol-ed)) #'rem-pstr)
+ (ev:add-notify vol-ed (coll:deleted (tumor-coll vol-ed)) #'rem-pstr)
+ (ev:add-notify vol-ed (coll:deleted (target-coll vol-ed)) #'rem-pstr)
+ (ev:add-notify vol-ed (coll:deleted (point-coll vol-ed)) #'rem-fs-pt))
+ (setf (pe vol-ed)
+ (make-planar-editor ;; just take default color and scale at first
+ :parent frm-win
+ :ulc-x (+ btw (* 2 dx)) :ulc-y fsh
+ :image nil ;; this will get set when the easel z is set
+ :background (sl:make-square-pixmap img-size t frm-win)
+ :x-origin (round (/ img-size 2))
+ :y-origin (round (/ img-size 2))
+ :next-mark-id (1+ (aif (coll:elements (point-coll vol-ed))
+ (apply #'max (mapcar #'id it))
+ 0))
+ ))
+ (setf (scaled-image vol-ed) (make-array (list img-size img-size)
+ :element-type
+ '(unsigned-byte 32)))
+ ;; add volumes to filmstrip
+ (dolist (vol (append (coll:elements (organ-coll vol-ed))
+ (coll:elements (tumor-coll vol-ed))
+ (coll:elements (target-coll vol-ed))))
+ (dolist (con (contours vol))
+ (fs-add-contour vol con (fs vol-ed))))
+ ;; add points to filmstrip
+ (dolist (pt (coll:elements (point-coll vol-ed)))
+ (fs-replace-points nil (list pt) (z pt) (fs vol-ed)))
+ (ev:add-notify vol-ed (sl:button-on (cpy-pts-btn vol-ed))
+ #'(lambda (vol-ed1 bt)
+ (aif (nearest (z vol-ed1)
+ (mapcar #'z
+ (if (volume vol-ed1)
+ (contours (volume vol-ed1))
+ (coll:elements
+ (point-coll vol-ed1))))
+ *display-epsilon*)
+ (progn
+ (setf (vertices (pe vol-ed1))
+ (if (volume vol-ed1)
+ ;; make fresh lists for copied contour
+ (copy-tree
+ (vertices (find it (contours
+ (volume vol-ed1))
+ :test #'= :key #'z)))
+ (append ;; add from nearest, not replace
+ (vertices (pe vol-ed1))
+ (remove nil
+ (mapcar
+ #'(lambda (pt)
+ (if (poly:nearly-equal
+ it (z pt)
+ *display-epsilon*)
+ (prog1 ;; need new one!
+ (make-point
+ ""
+ :x (x pt)
+ :y (y pt)
+ :z (z vol-ed1)
+ :id (next-mark-id
+ (pe vol-ed1)))
+ (incf (next-mark-id
+ (pe vol-ed1))))))
+ (coll:elements
+ (point-coll vol-ed1)))))))
+ (unless (sl:on (accept-btn (pe vol-ed1)))
+ (setf (sl:on (accept-btn (pe vol-ed1))) t)))
+ (sl:acknowledge "No nearest contour or points"))
+ (if (sl:on bt) (setf (sl:on bt) nil))))
+ (ev:add-notify vol-ed (sl:button-on del-con-b)
+ #'(lambda (vol-ed1 bt)
+ (declare (ignore bt))
+ (when (volume vol-ed1) ;; no action for points
+ (setf (vertices (pe vol-ed1)) nil) ;; do this first
+ (update-pstruct (volume vol-ed1) nil (z vol-ed1))
+ (fs-delete-contour (volume vol-ed1)
+ (z vol-ed1) (fs vol-ed1)))))
+ (ev:add-notify vol-ed (sl:button-on (extend-btn vol-ed))
+ #'(lambda (vol-ed1 bt)
+ (if (eql (edit-mode (pe vol-ed1)) :automatic)
+ (setf (auto-extend-subpanel vol-ed1)
+ (make-auto-extend-panel
+ vol-ed1
+ 5 (bp-y (+ (height (fs vol-ed1)) 5) bth 8)))
+ (progn
+ (sl:acknowledge
+ '("Multi-slice drawing possible"
+ "only in Automatic mode"))
+ (setf (sl:on bt) nil)))))
+ (ev:add-notify vol-ed (sl:button-off (extend-btn vol-ed))
+ #'(lambda (vol-ed1 bt)
+ (declare (ignore bt))
+ (when (auto-extend-subpanel vol-ed1)
+ (destroy (auto-extend-subpanel vol-ed1))
+ (setf (auto-extend-subpanel vol-ed1) nil))))
+ (ev:add-notify vol-ed (new-vertices (pe vol-ed))
+ #'(lambda (vol-ed1 a new-verts)
+ (declare (ignore a))
+ (if (volume vol-ed1)
+ (progn
+ (update-pstruct (volume vol-ed1) new-verts
+ (z vol-ed1))
+ (fs-delete-contour (volume vol-ed1)
+ (z vol-ed1) (fs vol-ed1))
+ (fs-add-contour (volume vol-ed1)
+ (make-contour :z (z vol-ed1)
+ :vertices
+ new-verts)
+ (fs vol-ed1))
+ (when (sl:on (extend-btn vol-ed1))
+ (generate-extended-contours
+ (auto-extend-subpanel vol-ed1) new-verts)))
+ (progn ;; add z coords to new points
+ (dolist (pt new-verts) (setf (z pt) (z vol-ed1)))
+ (fs-replace-points ;; do this before update
+ (remove (z vol-ed1)
+ (coll:elements (point-coll vol-ed1))
+ :key #'z
+ :test-not #'(lambda (a b)
+ (poly:nearly-equal
+ a b *display-epsilon*)))
+ new-verts (z vol-ed1) (fs vol-ed1))
+ (update-points vol-ed1 new-verts)))))
+ ;; select first avail pstruct or make a new organ to edit
+ (cond ((select-1 (organ-selector vol-ed)))
+ ((select-1 (tumor-selector vol-ed)))
+ ((select-1 (target-selector vol-ed)))
+ (t (let ((sel-pan (organ-selector vol-ed)))
+ (setf (sl:on (add-button sel-pan)) t) ;; adds a new organ
+ (setf (sl:on (add-button sel-pan)) nil))))
+ (ev:add-notify vol-ed (new-scale (pe vol-ed))
+ #'(lambda (vol-ed1 a new-sc)
+ (declare (ignore a new-sc))
+ (compute-volume-prims vol-ed1)
+ (compute-point-prims vol-ed1)
+ (write-pe-background vol-ed1)))
+ (ev:add-notify vol-ed (new-origin (pe vol-ed))
+ #'(lambda (vol-ed1 a new-org)
+ (declare (ignore a new-org))
+ (compute-volume-prims vol-ed1)
+ (compute-point-prims vol-ed1)
+ (write-pe-background vol-ed1)))
+ (ev:add-notify vol-ed (pt-selected (pe vol-ed))
+ #'(lambda (vol-ed1 pl-ed pt)
+ (declare (ignore pl-ed))
+ ;; select the point pt in the selector panel
+ (let ((selpan (point-selector vol-ed1)))
+ (sl:select-button
+ (button-for pt selpan)
+ (scroll-list selpan)))))
+ (setf (z vol-ed) (or (index (fs vol-ed)) 0.0))
+ (sl:flush-output)))
+
+;;;----------------------------------
+
+(defun make-volume-editor (&rest initargs)
+
+ "make-volume-editor &rest initargs
+
+Returns a volume editor with the specified parameters."
+
+ (apply #'make-instance 'volume-editor initargs))
+
+;;;----------------------------------
+
+(defmethod destroy :before ((vol-ed volume-editor))
+
+ "Releases X resources used by this panel and its children."
+
+ (ev:remove-notify vol-ed (coll:inserted (organ-coll vol-ed)))
+ (ev:remove-notify vol-ed (coll:inserted (tumor-coll vol-ed)))
+ (ev:remove-notify vol-ed (coll:inserted (target-coll vol-ed)))
+ (ev:remove-notify vol-ed (coll:inserted (point-coll vol-ed)))
+ (ev:remove-notify vol-ed (coll:deleted (organ-coll vol-ed)))
+ (ev:remove-notify vol-ed (coll:deleted (tumor-coll vol-ed)))
+ (ev:remove-notify vol-ed (coll:deleted (target-coll vol-ed)))
+ (ev:remove-notify vol-ed (coll:deleted (point-coll vol-ed)))
+ (if (volume vol-ed)
+ (ev:remove-notify vol-ed (new-color (volume vol-ed))))
+ (if (point vol-ed)
+ (ev:remove-notify vol-ed (new-color (point vol-ed))))
+
+ ;; possibly more here - check
+
+ (if (sl:on (extend-btn vol-ed)) (setf (sl:on (extend-btn vol-ed)) nil))
+ (sl:destroy (extend-btn vol-ed))
+ (sl:destroy (del-con-btn vol-ed))
+ (destroy (organ-selector vol-ed))
+ (destroy (tumor-selector vol-ed))
+ (destroy (target-selector vol-ed))
+ (destroy (point-selector vol-ed))
+ (sl:destroy (del-pnl-btn vol-ed))
+ (sl:destroy (z-tln vol-ed))
+ (sl:destroy (slice-no vol-ed))
+ (sl:destroy (window-control vol-ed))
+ (sl:destroy (level-control vol-ed))
+ (sl:destroy (cpy-pts-btn vol-ed))
+ (destroy (fs vol-ed))
+ (destroy (pe vol-ed))
+ (sl:destroy (fr vol-ed)))
+
+;;;----------------------------------
+
+(defmethod destroy :after ((vol-ed volume-editor))
+
+ (clx:free-pixmap (background (pe vol-ed)))) ;; made here, free here
+
+;;;----------------------------------
+;;; End.
diff --git a/prism/src/volume-graphics.cl b/prism/src/volume-graphics.cl
new file mode 100644
index 0000000..c477322
--- /dev/null
+++ b/prism/src/volume-graphics.cl
@@ -0,0 +1,211 @@
+;;;
+;;; volume-graphics
+;;;
+;;; defines draw methods and other stuff for drawing contoured volumes
+;;; in views.
+;;;
+;;; 29-Nov-1992 J. Unger modify draw method to pass pstruct colors,
+;;; modify draw method to accept optional color arg and to draw a
+;;; segment between last and first point of contour.
+;;; 13-Dec-1992 J. Unger modify draw method for pstructs into views to
+;;; pass parent parameter, also to operate on view's foreground
+;;; display list.
+;;; 22-Dec-1992 J. Unger add code to draw contours into
+;;; sagittal/coronal views.
+;;; 29-Dec-1992 J. Unger break the draw method for pstructs into views
+;;; into a separate method for each view; modify to do graphics
+;;; primitive management cleanly, modify contour draw methods to work
+;;; in conjunction with new draw method for pstructs into views.
+;;; 04-Jan-1993 J. Unger modify draw method for pstructs into
+;;; transverse views to correctly handle pstructs with multiple
+;;; contours with the same z attribute, fix sign bug in
+;;; contour/coronal view draw method, modify draw method for contours
+;;; into transverse views to correctly handle the possibility of
+;;; multiple contours from the same 'contour source' (eg: pstruct)
+;;; with the same z attribute.
+;;; 13-Jan-1993 J. Unger add draw method for pstructs into beam's eye
+;;; views, add draw method for contours into beam's eye views and
+;;; supporting code, move bev cache recomputation code to views
+;;; module.
+;;; 11-Feb-1993 J. Unger optimize drawing of contours into bev's.
+;;; 15-Feb-1993 I. Kalet always set color in primitives whether new or
+;;; old, get src-to-isocenter info from therapy machine.
+;;; 25-Mar-1993 J. Unger move draw method for contours into beams eye
+;;; views into beams-eye-views module, to break up a dependency cycle.
+;;; 3-Sep-1993 I. Kalet split off from volumes module, separated from
+;;; contours module and move draw method for contour in bev here from
+;;; bev module.
+;;; 1-Apr-1994 I. Kalet move bev method to new bev-graphics module
+;;; 22-Apr-1994 I. Kalet change refs to view origin to new ones.
+;;; 19-Sep-1996 I. Kalet merge draw methods for contours into methods
+;;; for pstruct, to eliminate :prim keyword parameter to draw
+;;; function.
+;;; 6-Dec-1996 I. Kalet don't generate prims for color invisible
+;;; 3-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx .
+;;; 11-Jan-1998 I. Kalet add draw-transverse back here, use here too.
+;;; 21-Apr-1999 I. Kalet change sl:invisible to 'sl:invisible.
+;;; 25-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 5-Jan-2000 I. Kalet relax z match criterion for transverse views.
+;;; 13-Oct-2002 I. Kalet add draw method for room view.
+;;; 25-May-2009 I. Kalet remove draw method for room view.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defun draw-transverse (vertices prim x-origin y-origin scale)
+
+ "draw-transverse vertices prim x-origin y-origin scale
+
+Draws vertices into graphics primitive prim (which must be a lines
+prim), based upon a transverse drawing plane with origin and scale as
+provided."
+
+ (declare (fixnum x-origin y-origin) (single-float scale))
+ (let ((pts (pixel-contour vertices scale x-origin y-origin)))
+ (push (nconc pts (list (first pts) (second pts)))
+ (points prim))))
+
+;;;--------------------------------------
+
+(defmethod draw ((pstr pstruct) (tv transverse-view))
+
+ "draw (pstr pstruct) (tv transverse-view)
+
+This method draws all the contours in the pstruct into a transverse
+view. Only those whose z is close to the z of the view are drawn."
+
+ (if (eql (display-color pstr) 'sl:invisible)
+ (setf (foreground tv) (remove pstr (foreground tv) :key #'object))
+ (let ((prim (find pstr (foreground tv) :key #'object))
+ (color (sl:color-gc (display-color pstr)))
+ (pos (view-position tv))
+ (scale (scale tv))
+ (x0 (x-origin tv))
+ (y0 (y-origin tv)))
+ (declare (fixnum x0 y0) (single-float pos scale))
+ (unless prim
+ (setq prim (make-lines-prim nil color :object pstr))
+ (push prim (foreground tv)))
+ (setf (color prim) color
+ (points prim) nil)
+ (dolist (con (contours pstr))
+ (when (poly:nearly-equal (z con) pos *display-epsilon*)
+ (draw-transverse (vertices con) prim x0 y0 scale))))))
+
+;;;--------------------------------------
+
+(defmethod draw ((pstr pstruct) (sv sagittal-view))
+
+ "draw (pstr pstruct) (sv sagittal-view)
+
+This method draws all the contours in the pstruct into a sagittal
+view. At each point where a contour intersects the view, a small box
+is drawn in the view."
+
+ (if (eql (display-color pstr) 'sl:invisible)
+ (setf (foreground sv) (remove pstr (foreground sv) :key #'object))
+ (let ((prim (find pstr (foreground sv) :key #'object))
+ (color (sl:color-gc (display-color pstr)))
+ (pos (view-position sv))
+ (xorig (x-origin sv))
+ (yorig (y-origin sv))
+ (scale (scale sv)))
+ (declare (fixnum xorig yorig) (single-float pos scale))
+ (unless prim
+ (setq prim (make-rectangles-prim nil color :object pstr))
+ (push prim (foreground sv)))
+ (setf (color prim) color
+ (rectangles prim) nil)
+ (dolist (con (contours pstr))
+ (when (vertices con)
+ (let ((rects nil))
+ ;; Here, we check each line segment in the contour,
+ ;; determined by points (x1,y1) and (x2,y2), to determine
+ ;; whether the plane of this sagittal view cuts the
+ ;; segment. If so, then determine the coordinates of the
+ ;; point of intersection (x,y) via linear interpolation,
+ ;; and map that point into pixel coordinates (xpix, ypix)
+ ;; of the view plane.
+ (mapl #'(lambda (verts)
+ (when (rest verts)
+ (let ((x1 (first (first verts)))
+ (y1 (second (first verts)))
+ (x2 (first (second verts)))
+ (y2 (second (second verts))))
+ (declare (single-float x1 y1 x2 y2))
+ (when (and (not (poly:nearly-equal x1 x2))
+ (or (poly:nearly-increasing x1 pos x2)
+ (poly:nearly-decreasing x1 pos x2)))
+ (let* ((x (z con))
+ (y (- y2 (* (- x2 pos)
+ (/ (- y2 y1) (- x2 x1)))))
+ (xpix (pix-x x xorig scale))
+ (ypix (pix-y y yorig scale)))
+ (declare (single-float x y)
+ (fixnum xpix ypix))
+ (setq rects
+ (nconc (list (- xpix 2) (- ypix 2) 4 4)
+ rects)))))))
+ (append (vertices con) (list (first (vertices con)))))
+ (setf (rectangles prim) (append rects (rectangles prim)))))))))
+
+;;;--------------------------------------
+
+(defmethod draw ((pstr pstruct) (cv coronal-view))
+
+ "draw (pstr pstruct) (cv coronal-view)
+
+This method draws all the contours in the pstruct into a coronal view."
+
+ (if (eql (display-color pstr) 'sl:invisible)
+ (setf (foreground cv) (remove pstr (foreground cv) :key #'object))
+ (let ((prim (find pstr (foreground cv) :key #'object))
+ (color (sl:color-gc (display-color pstr)))
+ (pos (view-position cv))
+ (xorig (x-origin cv))
+ (yorig (y-origin cv))
+ (scale (scale cv)))
+ (declare (fixnum xorig yorig) (single-float pos scale))
+ (unless prim
+ (setq prim (make-rectangles-prim nil color :object pstr))
+ (push prim (foreground cv)))
+ (setf (color prim) color
+ (rectangles prim) nil)
+ (dolist (con (contours pstr))
+ (when (vertices con)
+ (let ((rects nil))
+ ;; Here, we check each line segment in the contour,
+ ;; determined by points (x1,y1) and (x2,y2), to determine
+ ;; whether the plane of this coronal view cuts the
+ ;; segment. If so, then determine the coordinates of the
+ ;; point of intersection (x,y) via linear interpolation,
+ ;; and map that point into pixel coordinates (xpix, ypix)
+ ;; of the view plane.
+ (mapl #'(lambda (verts)
+ (when (rest verts)
+ (let ((x1 (first (first verts)))
+ (y1 (second (first verts)))
+ (x2 (first (second verts)))
+ (y2 (second (second verts))))
+ (declare (single-float x1 y1 x2 y2))
+ (when (and (not (poly:nearly-equal y1 y2))
+ (or (poly:nearly-increasing y1 pos y2)
+ (poly:nearly-decreasing y1 pos y2)))
+ (let* ((y (z con))
+ (x (+ x1 (* (- pos y1)
+ (/ (- x2 x1) (- y2 y1)))))
+ (xpix (pix-x x xorig scale))
+ ;; here ypix transforms like x, not y
+ (ypix (pix-x y yorig scale)))
+ (declare (single-float x y)
+ (fixnum xpix ypix))
+ (setq rects
+ (nconc (list (- xpix 2) (- ypix 2) 4 4)
+ rects)))))))
+ (append (vertices con) (list (first (vertices con)))))
+ (setf (rectangles prim) (append rects (rectangles prim)))))))))
+
+;;;--------------------------------------
+;;; End.
diff --git a/prism/src/volume-mediators.cl b/prism/src/volume-mediators.cl
new file mode 100644
index 0000000..2a3c23b
--- /dev/null
+++ b/prism/src/volume-mediators.cl
@@ -0,0 +1,48 @@
+;;;
+;;; volume-mediators
+;;;
+;;; defines mediator for update of contoured volume objects in views
+;;;
+;;; 3-Sep-1993 I. Kalet split off from volumes module
+;;; 14-Aug-2002 J. Sager modify for room-view
+;;; 22-Sep-2002 I. Kalet simplify event registrations.
+;;; 13-Oct-2002 I. Kalet clear the triangular mesh cache for room-view
+;;; when new contour announced.
+;;; 25-May-2009 I. Kalet remove ref to room-view
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass pstruct-view-mediator (object-view-mediator)
+
+ ()
+
+ (:documentation "This mediator connects a pstruct with a view.")
+ )
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((pvm pstruct-view-mediator)
+ &rest initargs)
+ (declare (ignore initargs))
+ (ev:add-notify pvm (new-color (object pvm))
+ #'update-view)
+ (ev:add-notify pvm (new-contours (object pvm))
+ #'update-view))
+
+;;;--------------------------------------
+
+(defmethod destroy :after ((pvm pstruct-view-mediator))
+
+ (ev:remove-notify pvm (new-contours (object pvm)))
+ (ev:remove-notify pvm (new-color (object pvm))))
+
+;;;--------------------------------------
+
+(defun make-pstruct-view-mediator (pstruct view)
+
+ (make-instance 'pstruct-view-mediator :object pstruct :view view))
+
+;;;--------------------------------------
diff --git a/prism/src/volumes.cl b/prism/src/volumes.cl
new file mode 100644
index 0000000..b4b641d
--- /dev/null
+++ b/prism/src/volumes.cl
@@ -0,0 +1,611 @@
+;;;
+;;; volumes
+;;;
+;;; The classes and methods for volume objects, including anatomy,
+;;; tumors and targets.
+;;;
+;;; 10-Aug-1992 I. Kalet created from old rtp-objects
+;;; 7-Sep-1992 I. Kalet change some methods to :before to supplement
+;;; default methods, also move contour stuff to contours module
+;;; 16-Sep-1992 I. Kalet name, new-name now in prism-objects
+;;; 1-Mar-1993 I. Kalet remove make-easel definition - defined in
+;;; easel
+;;; 31-Jul-1993 I. Kalet add new-contours and new-color events
+;;; 3-Sep-1993 I. Kalet split draw methods to volume-graphics, and
+;;; mediator to volume-mediators
+;;; 15-Oct-1993 I. Kalet remove unnecessary slot-type methods, add
+;;; default initargs for tumors and targets
+;;; 25-Oct-1993 I. Kalet add default initarg for density
+;;; 22-Mar-1994 J. Unger enhance tumor def for PTVT.
+;;; 28-Mar-1994 J. Unger add announcements when tumor attribs change.
+;;; 30-Mar-1994 J. Unger misc mods & enhancements to tumor attribs.
+;;; 2-Jun-1994 J. Unger add some announcements for setf obj
+;;; attributes.
+;;; 16-Jun-1994 I. Kalet change float to single-float, density can be
+;;; nil, default target-type is "unspecified".
+;;; 11-Sep-1995 I. Kalet DON'T SAVE new-m-stage - inadvertently
+;;; omitted from not-saved method for tumors.
+;;; 23-Jun-1997 I. Kalet add default initarg for tolerance dose.
+;;; 19-Oct-1998 C. Wilcox changed the calculation of thickness
+;;; for the physical volume calculation
+;;; 25-Feb-1999 I. Kalet put find-center-vol here, moved from coll-panels
+;;; 1-Apr-1999 I. Kalet add physical-volume, dose-histogram to
+;;; not-saved method for pstruct
+;;; 13-Aug-2002 J. Sager add 3d-display slot to pstruct and event
+;;; new-3d-display
+;;; 13-Oct-2002 I. Kalet add mesh slot to pstruct to hold triangulated
+;;; mesh generated from contours, remove new-3d-display event
+;;; 30-Oct-2002 I. Kalet don't save 3d-display!
+;;; 4-Aug-2005 E. Webster cumulative changes to improve OpenGL rendering
+;;; 25-May-2009 I. Kalet remove room-view support
+;;; 26-Jun-2009 I. Kalet and remove :3d-display default initarg in
+;;; target class.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass pstruct (generic-prism-object)
+
+ ((contours :initarg :contours
+ :accessor contours
+ :documentation "A list of contours representing the
+surface of the volume.")
+
+ (new-contours :type ev:event
+ :initform (ev:make-event)
+ :accessor new-contours
+ :documentation "Announced when a contour is added,
+replaced or altered. Must be done by external code, since the
+contours are not a collection but a simple list.")
+
+ (physical-volume :type single-float
+ :initarg :physical-volume
+ :reader physical-volume
+ :documentation "The total volume enclosed by the
+surface defined by the contours.")
+
+ (dose-histogram :initarg :dose-histogram
+ :accessor dose-histogram)
+
+ (display-color :initarg :display-color
+ :accessor display-color)
+
+ (new-color :type ev:event
+ :initform (ev:make-event)
+ :accessor new-color
+ :documentation "Announced by setf method when
+display-color is updated.")
+
+ (update-case :type ev:event
+ :initform (ev:make-event)
+ :accessor update-case
+ :documentation "An event that gets announced
+whenever any pstruct attribute changes that justifies resetting the
+pstruct's containing case id and timestamp.")
+
+ )
+
+ (:default-initargs :name "" :contours nil :display-color 'sl:white)
+
+ (:documentation "A pstruct is any kind of 3-d geometric structure
+pertaining to the case, either an organ, with density to be used in
+the dose computation, or an organ with no density, but whose dose
+histogram should be known, or a target, whose dose should be
+analyzed.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod slot-type ((obj pstruct) slotname)
+
+ (case slotname
+ (contours :object-list)
+ (otherwise :simple)))
+
+;;;--------------------------------------
+
+(defmethod not-saved ((obj pstruct))
+
+ (append (call-next-method)
+ '(update-case new-color new-contours physical-volume
+ dose-histogram)))
+
+;;;--------------------------------------
+
+(defmethod (setf name) :after (nm (obj pstruct))
+
+ (declare (ignore nm))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defmethod (setf display-color) :after (col (obj pstruct))
+
+ (ev:announce obj (new-color obj) col))
+
+;;;--------------------------------------
+
+(defmethod physical-volume :before ((pstr pstruct))
+
+ "Returns the physical volume of a pstruct, initially by computing
+the area of each contour (polygon) and multiplying by the thickness of
+each slice, then cached in the pstruct. The pstruct must have
+contours, and each is considered closed."
+
+ ;; Method for computing the area of a polygon (contour):
+ ;; Sums area of each triangle determined by a fixed reference point
+ ;; (in this case, the origin (0,0) and each side of polygon). Area K
+ ;; of each triangle is computed the formula:
+ ;; K = | V1 x V2 | / 2.0
+ ;; (see any text, for example Anton H, Elementary Linear Algebra ed.,
+ ;; John Wiley and Sons 1981, p. 113.) For the details and drawings
+ ;; showing the point, V1 and V2, see the discussion of IRREG-style
+ ;; scatter summation PLAN-32 User's Manual, Appendix A. In fact,
+ ;; this code is lifted right out of sector_sum.
+
+;; (unless (slot-boundp pstr 'physical-volume)
+ (setf (slot-value pstr 'physical-volume)
+ (let* ((conts (sort (copy-list (contours pstr))
+ #'(lambda (x y) (< (z x) (z y)))))
+ (zs (mapcar #'(lambda (x) (z x)) conts))
+ (prev-z (car zs))
+ (curr-z (car zs))
+ (next-z (car zs))
+ verts
+ first-vert
+ second-vert
+ (slab-thickness 0.0)
+ (cross 0.0)
+ (volume 0.0)
+ (area 0.0))
+ (dolist (cont conts volume)
+ (setf prev-z curr-z)
+ (setf curr-z next-z)
+ (setf zs (cdr zs))
+ (when zs (setf next-z (car zs)))
+ (setf slab-thickness (/ (abs (- prev-z next-z)) 2))
+ (setf verts (vertices cont))
+ (setf first-vert (car verts))
+ (setf area 0.0)
+ (dolist (vert (append (cdr verts) (list first-vert)))
+ (setf second-vert first-vert)
+ (setf first-vert vert)
+ ;; cross := end_2_y * end_1_x - end_2_x * end_1_y
+ (setf cross (- (* (cadr second-vert)
+ (car first-vert))
+ (* (car second-vert)
+ (cadr first-vert))))
+ (setf area (+ area cross)))
+ (setf volume (+ volume (* slab-thickness
+ (float (/ (abs area) 2.0)))))))))
+
+;;;--------------------------------------
+
+(defun bounding-box (vol)
+
+ "bounding-box vol
+
+Return the maximum and minimum cordinates of a pstruct vol."
+ (let* ((clist (contours vol))
+ (pts (apply #'append (mapcar #'vertices clist)))
+ (x-list (mapcar #'first pts))
+ (y-list (mapcar #'second pts))
+ (max-x (apply #'max x-list))
+ (min-x (apply #'min x-list))
+ (max-y (apply #'max y-list))
+ (min-y (apply #'min y-list))
+ (z-list (mapcar #'z clist))
+ (max-z (apply #'max z-list))
+ (min-z (apply #'min z-list)))
+ (list (list min-x min-y min-z)
+ (list max-x max-y max-z))))
+
+;;;--------------------------------------
+
+(defun find-center-vol (vol)
+
+ "find-center-vol vol
+
+Returns the center coordinates and maximum diameter of pstruct vol."
+
+ (let* ((extremes (bounding-box vol))
+ (minpt (first extremes))
+ (maxpt (second extremes)))
+ (values (list (* 0.5 (+ (first maxpt) (first minpt)))
+ (* 0.5 (+ (second maxpt) (second minpt)))
+ (* 0.5 (+ (third maxpt) (third minpt))))
+ (max (abs (- (first maxpt) (first minpt)))
+ (abs (- (second maxpt) (second minpt)))
+ (abs (- (third maxpt) (third minpt)))))))
+
+;;;--------------------------------------
+
+(defclass organ (pstruct)
+
+ ((tolerance-dose :type single-float
+ :initarg :tolerance-dose
+ :accessor tolerance-dose
+ :documentation "The accepted value for radiation
+tolerance for this organ type, in rads.")
+
+ (density :initarg :density
+ :accessor density
+ :documentation "The density to be used in the dose
+computation for inhomogeneity corrections. It can be nil or a number,
+so the type is not specified here. If nil, the organ is not used in
+the dose computation for inhomogeneity corrections.")
+
+ (new-density :type ev:event
+ :initform (ev:make-event)
+ :accessor new-density
+ :documentation "Announced when the density is
+updated.")
+
+ (organ-name :initarg :organ-name
+ :reader organ-name
+ :documentation "One of the known organ names.")
+
+ )
+
+ (:default-initargs :tolerance-dose 0.0 :density nil
+ :display-color 'sl:green)
+
+ (:documentation "This class includes both organs that represent
+inhomogeneities and organs for which there is a tolerance dose not to
+be exceeded. Some organs are of both types.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod not-saved ((obj organ))
+
+ (append (call-next-method)
+ '(new-density)))
+
+;;;--------------------------------------
+
+(defmethod (setf density) :after (den (obj organ))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-density obj) den))
+
+;;;--------------------------------------
+
+(defmethod (setf tolerance-dose) :after (tol (obj organ))
+
+ (declare (ignore tol))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defun make-organ (org-name &rest initargs)
+
+ (apply #'make-instance 'organ
+ :name (if (equal org-name "")
+ (format nil "~A" (gensym "ORGAN-"))
+ org-name)
+ initargs))
+
+;;;--------------------------------------
+
+(defclass tumor (pstruct)
+
+ ((t-stage :type symbol
+ :initarg :t-stage
+ :accessor t-stage
+ :documentation "The tumor's t-stage - one of 't1, 't2,
+'t3, t4, or nil if unspecified.")
+
+ (new-t-stage :type ev:event
+ :initform (ev:make-event)
+ :accessor new-t-stage
+ :documentation "Announced when the tumor's t-stage
+changes.")
+
+ (m-stage :type symbol
+ :initarg :m-stage
+ :accessor m-stage
+ :documentation "The tumor's m-stage.")
+
+ (new-m-stage :type ev:event
+ :initform (ev:make-event)
+ :accessor new-m-stage
+ :documentation "Announced when the tumor's m-stage
+changes.")
+
+ (n-stage :type symbol
+ :initarg :n-stage
+ :accessor n-stage
+ :documentation "The tumor's n-stage - one of 'n0, 'n1,
+'n2, 'n3, or nil if unspecified.")
+
+ (new-n-stage :type ev:event
+ :initform (ev:make-event)
+ :accessor new-n-stage
+ :documentation "Announced when the tumor's n-stage
+changes.")
+
+ (cell-type :type symbol
+ :initarg :cell-type
+ :accessor cell-type
+ :documentation "One of a list of numerous cell types, or
+nil if unspecified.")
+
+ (new-cell-type :type ev:event
+ :initform (ev:make-event)
+ :accessor new-cell-type
+ :documentation "Announced when the tumor's cell-type
+ changes.")
+
+ (site :type symbol
+ :initarg :site
+ :accessor site
+ :documentation "One of the known tumor sites, a symbol, as
+determined by the anatomy tree.")
+
+ (new-site :type ev:event
+ :initform (ev:make-event)
+ :accessor new-site
+ :documentation "Announced when the tumor's site changes.")
+
+ (region :type symbol
+ :initarg :region
+ :accessor region
+ :documentation "For lung tumors, a region of the lung. Nil
+if unspecified or for other tumor sites, or one of 'hilum, 'upper-lobe,
+'lower-lobe, or 'mediastinum.")
+
+ (new-region :type ev:event
+ :initform (ev:make-event)
+ :accessor new-region
+ :documentation "Announced when the tumor's region
+changes.")
+
+ (side :type symbol
+ :initarg :side
+ :accessor side
+ :documentation "For lung tumors, the side of the lung that
+the tumor is on. Nil if unspecified or for other tumor sites, or one
+of 'left or 'right.")
+
+ (new-side :type ev:event
+ :initform (ev:make-event)
+ :accessor new-side
+ :documentation "Announced when the tumor's side changes.")
+
+ (fixed :type symbol
+ :initarg :fixed
+ :accessor fixed
+ :documentation "For lung tumors, an indication of whether
+the tumor is fixed to the chest wall or not. Nil if unspecified of
+for other tumor sites, or one of 'yes or 'no.")
+
+ (new-fixed :type ev:event
+ :initform (ev:make-event)
+ :accessor new-fixed
+ :documentation "Announced when the tumor's fixed
+attribute changes.")
+
+ (pulm-risk :type symbol
+ :initarg :pulm-risk
+ :accessor pulm-risk
+ :documentation "For lung tumors, the tumor's pulmonary
+risk. Nil if unspecified or for other tumor sites, or one of 'high
+or 'low.")
+
+ (new-pulm-risk :type ev:event
+ :initform (ev:make-event)
+ :accessor new-pulm-risk
+ :documentation "Announced when the tumor's pulmonary
+risk changes.")
+
+ (grade :initarg :grade
+ :accessor grade
+ :documentation "The tumor's grade")
+
+ (new-grade :type ev:event
+ :initform (ev:make-event)
+ :accessor new-grade
+ :documentation "Announced when the tumor's grade
+changes.")
+
+ )
+
+ (:default-initargs :t-stage nil :n-stage nil :m-stage nil
+ :cell-type nil :site 'body :region nil
+ :side nil :fixed nil :pulm-risk nil
+ :grade nil :display-color 'sl:cyan)
+
+ (:documentation "There may be more than one tumor volume for a
+patient.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod not-saved ((obj tumor))
+
+ (append (call-next-method)
+ '(new-t-stage new-m-stage new-n-stage new-cell-type new-site
+ new-region new-side new-fixed new-pulm-risk new-grade)))
+
+;;;--------------------------------------
+
+(defmethod (setf t-stage) :after (t-stg (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-t-stage obj) t-stg))
+
+;;;--------------------------------------
+
+(defmethod (setf n-stage) :after (n-stg (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-n-stage obj) n-stg))
+
+;;;--------------------------------------
+
+(defmethod (setf cell-type) :after (new-ct (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-cell-type obj) new-ct))
+
+;;;--------------------------------------
+
+(defmethod (setf site) :after (new-s (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-site obj) new-s))
+
+;;;--------------------------------------
+
+(defmethod (setf region) :after (new-r (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-region obj) new-r))
+
+;;;--------------------------------------
+
+(defmethod (setf side) :after (new-s (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-side obj) new-s))
+
+;;;--------------------------------------
+
+(defmethod (setf fixed) :after (new-f (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-fixed obj) new-f))
+
+;;;--------------------------------------
+
+(defmethod (setf pulm-risk) :after (new-pr (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-pulm-risk obj) new-pr))
+
+;;;--------------------------------------
+
+(defmethod (setf grade) :after (new-gr (obj tumor))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-grade obj) new-gr))
+
+;;;--------------------------------------
+
+(defun make-tumor (tumor-name &rest initargs)
+
+ (apply #'make-instance 'tumor
+ :name (if (equal tumor-name "")
+ (format nil "~A" (gensym "TUMOR-"))
+ tumor-name)
+ initargs))
+
+;;;--------------------------------------
+
+(defclass target (pstruct)
+
+ ((site :initarg :site
+ :accessor site
+ :documentation "One of the known tumor sites")
+
+ (required-dose :type single-float
+ :initarg :required-dose
+ :accessor required-dose)
+
+ (region :initarg :region
+ :accessor region)
+
+ (target-type :initarg :target-type
+ :accessor target-type
+ :documentation "One of either initial or boost")
+
+ (nodes :initarg :nodes
+ :accessor nodes
+ :documentation "Nodes to treat")
+
+ (average-size :type single-float
+ :initarg :average-size
+ :accessor average-size)
+
+ (how-derived :initarg :how-derived
+ :accessor how-derived)
+
+ )
+
+ (:default-initargs :site 'body :required-dose 0.0
+ :region nil :target-type "unspecified"
+ :how-derived "Manual"
+ :display-color 'sl:blue)
+
+ (:documentation "There may be more than one target volume for a
+patient, e.g., the boost volume and the large volume. Also, the tumor
+volume and the target volume are different.")
+
+ )
+
+;;;--------------------------------------
+
+(defmethod (setf site) :after (new-s (obj target))
+
+ (ev:announce obj (update-case obj))
+ (ev:announce obj (new-site obj) new-s))
+
+;;;--------------------------------------
+
+(defmethod (setf required-dose) :after (new-dos (obj target))
+
+ (declare (ignore new-dos))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defmethod (setf region) :after (new-reg (obj target))
+
+ (declare (ignore new-reg))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defmethod (setf target-type) :after (new-type (obj target))
+
+ (declare (ignore new-type))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defmethod (setf nodes) :after (new-nodes (obj target))
+
+ (declare (ignore new-nodes))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defmethod (setf average-size) :after (new-size (obj target))
+
+ (declare (ignore new-size))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defmethod (setf how-derived) :after (new-deriv (obj target))
+
+ (declare (ignore new-deriv))
+ (ev:announce obj (update-case obj)))
+
+;;;--------------------------------------
+
+(defun make-target (target-name &rest initargs)
+
+ (apply #'make-instance 'target
+ :name (if (equal target-name "")
+ (format nil "~A" (gensym "TARGET-"))
+ target-name)
+ initargs))
+
+;;;--------------------------------------
diff --git a/prism/src/wedge-graphics.cl b/prism/src/wedge-graphics.cl
new file mode 100644
index 0000000..f77f6ec
--- /dev/null
+++ b/prism/src/wedge-graphics.cl
@@ -0,0 +1,279 @@
+;;;
+;;; wedge-graphics
+;;;
+;;; this module contains the draw methods for wedges.
+;;;
+;;; 20-Sep-1996 I. Kalet created from beam-graphics.
+;;; 1-Mar-1997 I. Kalet update calls to NEARLY- functions
+;;; 26-Jun-1997 BobGian specialize CLIP to CLIP-FIXNUM in KEEP-IN-VIEW.
+;;; 03-Jul-1997 BobGian updated NEARLY-xxx -> poly:NEARLY-xxx .
+;;; 12-Aug-1997 BobGian CLIP-FIXNUM -> CLIP in KEEP-IN-VIEW (no more
+;;; need for separate versions of clipping code specialized on data type).
+;;; 25-Aug-1997 BobGian cosmetics in DRAW-WEDGE [abolishes compiler
+;;; warning].
+;;; 20-Jan-1998 I. Kalet beam transforms now array, not multiple
+;;; values, also add some declarations, eliminate some local vars.
+;;;
+
+(in-package :prism)
+
+;;;----------------------------------------------
+
+(defconstant *wedge-base-length* 2.0 "The length, model space, of the
+base of the triangle depicting the wedge in views.")
+
+(defconstant *wedge-height* 5.0 "The height, in model space, of the
+wedge triangle as it would appear in a view if the vector from wedge
+heel to wedge toe were parallel to the plane of the view.")
+
+;;;----------------------------------------------
+
+(defun draw-wedge (prim bt sad w-rot scale x-origin y-origin width height)
+
+ "DRAW-WEDGE prim bt sad w-rot scale x-origin y-origin width height
+
+Draws an icon representing a wedge into graphic primitive prim, based
+upon beam transform bt, source to axis distance sad, wedge-rotation
+w-rot, and the provided view plane scale, x-origin, and y-origin. The
+width and height parameters are the width and height of the picture
+into which the wedge is to be drawn."
+
+ ;; We transform two points from collimator space to view space -
+ ;; a point at the toe of the wedge, a point in the center of the
+ ;; of the wedge. These points define the wedge directional vector.
+
+ (declare (single-float sad w-rot)
+ (type (simple-array single-float (12)) bt))
+ (let* ((x-vec (cond ((= w-rot 90.0) (- *wedge-height*))
+ ((= w-rot 270.0) *wedge-height*)
+ (t 0.0)))
+ (y-vec (cond ((= w-rot 0.0) *wedge-height*)
+ ((= w-rot 180.0) (- *wedge-height*))
+ (t 0.0)))
+ (r02 (aref bt 2))
+ (r03 (aref bt 3))
+ (r12 (aref bt 6))
+ (r13 (aref bt 7))
+ (toe-x (+ (* (aref bt 0) x-vec)
+ (* (aref bt 1) y-vec)
+ (* r02 sad) r03))
+ (toe-y (+ (* (aref bt 4) x-vec)
+ (* (aref bt 5) y-vec)
+ (* r12 sad) r13))
+ (src-x (+ (* r02 sad) r03))
+ (src-y (+ (* r12 sad) r13)))
+ (declare (single-float x-vec y-vec r02 r03 r12 r13))
+ (setf (points prim)
+ (if (and (poly:nearly-equal toe-x src-x 0.1)
+ (poly:nearly-equal toe-y src-y 0.1))
+ ;; vector tip/tail coincide - cannot determine wedge gradient
+ (append
+ (draw-indecisive-icon toe-x toe-y src-x src-y r03 r13
+ scale x-origin y-origin
+ (* 0.5 *wedge-base-length*)
+ width height)
+ (points prim))
+ ;; vector tip and tail do not coincide
+ (append
+ (draw-triangle-icon toe-x toe-y src-x src-y r03 r13
+ scale x-origin y-origin
+ *wedge-base-length* width height)
+ (points prim))))))
+
+;;;----------------------------------------------
+
+(defun draw-bev-wedge (prim b-ptl blk-outs col-ang sid
+ w-rot v-pos scl x-orig y-orig width height)
+
+ "DRAW-BEV-WEDGE prim b-ptl blk-outs col-ang sid
+ w-rot v-pos scl x-orig y-orig width height
+
+Draws a wedge icon into graphics primitive prim for a beam's eye view
+based upon wedge rotation w-rot, source-to-isocenter distance sid, and
+collimator angle col-ang. The wedge icon is drawn outside of the beam
+portal and any block outlines (b-ptl & blk-outs resp). The bev scale,
+x-origin, y-origin, and view-position are also supplied."
+
+ ;; place the wedge icon just to the outside of the beam portal
+ ;; and block outlines in the bev.
+
+ (declare (single-float col-ang sid w-rot v-pos))
+ (let* ((x-vec (cond ((= w-rot 90.0) (- *wedge-height*))
+ ((= w-rot 270.0) *wedge-height*)
+ (t 0.0)))
+ (y-vec (cond ((= w-rot 0.0) *wedge-height*)
+ ((= w-rot 180.0) (- *wedge-height*))
+ (t 0.0)))
+ (bdr-gap 4.0)
+ (toe-x 0.0) (toe-y 0.0)
+ (ctr-x 0.0) (ctr-y 0.0)
+ (sin-c (sin col-ang))
+ (cos-c (cos col-ang))
+ (fac (/ (- sid v-pos) sid)) ;; assume wedge at isoctr
+ (ptl-list (apply #'append (cons b-ptl blk-outs))))
+ (declare (single-float x-vec y-vec bdr-gap toe-x toe-y
+ ctr-x ctr-y sin-c cos-c fac))
+ (cond
+ ((= w-rot 0.0)
+ (setq toe-x (+ x-vec
+ (apply #'min (mapcar #'first ptl-list))
+ (- bdr-gap))
+ toe-y y-vec
+ ctr-x toe-x
+ ctr-y 0.0))
+ ((= w-rot 90.0)
+ (setq toe-x x-vec
+ toe-y (+ y-vec
+ (apply #'min (mapcar #'second ptl-list))
+ (- bdr-gap))
+ ctr-x 0.0
+ ctr-y toe-y))
+ ((= w-rot 180.0)
+ (setq toe-x (+ x-vec
+ (apply #'max (mapcar #'first ptl-list))
+ bdr-gap)
+ toe-y y-vec
+ ctr-x toe-x
+ ctr-y 0.0))
+ ((= w-rot 270.0)
+ (setq toe-x x-vec
+ toe-y (+ y-vec
+ (apply #'max (mapcar #'second ptl-list))
+ bdr-gap)
+ ctr-x 0.0
+ ctr-y toe-y)))
+ ;; convert to view space
+ (setf (points prim)
+ (append (draw-triangle-icon
+ (* fac (- (* toe-x cos-c) (* toe-y sin-c)))
+ (* fac (+ (* toe-x sin-c) (* toe-y cos-c)))
+ (* fac (- (* ctr-x cos-c) (* ctr-y sin-c)))
+ (* fac (+ (* ctr-x sin-c) (* ctr-y cos-c)))
+ 0.0 0.0 scl x-orig y-orig
+ *wedge-base-length* width height)
+ (points prim)))))
+
+;;;----------------------------------------------
+
+(defun draw-indecisive-icon (pt-x pt-y xc yc xi yi scl x-orig y-orig bl w h)
+
+ "DRAW-INDECISIVE-ICON pt-x pt-y xc yc xi yi scl x-orig y-orig bl w h
+
+Draws a square with an X inside of it, centered at pt, with sides of
+length bl, signifying that a triangle cannot be drawn since there is
+no basis for determining the triangle's height or orientation. The
+scl, x-orig, and y-orig parameters are the scale and origin of the
+plane into which the square is drawn. Draws the icon at the edge of
+the picture along the line determined by (xc yc) and (xi yi) if it
+would otherwise run outside of it. Returns a list of the form {x1 y1
+x2 y2}* suitable for passing to clx:draw-segments."
+
+ (declare (single-float pt-x pt-y xc yc xi yi scl bl)
+ (fixnum x-orig y-orig w h))
+ (let* ((xt (pix-x pt-x x-orig scl))
+ (yt (pix-y pt-y y-orig scl))
+ (x-ctr (pix-x xc x-orig scl))
+ (y-ctr (pix-y yc y-orig scl))
+ (x-iso (pix-x xi x-orig scl))
+ (y-iso (pix-y yi y-orig scl))
+ (b (round (* scl bl)))
+ (xl (- xt b))
+ (yl (- yt b))
+ (xh (+ xt b))
+ (yh (+ yt b))
+ (result (list
+ (list xl yl) (list xl yh) (list xh yh) (list xh yl)
+ (list xl yl) (list xh yh) (list xh yl) (list xl yh))))
+ (declare (fixnum xt yt b))
+ (keep-in-view result x-iso y-iso x-ctr y-ctr w h)))
+
+;;;----------------------------------------------
+
+(defun draw-triangle-icon (xt yt xc yc xi yi scl x-orig y-orig bl w h)
+
+ "DRAW-TRIANGLE-ICON xt yt xc yc xi yi scl x-orig y-orig bl w h
+
+Draws an isosoles triangle with tip at (xt yt) and (xc yc) in the
+center of the triangle, using the supplied scale and origin
+parameters. Assumes that (xt yt) does not equal (xc yc), otherwise,
+the orientation of the triangle of the plane cannot be determined.
+The length of the base is bl. The w and h parameters are the
+width and height, respectively of the picture into which the icon will
+be drawn. If the icon would otherwise be drawn off the picture, it is
+drawn at the intersection the edge of the screen with the ray from (xc
+yc), understood to be the projection of the beam source into the
+plane, to (xi yi), understood to be the projection of the beam
+isocenter into the plane. Returns a list of the form {x1 y1 x2 y2}*
+suitable for passing to clx:draw-segments."
+
+ (declare (single-float xt yt xc yc bl))
+ (let* ((rlen (/ 1.0 (distance xt yt xc yc)))
+ (dx (* rlen (- xc xt)))
+ (dy (* rlen (- yc yt)))
+ (xb (- (* 2 xc) xt))
+ (yb (- (* 2 yc) yt))
+ (x-tip (pix-x xt x-orig scl))
+ (y-tip (pix-y yt y-orig scl))
+ (x-ctr (pix-x xc x-orig scl))
+ (y-ctr (pix-y yc y-orig scl))
+ (x-iso (pix-x xi x-orig scl))
+ (y-iso (pix-y yi y-orig scl))
+ (x-edg1 (pix-x (- xb (* bl dy)) x-orig scl))
+ (x-edg2 (pix-x (+ xb (* bl dy)) x-orig scl))
+ (y-edg1 (pix-y (+ yb (* bl dx)) y-orig scl))
+ (y-edg2 (pix-y (- yb (* bl dx)) y-orig scl)))
+ (declare (single-float rlen dx dy xb yb))
+ (keep-in-view (list (list x-ctr y-ctr)
+ (list x-tip y-tip)
+ (list x-edg1 y-edg1)
+ (list x-edg2 y-edg2)
+ (list x-tip y-tip))
+ x-iso y-iso x-ctr y-ctr w h)))
+
+;;;----------------------------------------------
+
+(defun keep-in-view (pts xi yi xc yc w h)
+
+ "KEEP-IN-VIEW pts xi yi xc yc w h
+
+Ensures that pts, a list of the form {(x y)}*, is inside the region
+bounded by (0,0) and (w,h). If the pts are outside this region, they
+are moved as necessary along the line determined by (xi yi) and (xc
+yc) to bring them back into the region. A list of the form {x1 y1 x2
+y2}* is returned, suitable for passing to clx:draw-segments."
+
+ (declare (fixnum xi yi xc yc w h))
+ (let* ((x-pts (mapcar #'first pts))
+ (y-pts (mapcar #'second pts))
+ (min-x (apply #'min x-pts))
+ (max-x (apply #'max x-pts))
+ (min-y (apply #'min y-pts))
+ (max-y (apply #'max y-pts))
+ (x1 xc)
+ (y1 yc)
+ (x2 (- (* 2 xi) xc))
+ (y2 (- (* 2 yi) yc))
+ (bdr-gap 5)
+ (xl-bdr (+ bdr-gap (- xc min-x)))
+ (yl-bdr (+ bdr-gap (- yc min-y)))
+ (xh-bdr (- (+ w xc) (+ bdr-gap max-x)))
+ (yh-bdr (- (+ h yc) (+ bdr-gap max-y))))
+ (declare (fixnum min-x max-x min-y max-y x1 y1 x2 y2
+ bdr-gap xl-bdr yl-bdr xh-bdr yh-bdr))
+ (when (clip x1 y1 x2 y2 xl-bdr yl-bdr xh-bdr yh-bdr)
+ (let ((dx (- x1 xc))
+ (dy (- y1 yc)))
+ (declare (fixnum dx dy))
+ (dolist (pt pts)
+ (incf (first pt) dx)
+ (incf (second pt) dy))))
+ (do* ((ptr pts (rest ptr))
+ (segs nil))
+ ((null (rest ptr)) segs)
+ (push (second (second ptr)) segs)
+ (push (first (second ptr)) segs)
+ (push (second (first ptr)) segs)
+ (push (first (first ptr)) segs))))
+
+;;;----------------------------------------------
+;;; End.
diff --git a/prism/src/wedges.cl b/prism/src/wedges.cl
new file mode 100644
index 0000000..e4b3bcb
--- /dev/null
+++ b/prism/src/wedges.cl
@@ -0,0 +1,93 @@
+;;;
+;;; wedges
+;;;
+;;; Definitions of wedge object and related code.
+;;;
+;;; 24-Jun-1994 J. Unger extract out of beam.
+;;; 5-Sep-1994 J. Unger add init-inst so other init keywords can be
+;;; supplied (and ignored).
+;;; 15-Jan-1995 I. Kalet move copy functions here from beams. Don't
+;;; monkey with beam and plan stuff here in setf methods, just
+;;; announce the events. Make beam-for slotname :ignored so don't
+;;; have to edit old data files.
+;;; 11-Sep-1995 I. Kalet delete display-color, never used. DON'T
+;;; round wedge rotation in copy-wedge-rotation, it must stay
+;;; single-float.
+;;; 26-Oct-1997 I. Kalet add default for rotation also, since beam
+;;; panel will insure valid values when changing wedge id.
+;;; 30-Jan-2000 I. Kalet delete copy-wedge and copy-wedge-rotation, no
+;;; longer needed.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------------------
+
+(defclass wedge (generic-prism-object)
+
+ ((id :type fixnum
+ :initarg :id
+ :accessor id
+ :documentation "The wedge id, as known to the dose computation
+program.")
+
+ (rotation :type single-float
+ :initarg :rotation
+ :accessor rotation
+ :documentation "The wedge rotation angle (currently available
+only on machines with multileaf collimators), not the steepness of the
+wedge profile.")
+
+ (new-id :type ev:event
+ :accessor new-id
+ :initform (ev:make-event)
+ :documentation "Announced when the wedge's ID changes.")
+
+ (new-rotation :type ev:event
+ :accessor new-rotation
+ :initform (ev:make-event)
+ :documentation "Announced when the wedge's rotation changes.")
+
+ )
+ (:default-initargs :id 0 :rotation 0.0)
+
+ (:documentation "A wedge is contained in a beam.")
+ )
+
+;;;---------------------------------------------
+
+(defmethod slot-type ((object wedge) slotname)
+
+ (case slotname
+ ((beam-for display-color) :ignore)
+ (otherwise :simple)))
+
+;;;---------------------------------------------
+
+(defmethod not-saved ((object wedge))
+
+ (append (call-next-method) '(new-rotation new-id name)))
+
+;;;---------------------------------------------
+
+(defun make-wedge (&rest initargs)
+
+ "make-wedge &rest initargs
+
+Returns a wedge object with the specified initialization args."
+
+ (apply #'make-instance 'wedge initargs))
+
+;;;---------------------------------------------
+
+(defmethod (setf id) :after (new-id (w wedge))
+
+ (ev:announce w (new-id w) new-id))
+
+;;;---------------------------------------------
+
+(defmethod (setf rotation) :after (new-rot (w wedge))
+
+ (ev:announce w (new-rotation w) new-rot))
+
+;;;---------------------------------------------
diff --git a/prism/src/write-neutron.cl b/prism/src/write-neutron.cl
new file mode 100644
index 0000000..9e7058d
--- /dev/null
+++ b/prism/src/write-neutron.cl
@@ -0,0 +1,1257 @@
+;;;
+;;; write-neutron.cl
+;;;
+;;; The neutron panel gui and supporting code.
+;;;
+;;; 21-Jun-1994 I. Kalet write stub functions.
+;;; 19-Jul-1994 J. Unger implement from spec.
+;;; 21-Jul-1994 J. Unger partially adapt to arb collim size. Needs work.
+;;; 28-Jul-1994 J. Unger work on some more; check in partial impl.
+;;; 02-Aug-1994 J. Unger impl leaf setting values.
+;;; 05-Aug-1994 J. Unger misc modifications.
+;;; 07-Aug-1994 J. Unger more mods to accommodate new cnts-coll & info.
+;;; 09-Aug-1994 J. Jacky fill in write-neutron-file (stub by jmu)
+;;; 10-Aug-1994 J. Jacky fix case wedge-rot -- rotation is float not fix
+;;; also, add no wedge case
+;;; 11-Aug-1994 J. Unger reverse beams before supplying to write-neutron-file.
+;;; 11-Aug-1994 J. Jacky on panel, scale collim rot, wedge rot to
+;;; machine coord on panel, "none" not NIL for wedge rot when no wedge
+;;; on panel, prescribed dose defaults to 1600 not 0
+;;; 11-Aug-1994 jmu/jpj don't attempt to write file if no beams selected
+;;; 15-Aug-1994 J. Jacky 5,1 not 5,2 format for leaf setting textlines
+;;; SCX control software only goes to nearest millimeter!
+;;; 23-Aug-1994 J. Jacky change centerline-list to edge-list
+;;; 23-Aug-1994 J. Unger change readouts to textlines; make editable.
+;;; 26-Aug-1994 J. Unger fix minor info/label bug in wedge-sel-btn
+;;; 30-Aug-1994 J. Unger add call to transfer output neutron file to VAXes.
+;;; 31-Aug-1994 J. Unger numerous final touches, impl neutron-beam class.
+;;; 11-Sep-1994 J. Unger change make-volatile-textline to make-textline and
+;;; add to destroy method.
+;;; 21-Sep-1994 J. Unger add plan date, slight reorganization of controls.
+;;; 23-Sep-1994 J. Unger remove label parameter from call to
+;;; interactive-make-neutron-charts.
+;;; 4-Oct-1994 J. Jacky Round monitor units to nearest whole monitor
+;;; unit throughout -- so total mu is always exactly equal to daily
+;;; mu times number of fractions, and number written out to file is
+;;; always of form nnn.0
+;;; 4-Oct-1994 J. Unger minor change to plan-of pointer in call to
+;;; write-neutron-file.
+;;; 19-Oct-1994 J. Jacky Don't assume integer items will be integers
+;;; --- we find n of fractions in some Prism case files are floats;
+;;; printing these in CL "a" format makes files unreadable by SCX
+;;; software. Fix: explicitly round, then print using CL "d" format.
+;;; CL "d" requires integer, but CL "round" arg can be any numeric type.
+;;; 21-Oct-1994 J. Unger change default presc dose to 0, put patient
+;;; name in title.
+;;; 19-Jan-1995 I. Kalet use current beam of panel instead of beam-for
+;;; of wedge (wedges no longer have back pointers). Add plan to beam
+;;; pairs in output-alist.
+;;; 9-Mar-1995 I. Kalet/J. Jacky write a 1, for 90 degrees, instead
+;;; of a 0, 0 degrees, for wedge rotation code, when there is no
+;;; wedge.
+;;; 3-Sep-1995 I. Kalet take out beams-differ - not used anywhere
+;;; 5-Jun-1997 I. Kalet machine returns the object, not the name
+;;; 25-Aug-1997 I. Kalet remove invalid type specifier for
+;;; collim-info, use the machine named CNTS-BLOCKS for collim-info
+;;; cache, don't search the whole database.
+;;; 16-Sep-1997 I. Kalet database in get-therapy-machine now required.
+;;; Also make panel parameters local, not special.
+;;; 24-Oct-1997 I. Kalet wedge-rot-angles now needs wedge id parameter
+;;; 2-May-1998 I. Kalet use new chart-panel for printing chart pages
+;;; 24-Dec-1998 I. Kalet take out wait t in run-subprocess, now default
+;;; 22-Apr-1999 J. Jacky Revisions for new CNTS control system
+;;; In this version run-subprocess cnts_xfer not neutron_xfer
+;;; Record 11 change from 2-digit to 4-digit year for Y2K
+;;; just simplify calculation of output-date in initialize-instance
+;;; Record 21 print out pat-id, case-id, time-stamp for QA traceability
+;;; pass these as additional parameters to write-neutron
+;;; Record 22 add transfer date, transfer user for info on Select Field screen
+;;; Record 22 add also completion status, origin, and parent field
+;;; 23-Apr-1999 Change prompt "...10 to 30 seconds..." to "a few seconds"
+;;; 2-Jan-2000 I. Kalet add #+allegro qualifier to call to sys:getenv
+;;; 23-Jan-2000 I. Kalet restore missing fix of 15-Sep-1999: adjust
+;;; for changes to compute-mlc in regard to collimator angle.
+;;; 17-Feb-2000 I. Kalet add code to set wedge parameters after call
+;;; to copy-beam, since copy-beam now always deletes the wedge. Also,
+;;; make sure wedge rotation displayed as NONE when no wedge is selected.
+;;; 23-Feb-2000 I. Kalet change copy-beam to just copy, so no need to
+;;; separately set the wedge parameters.
+;;; 19-Mar-2000 I. Kalet revisions for new chart code.
+;;; 29-Jun-2000 I. Kalet modify signature of make-neutron-panel to fit
+;;; new style of tools panel function invocation.
+;;; 23-Feb-2001 J. Jacky write-neutron-file: new seq-trunc truncates strings
+;;; to max. field width.
+;;; 24-Feb-2001 I. Kalet add end line, take out blank lines.
+;;; 17-Feb-2005 A. Simms replace occurrence of sys:getenv with misc.cl
+;;; getenv function.
+;;; 19-May-2010 I. Kalet textlines return strings so use
+;;; read-from-string before using format to write back values to leaf
+;;; textlines.
+;;;
+
+(in-package :prism)
+
+;;;--------------------------------------
+
+(defclass neutron-panel (generic-panel)
+
+ ((fr :type sl:frame
+ :accessor fr
+ :documentation "The SLIK frame that contains the neutron panel.")
+
+ (del-pnl-btn ;; :type sl:button
+ :accessor del-pnl-btn
+ :documentation "The delete panel button for this panel.")
+
+ (add-beam-btn ;; :type sl:button
+ :accessor add-beam-btn
+ :documentation "The add beam button for this panel.")
+
+ (write-file-btn ;; :type sl:button
+ :accessor write-file-btn
+ :documentation "The write file button for this panel.")
+
+ (comments-box ;; :type sl:textbox
+ :accessor comments-box
+ :documentation "The plan comments box for this panel.")
+
+ (comments-label ;; :type sl:readout
+ :accessor comments-label
+ :documentation "The label for this panel's comments box.")
+
+ (beam-rdt ;; :type sl:readout
+ :accessor beam-rdt
+ :documentation "The beam readout for this panel.")
+
+ (plan-rdt ;; :type sl:readout
+ :accessor plan-rdt
+ :documentation "The plan name readout for this panel.")
+
+ (date-rdt ;; :type sl:readout
+ :accessor date-rdt
+ :documentation "The plan date readout for this panel.")
+
+ (plan-scr ;; :type sl:scrolling-list
+ :accessor plan-scr
+ :documentation "A scrolling list of available plans.")
+
+ (plan-label ;; :type sl:readout
+ :accessor plan-label
+ :documentation "The label for the plans scrolling list.")
+
+ (beam-scr ;; :type sl:scrolling-list
+ :accessor beam-scr
+ :documentation "A scrolling list of available beams.")
+
+ (beam-label ;; :type sl:readout
+ :accessor beam-label
+ :documentation "The label for the beams scrolling list.")
+
+ (output-scr ;; :type sl:scrolling-list
+ :accessor output-scr
+ :documentation "A scrolling list of beams that are
+to be output by the neutron panel.")
+
+ (output-label ;; :type sl:readout
+ :accessor output-label
+ :documentation "The label for the output scrolling list.")
+
+ (phys-name-tln ;; :type sl:readout
+ :accessor phys-name-tln
+ :documentation "The physician's name textline.")
+
+ (presc-dose-tln ;; :type sl:readout
+ :accessor presc-dose-tln
+ :documentation "The prescribed dose textline.")
+
+ (gan-start-tln ;; :type sl:textline
+ :accessor gan-start-tln
+ :documentation "The gantry starting angle textline.")
+
+ (gan-stop-tln ;; :type sl:textline
+ :accessor gan-stop-tln
+ :documentation "The gantry stopping angle textline.")
+
+ (n-treat-tln ;; :type sl:textline
+ :accessor n-treat-tln
+ :documentation "The num treatments textline.")
+
+ (tot-mu-rdt ;; :type sl:readout
+ :accessor tot-mu-rdt
+ :documentation "The total monitor units readout.")
+
+ (mu-treat-tln ;; :type sl:textline
+ :accessor mu-treat-tln
+ :documentation "The monitor units per treatment textline.")
+
+ (col-ang-tln ;; :type sl:textline
+ :accessor col-ang-tln
+ :documentation "The collimator angle textline.")
+
+ (couch-ang-tln ;; :type sl:textline
+ :accessor couch-ang-tln
+ :documentation "The couch angle textline.")
+
+ (wdg-sel-btn ;; :type sl:button
+ :accessor wdg-sel-btn
+ :documentation "The wedge selection button.")
+
+ (wdg-rot-btn ;; :type sl:button
+ :accessor wdg-rot-btn
+ :documentation "The wedge rotation button.")
+
+ (left-leaf-tlns ;; :type list
+ :accessor left-leaf-tlns
+ :initform nil
+ :documentation "A list of left side mlc leaf textlines.")
+
+ (right-leaf-tlns ;; :type list
+ :accessor right-leaf-tlns
+ :initform nil
+ :documentation "A list of right side mlc leaf textlines.")
+
+ (plan-alist :type list
+ :accessor plan-alist
+ :initform nil
+ :documentation "An assoc list of plans and buttons in
+the panel's scrolling list of plans.")
+
+ (beam-alist :type list
+ :accessor beam-alist
+ :initform nil
+ :documentation "An assoc list of beams and buttons in
+the panel's scrolling list of beams.")
+
+ (output-alist :type list
+ :accessor output-alist
+ :initform nil
+ :documentation "The association list of (original-beam
+current-beam) pairs and buttons in the panel's scrolling list of beams to
+be output.")
+
+ (current-patient :type patient
+ :accessor current-patient
+ :initarg :current-patient
+ :documentation "The current patient for the
+neutron panel, supplied at initialization time.")
+
+ (current-plan :type plan
+ :accessor current-plan
+ :initform nil
+ :documentation "The plan that the neutron panel is
+currently displaying.")
+
+ (current-beam :type beam
+ :accessor current-beam
+ :initform nil
+ :documentation "The beam that the neutron panel is
+currently displaying.")
+
+ (original-beam :type beam
+ :accessor original-beam
+ :initform nil
+ :documentation "The original version of the beam that
+the neutron panel is currently displaying.")
+
+ (phys-name :type string
+ :accessor phys-name
+ :initform "NO PHYS NAME"
+ :documentation "The physician name")
+
+ (presc-dose :type fixnum
+ :accessor presc-dose
+ :initform 0
+ :documentation "The prescribed dose")
+
+ (collim-info :accessor collim-info
+ :documentation "A cache for the collimator info of the
+current beam.")
+
+ )
+
+ (:documentation "The neutron panel is used to select plans and beams
+for subsequent writing to the filesystem and (outside of prism) later
+transfer to the cyclotron.")
+
+ )
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((np neutron-panel) &rest initargs)
+
+ "Initializes the neutron panel gui."
+
+ (let* ((np-off 10) ; Intercontrol spacing factor
+ (np-rdt-ht 30) ; readout height
+ (np-rdt-base 80) ; base readout width
+ (np-scr-ht (* 4 np-rdt-ht)) ; scrolling list height
+ (np-tb-ht (* 3 np-rdt-ht)) ; textbox height
+ (np-wd (+ (* 6 np-off)
+ (* 10 np-rdt-base))) ; panel width
+ (np-ht (+ (* 11 np-rdt-ht)
+ (* 12 np-off)
+ np-scr-ht
+ np-tb-ht)) ; panel height
+ (np-tl-color 'sl:green) ; textline border color
+ (np-rdt-color 'sl:white) ; readout border color
+ (np-bt-color 'sl:cyan) ; button border color
+ (frm (apply #'sl:make-frame np-wd np-ht
+ :title (format nil "Prism NEUTRON Panel -- ~a"
+ (name (current-patient np)))
+ initargs))
+ (frm-win (sl:window frm))
+ (cmts-r (apply #'sl:make-readout
+ (* 2 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 6 np-off) (* 5 np-rdt-ht)
+ np-scr-ht)
+ :border-color 'sl:black
+ :label "Plan Comments:"
+ initargs))
+ (cmts-bx (apply #'sl:make-textbox
+ (+ (* 6 np-rdt-base) (* 2 np-off))
+ np-tb-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 6 np-off) (* 6 np-rdt-ht)
+ np-scr-ht)
+ :border-color np-rdt-color
+ initargs))
+ (date-r (apply #'sl:make-readout
+ (+ (* 6 np-rdt-base) (* 2 np-off))
+ np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 4 np-off) (* 3 np-rdt-ht)
+ np-scr-ht)
+ :border-color np-rdt-color
+ :label "Plan Date: "
+ initargs))
+ (plan-r (apply #'sl:make-readout
+ (+ (* 6 np-rdt-base) (* 2 np-off))
+ np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 3 np-off) (* 2 np-rdt-ht)
+ np-scr-ht)
+ :border-color np-rdt-color
+ :label "Plan Name: "
+ initargs))
+ (beam-r (apply #'sl:make-readout
+ (+ (* 6 np-rdt-base) (* 2 np-off))
+ np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 5 np-off) (* 4 np-rdt-ht)
+ np-scr-ht)
+ :border-color np-rdt-color
+ :label "Beam Name: "
+ initargs))
+ (plan-l (apply #'sl:make-readout
+ (round (* 1.5 np-rdt-base)) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ np-rdt-ht (* 2 np-off))
+ :border-color 'sl:black
+ :label "Plans:"
+ initargs))
+ (plan-s (apply #'sl:make-radio-scrolling-list
+ (round (* 1.5 np-rdt-base)) np-scr-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 2 np-off) (* 2 np-rdt-ht))
+ :border-color np-bt-color
+ initargs))
+ (beam-l (apply #'sl:make-readout
+ (round (* 1.5 np-rdt-base)) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 np-off) (sl:width plan-s))
+ :ulc-y (+ np-rdt-ht (* 2 np-off))
+ :border-color 'sl:black
+ :label "Beams:"
+ initargs))
+ (beam-s (apply #'sl:make-radio-scrolling-list
+ (round (* 1.5 np-rdt-base)) np-scr-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 np-off) (sl:width plan-s))
+ :ulc-y (+ (* 2 np-off) (* 2 np-rdt-ht))
+ :border-color np-bt-color
+ initargs))
+ (output-l (apply #'sl:make-readout
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 2 (sl:width plan-s)))
+ :ulc-y (+ np-rdt-ht (* 2 np-off))
+ :border-color 'sl:black
+ :label "Output:"
+ initargs))
+ (output-s (apply #'sl:make-scrolling-list
+ (* 3 np-rdt-base) np-scr-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 2 (sl:width plan-s)))
+ :ulc-y (+ (* 2 np-off) (* 2 np-rdt-ht))
+ :enable-delete t
+ :border-color np-bt-color
+ initargs))
+ (del-pnl-b (apply #'sl:make-button
+ (* 2 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off :ulc-y np-off
+ :label "Del Panel"
+ :button-type :momentary
+ :border-color np-bt-color
+ initargs))
+ (add-beam-b (apply #'sl:make-button
+ (* 2 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 np-off) (* 2 np-rdt-base))
+ :ulc-y np-off
+ :label "Add Beam"
+ :button-type :momentary
+ :border-color np-bt-color
+ initargs))
+ (write-file-b (apply #'sl:make-button
+ (* 2 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 4 np-rdt-base))
+ :ulc-y np-off
+ :label "Write File"
+ :button-type :momentary
+ :border-color np-bt-color
+ initargs))
+ (phys-name-t (apply #'sl:make-textline
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 7 np-off) (* 9 np-rdt-ht)
+ np-scr-ht)
+ :label "Phys name: "
+ :border-color np-tl-color
+ initargs))
+ (presc-dose-t (apply #'sl:make-textline
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 3 np-rdt-base))
+ :ulc-y (+ (* 7 np-off) (* 9 np-rdt-ht)
+ np-scr-ht)
+ :label "Presc Dose: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 10000.0
+ :border-color np-tl-color
+ initargs))
+ (gan-start-t (apply #'sl::make-textline
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 8 np-off) (* 10 np-rdt-ht)
+ np-scr-ht)
+ :label "Gan start: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 359.9
+ :border-color np-tl-color
+ initargs))
+ (gan-stop-t (apply #'sl:make-textline
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 3 np-rdt-base))
+ :ulc-y (+ (* 8 np-off) (* 10 np-rdt-ht)
+ np-scr-ht)
+ :label "Gan Stop: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 359.9
+ :border-color np-tl-color
+ initargs))
+ (n-treat-t (apply #'sl:make-textline
+ (* 2 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 11 np-off) (* 13 np-rdt-ht)
+ np-scr-ht)
+ :label "N Treat: "
+ :numeric t
+ :lower-limit 0 :upper-limit 99
+ :border-color np-tl-color
+ initargs))
+ (tot-mu-r (apply #'sl:make-readout
+ (* 2 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 4 np-rdt-base))
+ :ulc-y (+ (* 11 np-off) (* 13 np-rdt-ht)
+ np-scr-ht)
+ :label "Tot Mu: "
+ :border-color np-rdt-color
+ initargs))
+ (mu-treat-t (apply #'sl:make-textline
+ (* 2 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 2 np-off) (* 2 np-rdt-base))
+ :ulc-y (+ (* 11 np-off) (* 13 np-rdt-ht)
+ np-scr-ht)
+ :label "Mu/Treat: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 999.0
+ :border-color np-tl-color
+ initargs))
+ (col-ang-t (apply #'sl:make-textline
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 9 np-off) (* 11 np-rdt-ht)
+ np-scr-ht)
+ :label "Collim Ang: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 359.9
+ :border-color np-tl-color
+ initargs))
+ (couch-ang-t (apply #'sl:make-textline
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 3 np-rdt-base))
+ :ulc-y (+ (* 9 np-off) (* 11 np-rdt-ht)
+ np-scr-ht)
+ :label "Couch Ang: "
+ :numeric t
+ :lower-limit 0.0 :upper-limit 359.9
+ :border-color np-tl-color
+ initargs))
+ (wdg-sel-b (apply #'sl:make-button
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x np-off
+ :ulc-y (+ (* 10 np-off) (* 12 np-rdt-ht)
+ np-scr-ht)
+ :label "Wedge Sel: No wedge"
+ :border-color np-bt-color
+ initargs))
+ (wdg-rot-b (apply #'sl:make-button
+ (* 3 np-rdt-base) np-rdt-ht
+ :parent frm-win
+ :ulc-x (+ (* 3 np-off) (* 3 np-rdt-base))
+ :ulc-y (+ (* 10 np-off) (* 12 np-rdt-ht)
+ np-scr-ht)
+ :label "Wedge Rot: NONE"
+ :border-color np-bt-color
+ initargs)))
+ (setf
+ (fr np) frm
+ (comments-box np) cmts-bx
+ (comments-label np) cmts-r
+ (beam-rdt np) beam-r
+ (plan-rdt np) plan-r
+ (date-rdt np) date-r
+ (plan-label np) plan-l
+ (plan-scr np) plan-s
+ (beam-label np) beam-l
+ (beam-scr np) beam-s
+ (output-label np) output-l
+ (output-scr np) output-s
+ (del-pnl-btn np) del-pnl-b
+ (add-beam-btn np) add-beam-b
+ (write-file-btn np) write-file-b
+ (phys-name-tln np) phys-name-t
+ (presc-dose-tln np) presc-dose-t
+ (gan-start-tln np) gan-start-t
+ (gan-stop-tln np) gan-stop-t
+ (n-treat-tln np) n-treat-t
+ (tot-mu-rdt np) tot-mu-r
+ (mu-treat-tln np) mu-treat-t
+ (col-ang-tln np) col-ang-t
+ (couch-ang-tln np) couch-ang-t
+ (wdg-sel-btn np) wdg-sel-b
+ (wdg-rot-btn np) wdg-rot-b)
+ ;; Set the collim-info cache for the panel. Use the machine named
+ ;; CNTS-BLOCKS in the therapy-machines database to set up the leaf
+ ;; textlines in this panel.
+ (setf (collim-info np)
+ (collimator-info (get-therapy-machine "CNTS-BLOCKS"
+ *therapy-machine-database*
+ *machine-index-directory*)))
+ ;; setup leaf textlines
+ (do* ((collim-info (collim-info np))
+ (column-len (1- (length (edge-list collim-info))))
+ (width (* 2 np-rdt-base))
+ (height (round (/ (- np-ht (* 2 np-off)) column-len)))
+ (leaf-pairs (leaf-pair-map collim-info) (rest leaf-pairs))
+ (xl (+ (* 6 np-rdt-base) (* 4 np-off)))
+ (xr (+ (* 8 np-rdt-base) (* 5 np-off)))
+ (y np-off (+ y height))
+ (i 0 (1+ i)))
+ ((= i column-len))
+ (push
+ (sl:make-textline width height
+ :parent frm-win
+ :ulc-x xl :ulc-y y
+ :numeric t
+ :lower-limit (- (leaf-open-limit
+ (collim-info np)))
+ :upper-limit (leaf-overcenter-limit
+ (collim-info np))
+ :label (format nil "Leaf ~2 at a: "
+ (first (first leaf-pairs)))
+ :border-color np-tl-color
+ :volatile-width 4) ; shows up better
+ (left-leaf-tlns np))
+ (push
+ (sl:make-textline width height
+ :parent frm-win
+ :ulc-x xr :ulc-y y
+ :numeric t
+ :lower-limit (- (leaf-overcenter-limit
+ (collim-info np)))
+ :upper-limit (leaf-open-limit (collim-info np))
+ :label (format nil "Leaf ~2 at a: "
+ (second (first leaf-pairs)))
+ :border-color np-tl-color
+ :volatile-width 4) ; shows up better
+ (right-leaf-tlns np)))
+ (setf (left-leaf-tlns np) (reverse (left-leaf-tlns np)))
+ (setf (right-leaf-tlns np) (reverse (right-leaf-tlns np)))
+ ;; setup plan scrolling list
+ (dolist (pln (coll:elements (plans (current-patient np))))
+ (let ((btn (sl:make-list-button (plan-scr np) (name pln))))
+ (sl:insert-button btn (plan-scr np))
+ (setf (plan-alist np) (acons pln btn (plan-alist np)))))
+ ;; setup physician name and prescribed dose text fields
+ (setf (sl:info phys-name-t) (phys-name np))
+ (setf (sl:info presc-dose-t) (write-to-string (presc-dose np)))
+ ;; setup add-notifies
+ (ev:add-notify np (sl:selected plan-s)
+ #'(lambda (np ann p-btn)
+ (declare (ignore ann))
+ (when (current-beam np)
+ (ev:remove-notify
+ np (new-id (wedge (current-beam np))))
+ (ev:remove-notify
+ np (new-rotation (wedge (current-beam np)))))
+ (setf (original-beam np) nil)
+ (setf (current-beam np) nil)
+ (setf (current-plan np)
+ (first (rassoc p-btn (plan-alist np))))))
+ (ev:add-notify np (sl:selected beam-s)
+ #'(lambda (np ann b-btn)
+ (declare (ignore ann))
+ (when (current-beam np)
+ (ev:remove-notify
+ np (new-id (wedge (current-beam np))))
+ (ev:remove-notify
+ np (new-rotation (wedge (current-beam np)))))
+ (setf (original-beam np)
+ (first (rassoc b-btn (beam-alist np))))
+ (setf (current-beam np) (copy (original-beam np)))
+ ;; register with the current beam's wedge's id
+ ;; and rotation events
+ (ev:add-notify
+ np (new-id (wedge (current-beam np)))
+ #'(lambda (np wdg id)
+ (declare (ignore wdg))
+ (if (zerop id) (setf (sl:label (wdg-rot-btn np))
+ "Wedge Rot: NONE"))
+ (setf (sl:label (wdg-sel-btn np))
+ (format nil "Wedge Sel: ~a"
+ (wedge-label id (machine
+ (current-beam np)))))))
+ (ev:add-notify
+ np (new-rotation (wedge (current-beam np)))
+ #'(lambda (np wdg rot)
+ (if (zerop (id wdg))
+ (setf (sl:label (wdg-rot-btn np))
+ "Wedge Rot: NONE")
+ (let ((mach (machine
+ (current-beam np))))
+ (setf (sl:label (wdg-rot-btn np))
+ (format nil "Wedge Rot: ~a"
+ (first (scale-angle
+ rot
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach)))))))
+ ))))
+ (ev:add-notify np (sl:deselected plan-s)
+ #'(lambda (np a btn)
+ (declare (ignore a btn))
+ (setf (current-plan np) nil)))
+ (ev:add-notify np (sl:deselected beam-s)
+ #'(lambda (np a btn)
+ (declare (ignore a btn))
+ (when (current-beam np)
+ (ev:remove-notify
+ np (new-id (wedge (current-beam np))))
+ (ev:remove-notify
+ np (new-rotation (wedge (current-beam np)))))
+ (setf (original-beam np) nil)
+ (setf (current-beam np) nil)))
+ (ev:add-notify np (sl:button-on del-pnl-b)
+ #'(lambda (np a)
+ (declare (ignore a))
+ (destroy np)))
+ (ev:add-notify np (sl:button-on add-beam-b)
+ #'(lambda (np a)
+ (declare (ignore a))
+ (if (and (current-plan np) (current-beam np))
+ (let ((a-btn (sl:make-list-button
+ (output-scr np)
+ (format nil "~a - ~a"
+ (name (current-beam
+ np))
+ (name (current-plan np)))
+ :button-type :momentary)))
+ (sl:insert-button a-btn (output-scr np))
+ (setf (output-alist np)
+ (acons
+ (list (original-beam np)
+ (current-beam np)
+ (current-plan np))
+ a-btn
+ (output-alist np))))
+ (sl:acknowledge "Please select a beam to add."))
+ (setf (sl:on add-beam-b) nil)))
+ (ev:add-notify np (sl:button-on write-file-b)
+ #'(lambda (np a)
+ (declare (ignore a))
+ (if (sl:confirm
+ '("Ready to transfer neutron file."
+ "This may take a few seconds."
+ "A chart dialog box will be displayed when finished."
+ "During transfer, please wait for chart dialog box."
+ "Ok to continue?"))
+ (if (output-alist np)
+ (let* ((dts (date-time-string))
+ (blank (position #\Space dts))
+ (date (subseq dts 0 blank))
+ (fp (open *neutron-setup-file*
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create))
+ (beam-pairs (mapcar #'first
+ (output-alist np)))
+ (pln (third (first beam-pairs)))
+ (pat (current-patient np))
+ (output-date (if (= 11 (length date))
+ date
+ (format nil " ~a" date))))
+ ;; long wait coming up, ignore user input
+ (sl:push-event-level)
+ (write-neutron-file
+ fp (patient-id pat)
+ (case-id pat) (time-stamp pln) (name pat)
+ ; different beams in list may come from
+ ; different plans so time-stamp may be
+ ; wrong for some beams - JJ 4/22/99
+ (hospital-id pat) output-date
+ (first (comments pln))
+ (phys-name np) (presc-dose np)
+ (reverse ; current beams
+ (mapcar #'second beam-pairs)))
+ (close fp)
+ (run-subprocess "cnts_xfer")
+ (sl:pop-event-level) ; long wait is over
+ (chart-panel 'neutron
+ pat nil beam-pairs dts))
+ ;; used to say "destroy np" but causes
+ ;; asynch drawable error
+ (sl:acknowledge
+ "No beams selected; NO file transferred!"))
+ (sl:acknowledge "Neutron file NOT transferred!"))
+ (setf (sl:on write-file-b) nil)))
+ (ev:add-notify np (sl:deleted output-s)
+ #'(lambda (np a btn)
+ (declare (ignore a))
+ (let ((pair (rassoc btn (output-alist np))))
+ (setf (output-alist np)
+ (remove pair (output-alist np))))))
+ (ev:add-notify np (sl:new-info phys-name-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (setf (phys-name np) info)))
+ (ev:add-notify np (sl:new-info presc-dose-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (setf (presc-dose np)
+ (round (read-from-string info)))))
+ (ev:add-notify np (sl:new-info gan-start-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (if (current-beam np)
+ (let* ((cb (current-beam np))
+ (mach (machine cb)))
+ (setf (gantry-angle cb)
+ (inverse-scale-angle
+ (read-from-string info)
+ (gantry-scale mach)
+ (gantry-offset mach)))
+ (setf (arc-size cb) 0.0)
+ (setf (sl:info gan-start-t)
+ (format nil "~6,1F" (read-from-string info)))
+ (setf (sl:info gan-stop-t)
+ (format nil "~6,1F" (sl:info gan-start-t))))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info gan-start-t) "")))))
+ (ev:add-notify np (sl:new-info gan-stop-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (if (current-beam np)
+ (let* ((cb (current-beam np))
+ (mach (machine cb)))
+ (setf (arc-size cb)
+ (- (inverse-scale-angle
+ (read-from-string info)
+ (gantry-scale mach)
+ (gantry-offset mach))
+ (gantry-angle cb)))
+ (setf (sl:info gan-stop-t)
+ (format nil "~6,1F" (read-from-string info))))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info gan-stop-t) "")))))
+ (ev:add-notify np (sl:new-info n-treat-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (if (current-beam np)
+ (let ((cb (current-beam np)))
+ (setf (n-treatments cb)
+ (truncate (read-from-string info)))
+ (setf (monitor-units cb)
+ (* (n-treatments cb)
+ (round (read-from-string
+ (sl:info mu-treat-t)))))
+ (setf (sl:info tot-mu-r)
+ (let* ((mu-tot (monitor-units cb))
+ (n (n-treatments cb))
+ (r-mu-per-frac (round (/ mu-tot n))))
+ (* r-mu-per-frac n))))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info n-treat-t) "")))))
+ (ev:add-notify np (sl:new-info mu-treat-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (if (current-beam np)
+ (let ((cb (current-beam np)))
+ (setf (monitor-units cb)
+ (* (n-treatments cb)
+ (round (read-from-string info))))
+ (setf (sl:info tot-mu-r)
+ (let* ((mu-tot (round (monitor-units cb)))
+ (n (n-treatments cb))
+ (r-mu-per-frac (round (/ mu-tot n))))
+ (* r-mu-per-frac n))))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info mu-treat-t) "")))))
+ (ev:add-notify np (sl:new-info col-ang-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (if (current-beam np)
+ (let* ((cb (current-beam np))
+ (mach (machine cb)))
+ (setf (collimator-angle cb)
+ (inverse-scale-angle
+ (read-from-string info)
+ (collimator-scale mach)
+ (collimator-offset mach)))
+ (setf (sl:info col-ang-t)
+ (format nil "~6,1F" (read-from-string info))))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info col-ang-t) "")))))
+ (ev:add-notify np (sl:new-info couch-ang-t)
+ #'(lambda (np a info)
+ (declare (ignore a))
+ (if (current-beam np)
+ (let* ((cb (current-beam np))
+ (mach (machine cb)))
+ (setf (couch-angle cb)
+ (inverse-scale-angle
+ (read-from-string info)
+ (turntable-scale mach)
+ (turntable-offset mach)))
+ (setf (sl:info couch-ang-t)
+ (format nil "~6,1F" (read-from-string info))))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info couch-ang-t) "")))))
+ (ev:add-notify np (sl:button-on wdg-sel-b)
+ #'(lambda (np a)
+ (declare (ignore a))
+ (if (current-beam np)
+ (let* ((cb (current-beam np))
+ (mach (machine cb))
+ (new-wdg-no (sl:popup-menu
+ (wedge-names mach))))
+ (when new-wdg-no
+ (setf (id (wedge cb)) new-wdg-no)))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:label wdg-sel-b) "Wedge Sel: No wedge")))
+ (setf (sl:on wdg-sel-b) nil)))
+ (ev:add-notify np (sl:button-on wdg-rot-b)
+ #'(lambda (np a)
+ (declare (ignore a))
+ (if (current-beam np)
+ (if (zerop (id (wedge (current-beam np))))
+ (sl:acknowledge "Please select a wedge first.")
+ (let* ((cb (current-beam np))
+ (mach (machine cb))
+ (angles (wedge-rot-angles (id (wedge cb))
+ mach))
+ (scl-ang (mapcar
+ #'(lambda (angle)
+ (first
+ (scale-angle
+ angle
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach))))
+ angles))
+ (pos (sl:popup-menu
+ (mapcar #'write-to-string scl-ang)))
+ (choice (when pos (nth pos angles))))
+ (when choice
+ (setf (rotation (wedge cb)) choice))))
+ (sl:acknowledge "Please select a beam first."))
+ (setf (sl:on wdg-rot-b) nil)))
+ ;; add-notifies for the leaf textlines
+ (do ((left-tlns (left-leaf-tlns np) (rest left-tlns))
+ (right-tlns (right-leaf-tlns np) (rest right-tlns)))
+ ((null left-tlns))
+ (ev:add-notify np (sl:new-info (first left-tlns))
+ #'(lambda (np tln info)
+ (if (current-beam np)
+ (let* ((pos (position tln (left-leaf-tlns np)))
+ (cb (current-beam np))
+ (ls (leaf-settings (collimator cb)))
+ (float-info
+ (float (read-from-string info))))
+ (setf (sl:info tln)
+ (format nil "~5,1F" float-info))
+ (setf (first (nth pos ls))
+ float-info))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info tln) "")))))
+ (ev:add-notify np (sl:new-info (first right-tlns))
+ #'(lambda (np tln info)
+ (if (current-beam np)
+ (let* ((pos (position tln (right-leaf-tlns np)))
+ (cb (current-beam np))
+ (ls (leaf-settings (collimator cb)))
+ (float-info
+ (float (read-from-string info))))
+ (setf (sl:info tln)
+ (format nil "~5,1F" float-info))
+ (setf (second (nth pos ls))
+ float-info))
+ (progn
+ (sl:acknowledge "Please select a beam first.")
+ (setf (sl:info tln) ""))))))))
+
+;;;---------------------------------------------
+
+(defmethod (setf current-plan) :after (new-plan (np neutron-panel))
+
+ (if new-plan
+ (progn
+ ;; fill up beams scrolling list and alist w/ new info -- only beams
+ ;; w/collimators of type cnts-coll are considered.
+ (dolist (bm (remove-if-not
+ #'(lambda (coll) (typep coll 'cnts-coll))
+ (coll:elements (beams new-plan))
+ :key #'collimator))
+ (let ((b-btn (sl:make-list-button (beam-scr np) (name bm))))
+ (sl:insert-button b-btn (beam-scr np))
+ (setf (beam-alist np) (acons bm b-btn (beam-alist np)))))
+ ; fill in plan readout
+ (setf (sl:info (plan-rdt np)) (name new-plan))
+ (setf (sl:info (date-rdt np)) (time-stamp new-plan))
+ ;; fill in plan-specific info on panel
+ (setf (sl:info (comments-box np)) (comments new-plan)))
+ (progn ;; clean out beams scrolling list and alist
+ (dolist (b-btn (sl:buttons (beam-scr np)))
+ (sl:delete-button b-btn (beam-scr np)))
+ (setf (beam-alist np) nil) ;; clear plan-specific info on panel
+ (setf (sl:info (plan-rdt np)) "")
+ (setf (sl:info (date-rdt np)) "")
+ (setf (sl:info (comments-box np)) '("")))))
+
+;;;---------------------------------------------
+
+(defmethod (setf current-beam) :after (new-beam (np neutron-panel))
+
+ (if new-beam
+ (let ((mach (machine new-beam)))
+ (setf (sl:info (beam-rdt np)) (name new-beam))
+ (setf (sl:info (gan-start-tln np))
+ (format nil "~6,1F" (first (scale-angle
+ (gantry-angle new-beam)
+ (gantry-scale mach)
+ (gantry-offset mach)))))
+ (setf (sl:info (gan-stop-tln np))
+ (format nil "~6,1F"
+ (mod (+ (gantry-angle new-beam) (arc-size new-beam)) 360)))
+ (setf (sl:info (couch-ang-tln np))
+ (format nil "~6,1F" (first (scale-angle
+ (couch-angle new-beam)
+ (turntable-scale mach)
+ (turntable-offset mach)))))
+ (setf (sl:info (n-treat-tln np)) (n-treatments new-beam))
+ (let* ((mu-tot (monitor-units new-beam)) ; no fractional mu
+ (n (n-treatments new-beam))
+ (r-mu-per-frac (round (/ mu-tot n)))
+ (r-tot-mu (* r-mu-per-frac n)))
+ (setf (sl:info (tot-mu-rdt np)) r-tot-mu)
+ (setf (sl:info (mu-treat-tln np)) r-mu-per-frac))
+ (setf (sl:info (col-ang-tln np))
+ (format nil "~6,1F" (first (scale-angle
+ (collimator-angle new-beam)
+ (collimator-scale mach)
+ (collimator-offset mach)))))
+ (setf (sl:label (wdg-sel-btn np))
+ (format nil "Wedge Sel: ~a"
+ (wedge-label (id (wedge new-beam)) (machine new-beam))))
+ (let ((scaled-wdg-rot (if (zerop (id (wedge new-beam))) "NONE"
+ (first (scale-angle
+ (rotation (wedge new-beam))
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach))))))
+ (setf (sl:label (wdg-rot-btn np))
+ (format nil "Wedge Rot: ~a" scaled-wdg-rot)))
+
+ ;; set this beam's collimator's leaf-settings cache, and the
+ ;; cache of the original copy of this beam as well
+ (setf (leaf-settings (collimator new-beam))
+ (compute-mlc (collimator-angle new-beam)
+ (get-mlc-vertices new-beam)
+ (edge-list (collim-info np))))
+ (setf (leaf-settings (collimator (original-beam np)))
+ (compute-mlc (collimator-angle (original-beam np))
+ (get-mlc-vertices new-beam)
+ (edge-list (collim-info np))))
+
+ ;; set the leaf textline values
+ (do* ((l-tlns (left-leaf-tlns np) (rest l-tlns))
+ (r-tlns (right-leaf-tlns np) (rest r-tlns))
+ (leaves (leaf-settings (collimator new-beam)) (rest leaves))
+ (leaf-pair (first leaves) (first leaves)))
+ ((null leaves))
+ (setf (sl:info (first l-tlns))
+ (format nil "~5,1F" (first leaf-pair)))
+ (setf (sl:info (first r-tlns))
+ (format nil "~5,1F" (second leaf-pair)))))
+ (progn
+ (setf (sl:info (beam-rdt np)) "")
+ (setf (sl:info (gan-start-tln np)) "")
+ (setf (sl:info (gan-stop-tln np)) "")
+ (setf (sl:info (couch-ang-tln np)) "")
+ (setf (sl:info (n-treat-tln np)) "")
+ (setf (sl:info (tot-mu-rdt np)) "")
+ (setf (sl:info (mu-treat-tln np)) "")
+ (setf (sl:info (col-ang-tln np)) "")
+ (setf (sl:label (wdg-sel-btn np)) "Wedge Sel: No wedge")
+ (setf (sl:label (wdg-rot-btn np)) "Wedge Rot: NONE")
+ (mapc #'(lambda (l-rdt r-rdt)
+ (setf (sl:info l-rdt) "")
+ (setf (sl:info r-rdt) ""))
+ (left-leaf-tlns np)
+ (right-leaf-tlns np)))))
+
+;;;---------------------------------------------
+
+(defun make-neutron-panel (pat &rest initargs)
+
+ "make-neutron-panel pat &rest initargs
+
+Creates and returns a neutron panel with the specified initargs."
+
+ (apply #'make-instance 'neutron-panel :current-patient pat initargs))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((np neutron-panel))
+
+ "Unmap the panel's frame."
+
+ (when (current-beam np)
+ (ev:remove-notify np (new-id (wedge (current-beam np))))
+ (ev:remove-notify np (new-rotation (wedge (current-beam np)))))
+ (sl:destroy (del-pnl-btn np))
+ (sl:destroy (add-beam-btn np))
+ (sl:destroy (write-file-btn np))
+ (sl:destroy (comments-box np))
+ (sl:destroy (comments-label np))
+ (sl:destroy (beam-rdt np))
+ (sl:destroy (plan-rdt np))
+ (sl:destroy (date-rdt np))
+ (sl:destroy (beam-label np))
+ (sl:destroy (plan-label np))
+ (sl:destroy (output-label np))
+ (sl:destroy (phys-name-tln np))
+ (sl:destroy (presc-dose-tln np))
+ (sl:destroy (gan-start-tln np))
+ (sl:destroy (gan-stop-tln np))
+ (sl:destroy (n-treat-tln np))
+ (sl:destroy (tot-mu-rdt np))
+ (sl:destroy (mu-treat-tln np))
+ (sl:destroy (col-ang-tln np))
+ (sl:destroy (couch-ang-tln np))
+ (sl:destroy (wdg-sel-btn np))
+ (sl:destroy (wdg-rot-btn np))
+ (mapcar #'sl:destroy (left-leaf-tlns np))
+ (mapcar #'sl:destroy (right-leaf-tlns np))
+ ;; Destroying the scrolling lists gives async drawable errors....
+ ;; (sl:destroy (plan-scr np))
+ ;; (sl:destroy (beam-scr np))
+ ;; (sl:destroy (output-scr np))
+ (sl:destroy (fr np)))
+
+;;;---------------------------------------------
+
+(defun write-neutron-file (fp pat-id case-id plan-time pat-name hosp-id date
+ plan-comment phys-name presc-dose beams)
+
+ "write-neutron-file fp pat-id case-id plan-time pat-name hosp-id date
+ plan-comment phys-name presc-dose beams
+
+Writes a file full of beam-specific neutron setup to stream fp, based
+on the supplied patient id, case id, plan time stamp, patient name,
+hospital id, plan comment string, physician name, prescribed dose,
+and list of beams."
+
+;;;
+;;; Lines from sample output file, with no blanks before start of data
+;;;
+;;;11 4268 LASTNAME, FIRSTNAME 85-62-92 23-Apr-1999
+;;;12 KR 0.0 0.0
+;;;13 composite: boost with initial fields
+;;;21 5 RPO BOOST I N N T 4268 2 21-Apr-1999 15:57:01
+;;;22 3 0 486.0 0.0 162.0 0 1 0 270.0 23-Apr-1999 jon X T 0
+;;;23 120.0 50.0 50.0 180.0 180.0 250.0 250.0
+;;;24 0 -4.2 -5.0 -5.0 -5.0 0.0 0.0 0.0 0.0 0.0 0.0
+;;;24 1 -3.1 -2.0 -1.5 -1.5 0.0 0.0 0.0 0.0 0.0 0.0
+;;;24 2 5.8 5.8 5.6 5.0 0.0 0.0 0.0 0.0 0.0 0.0
+;;;24 3 5.2 4.0 2.9 2.9 0.0 0.0 0.0 0.0 0.0 0.0
+;;;21 6 LAO BOOST I N N T
+;;;22 3 0 384.0 0.0 128.0 0 1 0 270.0
+;;; etc ...
+
+ ;; header --- just once per file. Date here must be in dd-mmm-yyyy form.
+ (format fp "11 ~5 at a ~30a ~15a ~11 at a~%"
+ pat-id (seq-trunc 30 pat-name) (seq-trunc 15 hosp-id) date)
+ (format fp "12 ~30a ~7,1f ~7,1f~%"
+ (seq-trunc 30 phys-name) presc-dose 0.0)
+ (format fp "13 ~60a~%" (seq-trunc 60 plan-comment))
+ ;; accum-dose above is always 0.0
+
+ (let ((bm-num 0) ;; No beam number in Prism -- just count 'em up here
+ (mach nil)) ;; just so mach isnt' "special"
+ (dolist (bm beams)
+ (setq bm-num (+ 1 bm-num))
+ (setq mach (machine bm))
+
+ ;; record 21
+ (format fp "21 ~2 at a ~30a I ~1a N T ~5d ~2d ~20 at a~%"
+ ; I N T means iso,no ext blks,use table
+ bm-num (seq-trunc 30 (name bm))
+ (if (zerop (arc-size bm)) "N" "Y")
+ pat-id case-id plan-time)
+
+ ;; record 22
+ (let* ((mu-tot (monitor-units bm))
+ (n (n-treatments bm))
+ (r-mu-per-frac (float (round (/ mu-tot n))))
+ (r-mu-tot (float (* r-mu-per-frac n)))
+ ; change 71.1 to 71.0 etc.
+ (wdg (wedge bm))
+ (wedge-id (id wdg))
+ (wedge-code (case wedge-id ; just tabulate it -- nothing fancy
+ ((0) 0) ; no wedge
+ ((1 2) 1) ; Prism 30-SF, 30-LF --> Scx 30 degree
+ ((3 4) 2) ; 45-SF, 45-LF
+ ((5 6) 3))) ; 60-SF, 60-LF
+ (wedge-rot-code
+ (if (zerop wedge-id) 1 ;; 90 degrees for no wedge
+ (case (first (scale-angle (rotation wdg)
+ (wedge-rot-scale mach)
+ (wedge-rot-offset mach)))
+ ((0.0) 0)
+ ((90.0) 1)
+ ((180.0) 2)
+ ((270.0) 3))))
+ (scaled-collim-angle (first
+ (scale-angle (collimator-angle bm)
+ (collimator-scale mach)
+ (collimator-offset mach)))))
+ (format fp
+ "22 ~2d ~2 at a ~6,1f ~6,1f ~6,1f ~1a ~1a ~2 at a ~6,1f ~11 at a ~8a X T 0 ~%"
+ (round n) 0 r-mu-tot 0.0 r-mu-per-frac
+ ; note mon units always of form nnn.0
+ ; accum n, accum dose always zero
+ wedge-code wedge-rot-code 0 scaled-collim-angle
+ date (seq-trunc 8 (getenv "USER"))))
+ ; X T 0 are completion flag (X = not completed),
+ ; origin (T = transfered) and parent beam (0 = none)
+
+ ;; record 23
+ (let* ((scaled-couch-angle (first (scale-angle (couch-angle bm)
+ (turntable-scale mach)
+ (turntable-offset mach))))
+ (scaled-gantry-angle (first (scale-angle (gantry-angle bm)
+ (gantry-scale mach)
+ (gantry-offset mach))))
+ (scaled-gantry-stop (first (scale-angle (+ (gantry-angle bm)
+ (arc-size bm))
+ (gantry-scale mach)
+ (gantry-offset mach)))))
+ (format fp "23~{ ~6,1f~}~%"
+ (list 120.0 50.0 50.0 scaled-couch-angle 180.0
+ ;; ignore couch-height, couch-lateral, couch-long
+ ;; always PSA vert 120, lat 50, long 50, top rot 180
+ scaled-gantry-angle scaled-gantry-stop)))
+
+ ;; record 24 --- leaves
+ (let* ((leaves (leaf-settings (collimator bm)))
+ (leaves0-19 (mapcar #'first leaves)) ; leaf order is bizarre!
+ (leaves0-9 (reverse-first-ten leaves0-19))
+ (leaves10-19 (skip-ten leaves0-19))
+ (leaves20-39 (mapcar #'second leaves))
+ (leaves20-29 (skip-ten leaves20-39)) ; leaves 20-29 are at end
+ (leaves30-39 (reverse-first-ten leaves20-39))) ; 30-39 at front
+ (dolist (line-num '(0 1 2 3))
+ (format fp "24 ~1a~{ ~5,1f~}~%" line-num
+ (case line-num
+ ((0) leaves0-9) ((1) leaves10-19)
+ ((2) leaves20-29) ((3) leaves30-39))))))))
+
+;;;---------------------------------------------
+
+(defun reverse-first-ten (list)
+
+ "reverse-first-ten list
+
+Return a list which is the first ten elements of input list, in
+reverse order. Used to extract and reorder leaf settings."
+
+ (let ((rlist nil)) (dotimes (i 10 rlist) (push (nth i list) rlist))))
+
+;;;----------------------------------------------
+
+(defun skip-ten (list)
+
+ "skip-ten list
+
+Return a list which is all but the first ten elements of input list.
+Used to extract and reorder leaf settings."
+
+ (let ((rlist list)) (dotimes (i 10 rlist) (setq rlist (rest rlist)))))
+
+;;;-----------------------------------------------
+
+(defun seq-trunc (width seq)
+
+ "seq-trunc width seq
+
+Truncate sequence to width so it doesn't overflow fixed-width column"
+
+ (subseq seq 0 (min width (length seq)))) ; avoid array ref out-of-bounds
+
+;;;-----------------------------------------------
+;;; End.
diff --git a/slik/src/2d-plot.cl b/slik/src/2d-plot.cl
new file mode 100644
index 0000000..2070f23
--- /dev/null
+++ b/slik/src/2d-plot.cl
@@ -0,0 +1,821 @@
+;;;
+;;; 2d-plot
+;;;
+;;; A 2d-plot is a SLIK frame which displays a 2d-plot of data
+;;;
+;;; 19-Aug-1998 C. Wilcox created
+;;; 14-Apr-1999 I. Kalet add labels for tick spacing boxes
+;;; 23-Apr-1999 I. Kalet changes for multiple colormaps
+;;; Jun-1999 J. Zeman implement print to postscript
+;;; 24=Oct-1999 I. Kalet some code format cleanup
+;;; 28-May-2000 I. Kalet use Helvetica medium as small font, instead
+;;; of Courier bold.
+;;;
+
+(in-package :slik)
+
+;;;--------------------------------
+
+(defclass 2d-plot (frame)
+
+ ((bottom-label :type string
+ :reader bottom-label
+ :initarg :bottom-label
+ :documentation "The axis label below the plot")
+
+ (top-label :type string
+ :reader top-label
+ :initarg :top-label
+ :documentation "The axis label above the plot")
+
+ (left-label :type string
+ :reader left-label
+ :initarg :left-label
+ :documentation "The axis label to the left of the plot")
+
+ (right-label :type string
+ :reader right-label
+ :initarg :right-label
+ :documentation "The axis label to the right of the plot")
+
+ (pad :type clx:card16
+ :reader pad
+ :initarg :pad
+ :documentation "The amount of space around the plot.")
+
+ ;; define ranges to be displayed from the dataset
+ (max-x-value :type number
+ :accessor max-x-value
+ :initarg :max-x-value
+ :documentation "The maximum value plotted on the x axis.")
+
+ (min-x-value :type number
+ :accessor min-x-value
+ :initarg :min-x-value
+ :documentation "The minimum value plotted on the x axis.")
+
+ (max-y-value :type number
+ :accessor max-y-value
+ :initarg :max-y-value
+ :documentation "The maximum value plotted on the y axis.")
+
+ (min-y-value :type number
+ :accessor min-y-value
+ :initarg :min-y-value
+ :documentation "The minimum value plotted on the y axis.")
+
+ (epsilon :reader epsilon
+ :initarg :epsilon
+ :documentation "The minimum allowable difference between
+corresponding max and min values.")
+
+ ;; define distance between tick marks
+ (x-units-per-tick :type number
+ :accessor x-units-per-tick
+ :initarg :x-units-per-tick
+ :documentation "The distance in x-coorinates between
+tick marks.")
+
+ (y-units-per-tick :type number
+ :accessor y-units-per-tick
+ :initarg :y-units-per-tick
+ :documentation "The distance in y-coorinates between
+tick marks.")
+
+ (tick-style :type (member :tick :grid :none)
+ :reader tick-style
+ :initarg :tick-style
+ :documentation "Define the way that ticks are defined.")
+
+ ;; define the positions for slider bars in the graph
+ (x-slider-val :type number
+ :accessor x-slider-val
+ :initarg :x-slider-val
+ :documentation "This is the position of the x-coordinate
+slider bar.")
+
+ (y-slider-val :type number
+ :accessor y-slider-val
+ :initarg :y-slider-val
+ :documentation "This is the position of the y-coordinate
+slider bar.")
+
+ (new-slider-val :type ev:event
+ :accessor new-slider-val
+ :initform (ev:make-event)
+ :documentation "This is announced when the slider
+bar values are updated by clicking the mouse.")
+
+ ;; define the scale factor between the left axis labels and right
+ ;; axis labels
+ (x-scale-factor :reader x-scale-factor
+ :initarg :x-scale-factor
+ :documentation "The ratio of bottom units to top units.")
+
+ (y-scale-factor :reader y-scale-factor
+ :initarg :y-scale-factor
+ :documentation "The ratio of left units to right units.")
+
+ (redraw :accessor redraw
+ :initform t
+ :documentation "This holds the state for redrawing the plot.")
+
+ ;; private widget slots
+ (series-coll :reader series-coll
+ :initarg :series-coll
+ :documentation "A list of lists of pairs of numbers...")
+
+ (widgets :accessor widgets
+ :documentation "A list of widgets to destroy when
+the plot is destroyed.")
+
+ (notifies :accessor notifies
+ :initform nil
+ :documentation "A list of notifies to destroy when the
+plot is destroyed.")
+
+ (plot-picture :type picture
+ :accessor plot-picture
+ :initform nil
+ :documentation "This is the picture to draw the plots into.")
+
+ )
+
+ (:default-initargs :title "SLIK 2D Plot"
+ :bottom-label "X-Axis" :top-label ""
+ :left-label "Y-Axis" :right-label ""
+ :pad 40
+ :max-x-value 100 :min-x-value 0
+ :max-y-value 100 :min-y-value 0
+ :epsilon 1
+ :x-units-per-tick 20
+ :y-units-per-tick 20
+ :tick-style :grid
+ :x-scale-factor nil
+ :y-scale-factor nil
+ :x-slider-val 0
+ :y-slider-val 0
+ ;; (list (list 0 'red '(0 0) (1 20) (2 10)))
+ :series-coll (coll:make-collection)
+ :width 300 :height 300)
+
+ (:documentation "A 2d-plot is designed to display multiple series
+of 2d data pairs.")
+
+ )
+
+;;;---------------------------------------------
+
+(defun remove-series (plot id)
+
+ (coll:delete-element id (series-coll plot)
+ :test #'(lambda (id elem)
+ (equal id (first elem))))
+ (when (redraw plot) (draw-plot-lines plot)))
+
+;;;---------------------------------------------
+
+(defun update-series (plot id gc series)
+
+ (let ((current-redraw (redraw plot)))
+ (setf (redraw plot) nil)
+ (remove-series plot id)
+ (setf (redraw plot) current-redraw)
+ (coll:insert-element (list id gc series) (series-coll plot)
+ :test #'(lambda (a b)
+ (declare (ignore a b))
+ nil))
+ (when (redraw plot) (draw-plot-lines plot))))
+
+;;;---------------------------------------------
+
+(defun make-2d-plot (width height &rest other-initargs)
+
+ (let* ((p (apply 'make-instance '2d-plot
+ :width width :height height other-initargs))
+ (pad (pad p))
+ (double-pad (* 2 pad))
+ (trough 5)
+ (box-width (- double-pad (* 2 trough)))
+ (box-height 25)
+ (ytick-text (make-textline box-width box-height
+ :parent (window p)
+ :numeric t
+ :upper-limit most-positive-single-float
+ :lower-limit least-positive-single-float
+ :label "Ygrid " :font helvetica-medium-12
+ :info (format nil "~s"
+ (y-units-per-tick p))
+ :ulc-x trough
+ :ulc-y (- pad trough box-height)))
+ (xtick-text (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :upper-limit most-positive-single-float
+ :lower-limit least-positive-single-float
+ :label "Xgrid " :font helvetica-medium-12
+ :info (format nil "~s"
+ (x-units-per-tick p))
+ :ulc-x (- (width p)
+ (- double-pad trough))
+ :ulc-y (- (height p)
+ (- pad trough))))
+ (maxy-text (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-x trough :ulc-y pad))
+ (miny-text (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-x trough
+ :ulc-y (- (height p) pad box-height)))
+ (maxy-text2
+ (if (y-scale-factor p)
+ (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-x (- (width p) (- double-pad trough))
+ :ulc-y pad)
+ nil))
+ (miny-text2
+ (if (y-scale-factor p)
+ (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-x (- (width p) (- double-pad trough))
+ :ulc-y (- (height p) pad box-height))
+ nil))
+ (minx-text (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :ulc-x double-pad
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-y (- (height p) (- pad trough))))
+ (maxx-text (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :ulc-x (- (width p)
+ (* 2 (- double-pad trough)))
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-y (- (height p) (- pad trough))))
+ (minx-text2
+ (if (x-scale-factor p)
+ (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :ulc-x double-pad
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-y (max 0 (- pad box-height trough)))
+ nil))
+ (maxx-text2
+ (if (x-scale-factor p)
+ (make-textline box-width box-height
+ :parent (window p) :numeric t
+ :ulc-x (- (width p) (* 2 (- double-pad trough)))
+ :upper-limit most-positive-single-float
+ :lower-limit most-negative-single-float
+ :ulc-y (max 0 (- pad box-height trough)))
+ nil))
+ (pic (make-picture (- (width p) (* 2 double-pad))
+ (- (height p) double-pad)
+ :parent (window p)
+ :ulc-x double-pad :ulc-y pad)))
+ ;; initialize textline values and keep track of
+ ;; newly created widgets
+ (setf (info miny-text) (min-y-value p)
+ (info maxy-text) (max-y-value p)
+ (info minx-text) (min-x-value p)
+ (info maxx-text) (max-x-value p)
+ (widgets p) (list maxy-text miny-text minx-text maxx-text
+ xtick-text ytick-text pic))
+ (when (y-scale-factor p)
+ (setf (info miny-text2) (* (min-y-value p) (y-scale-factor p)))
+ (setf (info maxy-text2) (* (max-y-value p) (y-scale-factor p)))
+ (push maxy-text2 (widgets p))
+ (push miny-text2 (widgets p)))
+ (when (x-scale-factor p)
+ (setf (info minx-text2) (* (min-y-value p) (x-scale-factor p)))
+ (setf (info maxx-text2) (* (max-y-value p) (x-scale-factor p)))
+ (push maxx-text2 (widgets p))
+ (push minx-text2 (widgets p)))
+ ;; assign slot for the picture
+ (setf (plot-picture p) pic)
+ (push (list p 'button-release pic) (notifies p))
+ (ev:add-notify p (button-release pic)
+ #'(lambda (pan pic code x y)
+ (when (= code 1) ;left button
+ (let ((xmin (min-x-value p))
+ (xmax (max-x-value p))
+ (ymin (min-y-value p))
+ (ymax (max-y-value p))
+ (w (width pic))
+ (h (height pic)))
+ (setf (x-slider-val pan)
+ (+ xmin (* (/ x w) (- xmax xmin))))
+ (setf (y-slider-val pan)
+ (- ymax (* (/ y h) (- ymax ymin))))
+ (ev:announce pan (new-slider-val pan)
+ (x-slider-val pan)
+ (y-slider-val pan))
+ (draw-plot-lines pan)))))
+ (let* ((busy nil)
+ (hi-low-check #'(lambda (hi low which-new)
+ (let ((thresh (epsilon p)))
+ (when (< hi (+ low thresh))
+ (if (eq which-new 0)
+ (setf hi (+ low thresh))
+ (setf low (- hi thresh))))
+ (if (eq which-new 0) hi low))))
+ (constraint-check
+ #'(lambda (boxes ratio which-new)
+ ;; (info (first boxes))
+ ;; (info (second boxes)))
+ ;; must ensure that (not (eq info nil)) @@@@@@@@@
+ (let* ((hi1 (or (read-from-string (info (first boxes)))
+ 100))
+ (low1 (or (read-from-string (info (second boxes)))
+ 0))
+ (hi2 (if ratio
+ (or (read-from-string (info (third boxes)))
+ 100)
+ 0))
+ (low2 (if ratio
+ (or (read-from-string (info (fourth boxes)))
+ 0)
+ 0))
+ (vals (list hi1 low1 hi2 low2))
+ (digits (format nil "~~~df"
+ (max 1 (floor (- (pad p) 10) 5)))))
+ ;; ensure that max > min
+ (setf (nth which-new vals)
+ (if (< which-new 2)
+ (funcall hi-low-check hi1 low1 (mod which-new 2))
+ (funcall hi-low-check hi2 low2 (mod which-new 2))))
+ ;; ensure that the ratio invariant holds
+ (when ratio
+ (setf (nth (mod (+ which-new 2) 4) vals)
+ (if (< which-new 2)
+ (* (nth which-new vals) ratio)
+ (/ (nth which-new vals) ratio))))
+ ;; update the text-box values
+ (setf (info (first boxes))
+ (format nil digits (first vals)))
+ (setf (info (second boxes))
+ (format nil digits (second vals)))
+ (when ratio
+ (setf (info (third boxes))
+ (format nil digits (third vals)))
+ (setf (info (fourth boxes))
+ (format nil digits (fourth vals))))
+ (list (first vals) (second vals)))))
+ (check-y #'(lambda (which)
+ (when (not busy)
+ (setf busy t)
+ (let ((result
+ (funcall constraint-check
+ (list maxy-text miny-text
+ maxy-text2 miny-text2)
+ (y-scale-factor p) which)))
+ (when result
+ (setf (max-y-value p) (first result))
+ (setf (min-y-value p) (second result)))
+ (setf busy nil)))))
+ (check-x #'(lambda (which)
+ (when (not busy)
+ (setf busy t)
+ (let ((result
+ (funcall constraint-check
+ (list maxx-text minx-text
+ maxx-text2 minx-text2)
+ (x-scale-factor p) which)))
+ (when result
+ (setf (max-x-value p) (first result))
+ (setf (min-x-value p) (second result)))
+ (setf busy nil))))))
+ ;; respond to changes in tick-marks
+ (push (list p 'new-info ytick-text) (notifies p))
+ (ev:add-notify p (new-info ytick-text)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb))
+ (setf (y-units-per-tick plot)
+ (read-from-string newval))
+ (draw-plot-lines plot)))
+ (push (list p 'new-info xtick-text) (notifies p))
+ (ev:add-notify p (new-info xtick-text)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb))
+ (setf (x-units-per-tick plot)
+ (read-from-string newval))
+ (draw-plot-lines plot)))
+ ;; respond to changes in y scales
+ (push (list p 'new-info maxy-text) (notifies p))
+ (ev:add-notify p (new-info maxy-text)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-y 0)
+ (draw-plot-lines plot)))
+ (push (list p 'new-info miny-text) (notifies p))
+ (ev:add-notify p (new-info miny-text)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-y 1)
+ (draw-plot-lines plot)))
+ (when (y-scale-factor p)
+ (push (list p 'new-info maxy-text2) (notifies p))
+ (ev:add-notify p (new-info maxy-text2)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-y 2)
+ (draw-plot-lines plot)))
+ (push (list p 'new-info miny-text2) (notifies p))
+ (ev:add-notify p (new-info miny-text2)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-y 3)
+ (draw-plot-lines plot))))
+ ;; respond to changes in x scales
+ (push (list p 'new-info minx-text) (notifies p))
+ (ev:add-notify p (new-info minx-text)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-x 1)
+ (draw-plot-lines plot)))
+ (push (list p 'new-info maxx-text) (notifies p))
+ (ev:add-notify p (new-info maxx-text)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-x 0)
+ (draw-plot-lines plot)))
+ (when (x-scale-factor p)
+ (push (list p 'new-info maxx-text2) (notifies p))
+ (ev:add-notify p (new-info maxx-text2)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-x 2)
+ (draw-plot-lines plot)))
+ (push (list p 'new-info minx-text2) (notifies p))
+ (ev:add-notify p (new-info minx-text2)
+ #'(lambda (plot tb newval)
+ (declare (ignore tb newval))
+ (funcall check-x 3)
+ (draw-plot-lines plot)))))
+ (push (list p 'exposure pic) (notifies p))
+ (ev:add-notify p (exposure pic)
+ #'(lambda (plot pic x y width height count)
+ (declare (ignore pic x y width height count))
+ (draw-plot-lines plot)))
+ p))
+
+;;;---------------------------------------------
+
+(defun draw-plot-lines (p)
+
+ "draw-plot-lines p
+
+Draw the plot lines for the graph."
+
+ (let* ((pic (plot-picture p))
+ (win (pixmap pic))
+ (cm (colormap pic))
+ (gc (color-gc (fg-color pic) cm))
+ (prevx 0.0)
+ (prevy 0.0)
+ (curx 0.0)
+ (cury 0.0)
+ (width (width pic))
+ (height (height pic))
+ ;; pixels per unit
+ (xmin (min-x-value p))
+ (ymin (min-y-value p))
+ (xppu (/ width (- (max-x-value p)
+ xmin)))
+ (yppu (/ height (- (max-y-value p)
+ ymin)))
+ (xhash (* (- (x-units-per-tick p)
+ (mod xmin (x-units-per-tick p))) xppu))
+ (xdelta (* (x-units-per-tick p) xppu))
+ (yhash (* (- (y-units-per-tick p)
+ (mod ymin (y-units-per-tick p))) yppu))
+ (ydelta (* (y-units-per-tick p) yppu))
+ (tick-size 6))
+ ;; clear the grid area and redraw the grid frame
+ (clx:draw-rectangle win (color-gc (bg-color pic) cm)
+ 0 0 (width pic) (height pic) t)
+ (if (eq (tick-style p) :grid)
+ (progn
+ (loop as i from xhash to width by xdelta do
+ (clx:draw-line win (color-gc 'gray-dashed cm)
+ (round i) 0 (round i) height))
+ (loop as i from yhash to height by ydelta do
+ (clx:draw-line win (color-gc 'gray-dashed cm)
+ 0 (round (- height i))
+ width (round (- height i))))))
+ (if (eq (tick-style p) :tick)
+ (progn
+ (loop as i from xhash to width by xdelta do
+ (clx:draw-line win gc (round i) (- height tick-size)
+ (round i) height))
+ (loop as i from yhash to height by ydelta do
+ (clx:draw-line win gc 0 (round (- height i))
+ tick-size (round (- height i))))))
+ ;; draw the slider-bars
+ (when (numberp (y-slider-val p))
+ (let ((y-bar-pixel (- height (floor (* yppu (- (y-slider-val p)
+ ymin))))))
+ (if (and (<= y-bar-pixel height) (>= y-bar-pixel 0))
+ (clx:draw-line win (color-gc 'white-dashed cm)
+ 0 y-bar-pixel
+ width y-bar-pixel))))
+ (when (numberp (x-slider-val p))
+ (let ((x-bar-pixel (floor (* xppu (- (x-slider-val p) xmin)))))
+ (if (and (<= x-bar-pixel width) (>= x-bar-pixel 0))
+ (clx:draw-line win (color-gc 'white-dashed cm)
+ x-bar-pixel 0
+ x-bar-pixel height))))
+ ;; draw plot lines
+ (let ((seriesgc nil)
+ (series-lst (coll:elements (series-coll p)))
+ (series nil))
+ (when (listp series-lst)
+ (dolist (series-rec series-lst)
+ (when series-rec
+ (setq seriesgc (color-gc (second series-rec) cm))
+ (setq series (third series-rec))
+ (setq prevx (max (min (floor (* xppu
+ (- (first (first series))
+ xmin)))
+ 32000) -32000))
+ (setq prevy (max (min (- height
+ (floor (* yppu
+ (- (second (first series))
+ ymin))))
+ 32000) -32000))
+ (dolist (point series)
+ (setq curx (max (min (floor (* xppu (- (first point) xmin)))
+ 32000) -32000))
+ (setq cury (max (min (- height (floor (* yppu
+ (- (second point)
+ ymin))))
+ 32000) -32000))
+ (clx:draw-line win seriesgc prevx prevy curx cury)
+ (setq prevx curx)
+ (setq prevy cury))))))
+ (clx:draw-rectangle win gc
+ 0 0 (- (width pic) 1) (- (height pic) 1))
+ (draw-border pic)
+ (erase pic)
+ (flush-output)))
+
+;;;---------------------------------------
+
+(defun draw-text (widget text x y &key
+ (orientation :horizontal)
+ (justify :left)
+ (alignment :bottom))
+
+ "draw horizontal or vertical text with various alignments."
+
+ (declare (type string text)
+ (type clx:card16 x y)
+ (type (member :left :center :right) justify)
+ (type (member :horizontal :vertical) orientation)
+ (type (member :top :center :bottom) alignment))
+ (let* ((win (window widget))
+ (gc (color-gc (fg-color widget) (colormap widget)))
+ ;; (bgc (color-gc (bg-color widget) (colormap widget)))
+ (fnt (clx:gcontext-font gc))
+ (len (length text))
+ (asc (clx:font-ascent fnt))
+ (desc (clx:font-descent fnt))
+ (ch-wid (clx:max-char-width fnt))
+ (line-height (+ asc desc)))
+ (if (eq orientation :horizontal)
+ (progn
+ (cond
+ ((eq justify :center) (decf x (floor (clx:text-width fnt text) 2)))
+ ((eq justify :right) (decf x (clx:text-width fnt text))))
+ (cond
+ ((eq alignment :top) (incf y asc))
+ ((eq alignment :center) (incf y (floor asc 2))))
+ ;; (clx:draw-rectangle win gc
+ ;; (- x 5) (- y asc 5)
+ ;; (+ (clx:text-width fnt text) 10)
+ (+ asc desc 10)
+ (clx:draw-glyphs win gc x y text))
+ ;; if vertical
+ (progn
+ (cond
+ ((eq justify :center) (decf x (floor ch-wid 2)))
+ ((eq justify :right) (decf x ch-wid)))
+ (cond
+ ((eq alignment :top) (incf y asc))
+ ((eq alignment :center)
+ (decf y (floor (+ (* (+ asc desc) (- len 2)) desc) 2)))
+ ((eq alignment :bottom) (decf y (* (+ asc desc) (- len 1)))))
+ ;; (clx:draw-rectangle win gc (- x 5) (- y asc 5)
+ ;; (+ ch-wid 10) (+ 10 desc (* len line-height)))
+ (dotimes (i len)
+ (clx:draw-glyph win gc x y (char text i))
+ (incf y line-height))))))
+
+;;;---------------------------------------
+
+(defun draw-four-sides (p)
+
+ (let* ((win (window p))
+ (text-pad (pad p)))
+ (clx:draw-rectangle win (color-gc (bg-color p) (colormap p))
+ 0 0 (width p) (height p) t)
+ (when (x-scale-factor p)
+ (draw-text p (top-label p)
+ (floor (width p) 2)
+ (max 10 (floor text-pad 2))
+ :orientation :horizontal
+ :justify :center
+ :alignment :center))
+ (draw-text p (bottom-label p)
+ (floor (width p) 2)
+ (- (height p) (max 10 (floor text-pad 2)))
+ :orientation :horizontal
+ :justify :center
+ :alignment :center)
+ (draw-text p (left-label p) text-pad (floor (height p) 2)
+ :orientation :vertical
+ :justify :center
+ :alignment :center)
+ (when (y-scale-factor p)
+ (draw-text p (right-label p) (- (width p) text-pad)
+ (floor (height p) 2)
+ :orientation :vertical
+ :justify :center
+ :alignment :center))))
+
+;;;---------------------------------------
+
+(defmethod refresh :before ((p 2d-plot))
+
+ "Redraws the labels for the plot."
+
+ ;; The plot is a picture so it knows how to refresh itself
+ (draw-four-sides p))
+
+;;;---------------------------------------
+
+(defmethod destroy :before ((p 2d-plot))
+
+ (dolist (n (notifies p))
+ (ev:remove-notify (first n) (slot-value (third n) (second n))))
+ (dolist (e (widgets p))
+ (destroy e)))
+
+;;;-----------------------------------
+
+(defun print-2dplot (strm p width height slider)
+
+ "print-2dplot strm p width height slider
+
+writes PostScript output to stream strm, representing a printed
+rendition of the contents of 2d-plot p, in a region of size width by
+height inches, assuming a starting point, the lower left corner, has
+already been defined by prior PostScript output to the stream. Labels
+are size 12 point, no matter what size the graph is. If slider is t,
+the vertical and horizontal sliding lines are included."
+
+ (format strm "gsave gsave~%")
+ (format strm "72 72 rmoveto~%")
+ ;;move to graph, draw lines
+ (format strm "currentpoint translate~%")
+ (format strm "~A ~A scale newpath 0 0 moveto~%"
+ (float (/ (* 72 (- width 2))
+ (- (max-x-value p) (min-x-value p))))
+ (float (/ (* 72 (- height 2))
+ (- (max-y-value p) (min-y-value p)))))
+
+ ;;draw the grid, then the series
+ (let ((repts (floor (/ (- (max-x-value p) (min-x-value p))
+ (x-units-per-tick p)))))
+ (format strm "1 8 div setlinewidth~%")
+ (dotimes (i (+ repts 1))
+ (format strm "~A ~A moveto ~A ~A lineto stroke~%"
+ (* i (x-units-per-tick p)) 0 (* i (x-units-per-tick p))
+ (- (max-y-value p) (min-y-value p)))))
+ (format strm "~A ~A moveto ~A ~A lineto stroke~%"
+ (- (max-x-value p) (min-x-value p)) 0
+ (- (max-x-value p) (min-x-value p))
+ (- (max-y-value p) (min-y-value p)))
+ (format strm "0 0 moveto~%")
+
+ (let ((repts (floor (/ (- (max-y-value p) (min-y-value p))
+ (y-units-per-tick p)))))
+ (dotimes (i (+ repts 1))
+ (format strm "~A ~A moveto ~A ~A lineto stroke~%"
+ 0 (* i (y-units-per-tick p))
+ (- (max-x-value p) (min-x-value p))
+ (* i (y-units-per-tick p)))))
+ (format strm "~A ~A moveto ~A ~A lineto stroke~%"
+ 0 (- (max-y-value p) (min-y-value p))
+ (- (max-x-value p) (min-x-value p))
+ (- (max-y-value p) (min-y-value p)))
+ (format strm "0 0 moveto~%")
+ (format strm "~A ~A rlineto ~A ~A rlineto ~%"
+ 0 (- (max-y-value p) (min-y-value p))
+ (- (max-x-value p) (min-x-value p)) 0)
+ (format strm "~A ~A rlineto closepath clip newpath~%" 0
+ (- (min-y-value p) (max-y-value p)))
+ (format strm "1 4 div setlinewidth~%")
+ (dolist (series (coll:elements (series-coll p)))
+ (format strm "gsave~%")
+ (let ((color (cadr series)))
+ (cond
+ ((eq color 'sl:black) (ps:set-graphics strm :color '(0 0 0)))
+ ((eq color 'sl:red) (ps:set-graphics strm :color '(1 0 0)))
+ ((eq color 'sl:blue) (ps:set-graphics strm :color '(0 0 1)))
+ ((eq color 'sl:magenta) (ps:set-graphics strm :color '(.7 0 1)))
+ ((eq color 'sl:green) (ps:set-graphics strm :color '(0 1 0)))
+ ((eq color 'sl:white) (ps:set-graphics strm :color '(0 0 0)))
+ ((eq color 'sl:yellow) (ps:set-graphics strm :color '(0 0 0)))
+ ((eq color 'sl:cyan) (ps:set-graphics strm :color '(0 1 1)))
+ (t (ps:set-graphics strm :color '(.5 .5 .5)))))
+ (format strm "~A ~A moveto~%"
+ (float (caar (caddr series))) (float (cadar (caddr series))))
+ (dolist (point (caddr series))
+ (format strm "~A ~A lineto~%"(float (- (car point) (min-x-value p)))
+ (float (- (cadr point) (min-y-value p)))))
+ (format strm "stroke grestore~%"))
+ ;; print slider lines if asked for
+ (if slider
+ (format strm "[1 1] 0 setdash 0 ~A moveto ~A ~A lineto stroke~%"
+ (float (- (y-slider-val p) (min-y-value p)))
+ (float (- (max-x-value p) (min-x-value p)))
+ (float (- (y-slider-val p) (min-y-value p)))))
+ (if slider
+ (format strm "~A 0 moveto ~A ~A lineto stroke~%"
+ (float (- (x-slider-val p) (min-x-value p)))
+ (float (- (x-slider-val p) (min-x-value p)))
+ (float (- (max-y-value p) (min-y-value p)))))
+
+ (format strm "grestore~%")
+ ;;print labels around graph. have an inch on each side to do.
+ (format strm "gsave currentpoint translate~%")
+ (format strm "/Courier findfont 12 scalefont setfont~%")
+ (format strm "72 40 moveto (~A) show~%" (bottom-label p))
+ (format strm "~A 57 moveto (~,2F) show~%"
+ (* 72 (- width 1)) (max-x-value p))
+ (format strm "72 57 moveto (~,2F) show~%" (min-x-value p))
+ (format strm "55 ~A moveto (~,2F) show~%"
+ (* 72 (- height 1)) (max-y-value p))
+ (format strm "40 72 moveto (~,2F) show~%" (min-y-value p))
+ (format strm "72 ~A moveto (~A) show~%"
+ (- (* 72 height) 14) (top-label p))
+ (when slider
+ (format strm "~A 35 moveto (X Slider Value: ~,2F) show~%"
+ (* 72 (- width 3)) (float (x-slider-val p)))
+ (format strm "~A 20 moveto (Y Slider Value: ~,2F) show~%"
+ (* 72 (- width 3)) (float (y-slider-val p))))
+
+ ;;print side labels
+ (format strm "50 ~A moveto~%" (* 72 (- height 1.5)))
+ (dotimes (i (length (left-label p)))
+ (format strm "(~A) show 50 currentpoint exch pop 14 sub moveto~%"
+ (elt (left-label p) i)))
+
+ (format strm "~A ~A moveto~%"
+ (- (* 72 width) 57) (* 72 (- height 1.5)))
+ (dotimes (i (length (right-label p)))
+ (format strm "(~A) show ~A currentpoint exch pop 14 sub moveto~%"
+ (elt (right-label p) i)
+ (- (* 72 width) 57)))
+ ;;print (if they exist) alternate scales
+ (if (y-scale-factor p)
+ (format strm "~A ~A moveto (~,2F) show~%"
+ (* 72 (- width 1)) (- (* height 72) 87)
+ (* (y-scale-factor p) (max-y-value p))))
+ (if (x-scale-factor p)
+ (format strm "~A ~A moveto (~,2F) show~%"
+ (* 72 (- width 1.5))
+ (- (* 72 height) 69) (* (x-scale-factor p) (max-x-value p))))
+
+ ;;print tick scale:
+ (format strm "72 22 moveto (X Units (per tick)) show~%")
+ (format strm "72 8 moveto ( ~,2F) show~%" (x-units-per-tick p))
+ (format strm "0 163 moveto (Y Units) show~%")
+ (format strm "0 149 moveto ((per tick)) show~%")
+ (format strm "0 135 moveto (~,2F) show ~%" (y-units-per-tick p))
+
+ (format strm "grestore~%")
+ );;end function, for now
+
+;;;-----------------------------------
+;;; End.
+
+
+
+
+
+
+
+
+
diff --git a/slik/src/adj-sliderboxes.cl b/slik/src/adj-sliderboxes.cl
new file mode 100644
index 0000000..a8f0139
--- /dev/null
+++ b/slik/src/adj-sliderboxes.cl
@@ -0,0 +1,189 @@
+;;;
+;;; adj-sliderboxes
+;;;
+;;; An adjustable sliderbox is a sliderbox in which you can edit the
+;;; minimum and maximum values.
+;;;
+;;; 20-Apr-1994 J. Unger created
+;;; 23-Sep-1994 J. Unger make textlines numeric.
+;;; 3-Jan-1995 I. Kalet remove proclaim form.
+;;; 8-Sep-1995 I. Kalet make consistent with fixes in sliderboxes,
+;;; including use of initialize-instance, finally.
+;;; 4-May-1997 I. Kalet don't use the label (formerly title) to
+;;; determine the width of the limit textlines.
+;;; 3-Nov-1998 I. Kalet track changes in sliders module.
+;;; 11-Mar-2001 I. Kalet explicitly set border style in textlines -
+;;; does not default correctly.
+;;;
+
+(in-package :slik)
+
+;;;---------------------------------------------
+
+(defclass adjustable-sliderbox (sliderbox)
+
+ ((the-minimum :type textline
+ :accessor the-minimum
+ :documentation "The minimum value textline in the
+lower left corner of the sliderbox.")
+
+ (the-maximum :type textline
+ :accessor the-maximum
+ :documentation "The maximum value textline in the
+lower right corner of the sliderbox.")
+
+ (smallest-range :type single-float
+ :accessor smallest-range
+ :initform 1.0
+ :initarg :smallest-range
+ :documentation "The smallest distance between the
+minimum and maximum values of the sliderbox.")
+
+ (minimum-changed :type ev:event
+ :accessor minimum-changed
+ :initform (ev:make-event)
+ :documentation "Announced when the minimum value
+of the sliderbox changes.")
+
+ (maximum-changed :type ev:event
+ :accessor maximum-changed
+ :initform (ev:make-event)
+ :documentation "Announced when the maximum value
+of the sliderbox changes.")
+
+ )
+
+ (:documentation "A sliderbox with editable min and max values.")
+ )
+
+;;;---------------------------------------------
+
+(defmethod (setf minimum) (new-min (asb adjustable-sliderbox))
+
+ "Sets the minimum value of the sliderbox and announces minimum-changed."
+
+ (erase-knob (the-slider asb))
+ (setf (minimum (the-slider asb))
+ (min new-min (- (maximum asb) (smallest-range asb))))
+ (unless (= new-min (minimum (the-slider asb)))
+ (setf (info (the-minimum asb)) (minimum asb)))
+ (scale-knob (the-slider asb))
+ (refresh (the-slider asb))
+ (ev:announce asb (minimum-changed asb) (minimum (the-slider asb))))
+
+;;;---------------------------------------------
+
+(defmethod (setf maximum) (new-max (asb adjustable-sliderbox))
+
+ "Sets the maximum value of the sliderbox and announces maximum-changed."
+
+ (erase-knob (the-slider asb))
+ (setf (maximum (the-slider asb))
+ (max new-max (+ (minimum asb) (smallest-range asb))))
+ (unless (= new-max (maximum (the-slider asb)))
+ (setf (info (the-maximum asb)) (maximum asb)))
+ (scale-knob (the-slider asb))
+ (refresh (the-slider asb))
+ (ev:announce asb (maximum-changed asb) (maximum (the-slider asb))))
+
+;;;---------------------------------------------
+
+(defmethod refresh ((asb adjustable-sliderbox))
+
+ "Supercedes the sliderbox refresh method, since everything here
+refreshes itself."
+
+ nil)
+
+;;;---------------------------------------------
+
+(defun make-adjustable-sliderbox (sl-width sl-height min max digits
+ &rest other-initargs
+ &key (font *default-font*)
+ &allow-other-keys)
+
+ "make-adjustable-sliderbox sl-width sl-height min max digits
+ &rest other-initargs
+ &key (font *default-font*)
+ &allow-other-keys
+
+Returns an instance of an adjustable sliderbox with the specified
+parameters. The digits parameter is a number that is used to
+determine how big to make the textline, to accomodate the setting
+values to whatever significant digits are needed by the application."
+
+ (apply #'make-instance 'adjustable-sliderbox
+ :sl-width sl-width :sl-height sl-height
+ :sl-min min :sl-max max :digits digits
+ :width (+ sl-width (* 2 *sx*)) ;; *sx* in sliderboxes module.
+ ;; allow 5 pixels above and below textline, and same inside
+ ;; textline above and below the text, for total of 20
+ :height (+ *sy* sl-height (font-height font) 20)
+ other-initargs))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((sb adjustable-sliderbox)
+ &rest other-initargs
+ &key lower-limit upper-limit
+ &allow-other-keys)
+
+ (let* ((sl-width (sl-width sb))
+ (sl-height (sl-height sb))
+ (max (sl-max sb))
+ (min (sl-min sb))
+ (font (font sb))
+ (width (+ sl-width (* 2 *sx*))) ;; different for vert. *******
+ (fh (font-height font))
+ (th (+ fh 10)) ; textline height
+ (tw (+ (clx:text-width font (format nil "~A" (digits sb)))
+ 20)) ; 10 pixels margin on each side
+ (win (window sb)))
+ (setf (the-minimum sb) (apply #'make-textline tw th
+ :parent win
+ :ulc-x *sx*
+ :ulc-y (+ *sy* sl-height 5)
+ :border-style
+ (if (eql *default-border-style* :flat)
+ :flat :lowered)
+ :numeric t
+ :upper-limit (or upper-limit max)
+ :lower-limit (or lower-limit min)
+ other-initargs)
+ (the-maximum sb) (apply #'make-textline tw th
+ :parent win
+ :ulc-x (- width *sx* tw)
+ :ulc-y (+ *sy* sl-height 5)
+ :border-style
+ (if (eql *default-border-style* :flat)
+ :flat :lowered)
+ :numeric t
+ :upper-limit (or upper-limit max)
+ :lower-limit (or lower-limit min)
+ other-initargs))
+ (setf (info (the-minimum sb)) (minimum sb))
+ (setf (info (the-maximum sb)) (maximum sb))
+ (ev:add-notify sb (new-info (the-minimum sb))
+ #'(lambda (asb ann val)
+ (declare (ignore ann))
+ (setf (minimum asb) (read-from-string val))
+ (when (< (setting asb) (minimum asb))
+ (setf (setting asb) (minimum asb)))))
+ (ev:add-notify sb (new-info (the-maximum sb))
+ #'(lambda (asb ann val)
+ (declare (ignore ann))
+ (setf (maximum asb) (read-from-string val))
+ (when (> (setting asb) (maximum asb))
+ (setf (setting asb) (maximum asb)))))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((asb adjustable-sliderbox))
+
+ "destroy the extra textlines first"
+
+ (destroy (the-minimum asb))
+ (destroy (the-maximum asb)))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/slik/src/buttons.cl b/slik/src/buttons.cl
new file mode 100644
index 0000000..6ef3654
--- /dev/null
+++ b/slik/src/buttons.cl
@@ -0,0 +1,291 @@
+;;;
+;;; buttons
+;;;
+;;; This file defines the various types of buttons in SLIK
+;;;
+;;; 13-Apr-1992 I. Kalet started
+;;; 27-Apr-1992 I. Kalet add Exit button
+;;; 29-May-1992 I. Kalet font defaults in frame class
+;;; 9-Jun-1992 I. Kalet take out process-enter-notify and
+;;; process-leave-notify - they did not behave as expected.
+;;; 6-Jul-1992 I. Kalet add :justify parameter to make-button, change
+;;; behavior to event and be: to ev:
+;;; 8-Oct-1992 I. Kalet change defsetf to defmethod (setf ... also
+;;; add (setf label)
+;;; 25-Oct-1992 I. Kalet eliminate pixmap
+;;; 29-Nov-1992 I. Kalet make default border color white not gray
+;;; 27-Feb-1993 I. Kalet reposition label when label or font is
+;;; changed
+;;; 3-Aug-1993 I. Kalet provide button-2-on event for middle mouse
+;;; button press. Used in scrolling list code. Not yet for export.
+;;; 26-May-1994 I. Kalet implement the active attribute, also the
+;;; confirm attribute for exit buttons.
+;;; 5-Jun-1994 I. Kalet modify process-button-press for exit button,
+;;; to check for on, so that accidental exit does not occur
+;;; 3-Jan-1995 I. Kalet move exit button stuff to dialogboxes to
+;;; remove circular module dependency, also remove proclaim form.
+;;; 7-Jun-1997 I. Kalet add icon-button, which provides a filled or
+;;; outline contour in the foreground color, also make-arrow-button,
+;;; which returns an icon-button with a filled arrow polygon.
+;;; 23-Apr-1999 I. Kalet changes to support multiple colormaps
+;;; 30-May-2000 I. Kalet add support for 3-d border style.
+;;; 13-Mar-2001 I. Kalet allow button-2 active even if button-1 not.
+;;;
+
+(in-package :slik)
+
+;;;------------------------------------------------
+
+(defclass button (frame)
+
+ ((active :accessor active
+ :initarg :active
+ :documentation "True if the button responds to X events,
+otherwise nil.")
+
+ (allow-button-2 :accessor allow-button-2
+ :initarg :allow-button-2
+ :documentation "Normally button-2 is disabled if
+active is nil, but this being non-nil overrides that.")
+
+ (on :accessor on
+ :initarg :on
+ :documentation "A flag that holds the state of the button.")
+
+ (button-type :type (member :momentary :hold)
+ :reader button-type
+ :initarg :button-type)
+
+ (label :type string
+ :accessor label
+ :initarg :label)
+
+ (justify :type (member :left :center :right)
+ :accessor justify
+ :initarg :justify)
+
+ (label-x :type clx:card16
+ :accessor label-x)
+
+ (label-y :type clx:card16
+ :accessor label-y)
+
+ (button-on :type ev:event
+ :accessor button-on
+ :initform (ev:make-event))
+
+ (button-off :type ev:event
+ :accessor button-off
+ :initform (ev:make-event))
+
+ (button-2-on :type ev:event
+ :accessor button-2-on
+ :initform (ev:make-event))
+ )
+
+ (:default-initargs :title "SLIK button"
+ :active t :allow-button-2 nil :on nil
+ :label "" :justify :center :button-type :hold)
+
+ (:documentation "A button is a frame which can be clicked on or off.
+It has a color that changes when it is on, and might have a text label.")
+
+ )
+
+;;;------------------------------------------------
+
+(defun make-button (width height &rest other-initargs)
+
+ "make-button width height &rest other-initargs
+
+Returns a button with the specified parameters. If a label is
+provided it is positioned accordingly."
+
+ (apply 'make-instance 'button
+ :width width :height height other-initargs))
+
+;;;------------------------------------------------
+
+(defmethod refresh :before ((b button))
+
+ (let* ((text (label b))
+ (win (window b))
+ (gc-fg (color-gc (fg-color b) (colormap b)))
+ (gc-bg (color-gc (bg-color b) (colormap b)))
+ (flood (if (and (eql (border-style b) :flat) (on b))
+ gc-fg gc-bg))
+ (text-col (if (and (eql (border-style b) :flat) (on b))
+ gc-bg gc-fg)))
+ ;; first color the button
+ (clx:draw-rectangle win flood 0 0 (width b) (height b) t)
+ ;; then add label if there is one
+ (unless (equal text "")
+ (clx:with-gcontext (text-col :font (font b))
+ (clx:draw-glyphs win text-col (label-x b) (label-y b) text)))))
+
+;;;------------------------------------------------
+
+(defun set-label-xy (b)
+
+ "set-label-xy b
+
+updates the label-x and label-y attributes according to the current
+contents of the other button attributes."
+
+ (let* ((w (width b))
+ (h (height b))
+ (f (font b))
+ (font-descent (clx:max-char-descent f))
+ (label-width (clx:text-width f (label b)))
+ )
+ (setf (label-x b) (case (justify b)
+ (:left 5)
+ (:center (round (/ (- w label-width) 2)))
+ (:right (- w label-width)))
+ (label-y b) (- h (round (/ (- h (font-height f)) 2))
+ font-descent))))
+
+;;;------------------------------------------------
+
+(defmethod initialize-instance :after ((b button) &rest initargs)
+
+ "Used also by exit-button."
+
+ (declare (ignore initargs))
+ (set-label-xy b)
+ (refresh b))
+
+;;;------------------------------------------------
+
+(defmethod (setf on) :after (turned-on (b button))
+
+ "Used to change the on-off state of the button. The turned-on
+parameter is t or nil."
+
+ (unless (eql (border-style b) :flat)
+ (setf (border-style b) (if turned-on :lowered :raised)))
+ (refresh b)
+ (ev:announce b (if (on b) (button-on b) (button-off b))))
+
+;;;------------------------------------------------
+
+(defmethod (setf label) :after (new-label (b button))
+
+ (declare (ignore new-label))
+ (set-label-xy b)
+ (refresh b))
+
+;;;------------------------------------------------
+
+(defmethod (setf font) :after (new-font (b button))
+
+ (declare (ignore new-font))
+ (set-label-xy b)
+ (refresh b))
+
+;;;------------------------------------------------
+
+(defmethod process-button-press ((b button) code x y)
+
+ (declare (ignore x y))
+ (case code
+ (1 (when (active b) ; left mouse button
+ (if (eql (button-type b) :hold) ; i.e., click on, click off
+ (setf (on b) (not (on b))) ; if off, turn on and vice versa
+ (setf (on b) t)))) ; for momentary, just turn on
+ (2 (when (or (active b) (allow-button-2 b)) ; middle mouse button
+ (ev:announce b (button-2-on b))))) ; just announce
+ nil)
+
+;;;------------------------------------------------
+
+(defmethod process-button-release ((b button) code x y)
+
+ (declare (ignore x y))
+
+ (when (and (active b)
+ (= code 1) ;; left button
+ (eql (button-type b) :momentary)) ;; release turns it off
+ (setf (on b) nil)) ;; but for :hold type, do nothing
+ nil)
+
+;;;------------------------------------------------
+
+(defclass icon-button (button)
+
+ ((icon :type list
+ :accessor icon
+ :initarg :icon
+ :documentation "The pixel coordinates of the icon outline, in
+a form suitable for input to clx:draw-lines, i.e., a simple list of
+alternating x and y values for the vertices.")
+
+ (filled :accessor filled
+ :initarg :filled
+ :documentation "A boolean, specifies whether to fill the
+icon.")
+
+ )
+
+ (:default-initargs :button-type :momentary :icon nil :filled t)
+
+ (:documentation "An icon button has a polygon drawn on it, like an
+arrow shape, in the foreground color, usually instead of text, but if
+not filled, could be in combination with some text.")
+
+ )
+
+;;;------------------------------------------------
+
+(defmethod refresh :after ((b icon-button))
+
+ "Just adds the polygon."
+
+ (clx:draw-lines (window b)
+ (color-gc (if (on b) (bg-color b) (fg-color b))
+ (colormap b))
+ (icon b)
+ :fill-p (filled b)))
+
+;;;------------------------------------------------
+
+(defun make-icon-button (width height icon &rest initargs)
+
+ "make-icon-button width height icon &rest initargs
+
+Returns an icon button with the specified parameters."
+
+ (apply 'make-instance 'icon-button
+ :width width :height height
+ :icon icon
+ initargs))
+
+;;;------------------------------------------------
+
+(defun make-arrow-button (width height direction &rest initargs)
+
+ "make-arrow-button width height direction &rest initargs
+
+Returns an arrow button in the specified direction, one of the
+keywords, :left :right :up or :down."
+
+ (apply #'make-icon-button width height
+ (let* ((hx (round (/ width 2)))
+ (hy (round (/ height 2)))
+ (x13 (round (/ width 3)))
+ (x23 (* 2 x13))
+ (y13 (round (/ height 3)))
+ (y23 (* 2 y13)))
+ (case direction ;; pass in the correct arrow polygon
+ (:left (list 0 hy hx 0 hx y13 width y13
+ width y23 hx y23 hx height 0 hy))
+ (:right (list width hy hx 0 hx y13 0 y13
+ 0 y23 hx y23 hx height width hy))
+ (:up (list hx 0 width hy x23 hy x23 height
+ x13 height x13 hy 0 hy hx 0))
+ (:down (list hx height width hy x23 hy x23 0
+ x13 0 x13 hy 0 hy hx height))))
+ initargs))
+
+;;;------------------------------------------------
+;;; End.
diff --git a/slik/src/clx-support.cl b/slik/src/clx-support.cl
new file mode 100644
index 0000000..eeac990
--- /dev/null
+++ b/slik/src/clx-support.cl
@@ -0,0 +1,329 @@
+;;;
+;;; clx-support
+;;;
+;;; This module contains all the basic CLX support for SLIK, the revised
+;;; small LISP toolkit, based on Mark Niehaus's minitools.
+;;;
+;;; 13-Jan-1992 I. Kalet started
+;;; 13-Apr-1992 I. Kalet change colors from pixel to graphic contexts
+;;; 01-May-1992 I. Kalet delete unnecessary functions
+;;; 03-May-1992 I. Kalet move image stuff to images file
+;;; 15-May-1992 I. Kalet add font-height function
+;;; 24-May-1992 I. Kalet move exported symbols to slik-exports
+;;; 14-Jul-1992 I. Kalet add make-duplicate-gc function
+;;; 8-Oct-1992 I. Kalet make parameter in make-duplicate-gc &optional
+;;; 30-Oct-1992 I. Kalet added *linespace* parameter, deleted
+;;; text-height, added named font variables
+;;; 23-Mar-1993 J. Unger add type declaration to assign-gray-pixels
+;;; 3-Aug-1993 I. Kalet add color invisible, which uses NOOP draw
+;;; operation in its gcontext.
+;;; 25-Apr-1994 I. Kalet add make-square-pixmap, extracted from Prism
+;;; 5-Jun-1994 I. Kalet add host function - not strictly reliable...
+;;; 03-Oct-1994 J. Unger add support for dashed colors.
+;;; 3-Jan-1995 I. Kalet remove proclaim form, make initialize function
+;;; return nil if successful, as documented, put *kp-enter-keysym* here
+;;; as global, but leave terminate function in event-loop.
+;;; 18-Feb-1996 I. Kalet add new globals to handle different display
+;;; configurations.
+;;; 8-Oct-1996 I. Kalet move find-dashed-color and find-solid-color
+;;; here from Prism.
+;;; 25-Feb-1998 I. Kalet cosmetic changes
+;;; 21-Jul-1998 I. Kalet add optional arg to initialize to not
+;;; allocate gray scale in the screen default colormap.
+;;; 16-Dec-1998 I. Kalet add hack for wierdness in default host for
+;;; HP-UX 10.20 X support.
+;;; 1-Apr-1999 C. Wilcox added event-level and background-event-queue
+;;; initialization to the slik initialize function.
+;;; 25-Apr-1999 I. Kalet big overhaul to add support for multiple
+;;; colormaps.
+;;; 31-May-2000 I. Kalet add support for Helvetica medium fonts,
+;;; provide new exported global, *default-font-name* so an application
+;;; can set it before calling initialize.
+;;; 4-Aug-2000 I. Kalet add support for display other than display 0,
+;;; allow host in initialize to include display number.
+;;; 25-Aug-2000 I. Kalet call load-gl in initialize.
+;;; 27-Dec-2000 I. Kalet make localhost and blank string equivalent in
+;;; host function.
+;;; 18-Mar-2001 I. Kalet add default foreground and background colors
+;;; and border style - black on gray, raised borders, but user configurable.
+;;; Make HPUX-10 host hack independent of Allegro version.
+;;; 23-Jun-2001 I. Kalet add egregious hack to fix an obscure CLX bug -
+;;; see end of this file.
+;;; 30-Jul-2004 I. Kalet move initialize and related code to separate
+;;; file to untangle dependency circularity with OpenGL code.
+;;; 17-May-2008 I. Kalet take out ref to HP-UX, long gone.
+;;;
+
+(in-package :slik)
+
+;;;--------------------------------------------
+;;; The following global variables are used in places throughout the SLIK
+;;; system, but are not intended to be manipulated by users of the
+;;; package. Instead they are managed by function calls to SLIK
+;;; functions.
+;;;--------------------------------------------
+
+(defvar *host* "" "Name of the graphic display host")
+(defvar *display* nil "Only one open-display call made at initialization")
+(defvar *screen* nil "Display default screen")
+(defvar *screen-root* nil "Root window for *screen*")
+(defvar *screen-default-colormap* nil "Shared default colormap")
+(defvar *screen-root-depth* 8 "Depth of the screen root window")
+(defvar *image-bits-per-pixel* 8 "Bits per pixel corresponding to the
+pixmap format of the screen default depth - needed for images and not
+always equal to screen root depth.")
+
+;;;--------------------------------------------
+;;; Define/bind the number of entries in the gray pixel ramp here.
+;;;--------------------------------------------
+
+(defvar *default-gray-pixels* "For gray scale images")
+(defparameter *num-gray-pixels* 128)
+
+;;;--------------------------------------------
+
+(defconstant *up-arrow-keysym* 65362 "The X keysym for the up arrow.")
+(defconstant *down-arrow-keysym* 65364 "The X keysym for the down arrow.")
+(defconstant *kp-enter-keysym* 65421 "The X keysym for the keypad enter key")
+(defconstant *button-1* 1 "The X keycode for mouse button 1")
+
+;;;--------------------------------------------
+
+(defparameter *linespace* 10
+"Pixels vertical space between lines of text.")
+
+;;;--------------------------------------------
+
+(defvar *default-border-style* :raised)
+
+;;;--------------------------------------------
+;;; named and default fonts
+;;;--------------------------------------------
+
+(defvar *default-font-name* 'helvetica-medium-14
+ "Symbol, can be changed by application before calling initialize.")
+
+(defvar *default-font* nil "Default font for primary graphic contexts")
+(defvar courier-bold-12)
+(defvar courier-bold-14)
+(defvar courier-bold-18)
+(defvar times-bold-12)
+(defvar times-bold-14)
+(defvar times-bold-18)
+(defvar helvetica-medium-12)
+(defvar helvetica-medium-14)
+(defvar helvetica-medium-18)
+(defvar helvetica-bold-12)
+(defvar helvetica-bold-14)
+(defvar helvetica-bold-18)
+(defvar schoolbook-bold-12)
+(defvar schoolbook-bold-14)
+(defvar schoolbook-bold-18)
+
+;;;--------------------------------------------
+;;; The following global variables hold graphic contexts for the
+;;; primary colors. In places where colors are stored as attributes
+;;; for objects, use the symbols sl:red, sl:blue, etc. and get the
+;;; graphic contexts by (color-gc (color obj) colormap). Their values
+;;; are set by the make-primary-gc function below, called by the
+;;; initialize function.
+;;;--------------------------------------------
+
+(defvar red nil)
+(defvar green nil)
+(defvar blue nil)
+(defvar magenta nil)
+(defvar cyan nil)
+(defvar yellow nil)
+(defvar black nil)
+(defvar black2 nil) ;; used for button edge shadows
+(defvar white nil)
+(defvar gray nil)
+(defvar default-fg nil) ;; used for widget foreground
+(defvar default-bg nil) ;; used for widget background
+(defvar invisible nil)
+
+(defvar red-dashed nil)
+(defvar green-dashed nil)
+(defvar blue-dashed nil)
+(defvar magenta-dashed nil)
+(defvar cyan-dashed nil)
+(defvar yellow-dashed nil)
+(defvar black-dashed nil)
+(defvar white-dashed nil)
+(defvar gray-dashed nil)
+
+(defvar *fg-level* 0.0) ;; used for making default-fg
+(defvar *bg-level* 0.75) ;; used for making default-bg
+
+;;;--------------------------------------------
+
+(defun host ()
+
+ "host
+
+returns the string naming the host for the current display"
+
+ (if (or (string-equal *host* "")
+ (string-equal *host* "localhost"))
+ (short-site-name)
+ *host*))
+
+;;;--------------------------------------------
+
+(defun color-gc (color &optional (colormap *screen-default-colormap*))
+
+ "color-gc color &optional (colormap *screen-default-colormap*)
+
+returns the graphic context for the symbol color, naming one of the
+predefined colors. The colormap parameter is used to look it up in
+the association list bound to the symbol."
+
+ (second (find colormap (symbol-value color) :key #'first)))
+
+;;;--------------------------------------------
+
+(defun make-duplicate-gc (&optional base-gc)
+
+ "make-duplicate-gc &optional base-gc
+
+returns a fresh clx:gcontext object whose parameters are identical to
+those of base-gc. If base-gc is null, white is used."
+
+ (unless base-gc (setq base-gc (color-gc 'white)))
+ (let ((new-gc (clx:create-gcontext :drawable *screen-root*)))
+ (clx:copy-gcontext base-gc new-gc)
+ new-gc))
+
+;;;--------------------------------------------
+
+(defun flush-output ()
+
+ "flush-output
+
+force any pending graphics operation on the SLIK display."
+
+ (clx:display-force-output *display*))
+
+;;;--------------------------------------------
+
+(defun font-height (f)
+
+ "font-height f
+
+Returns the sum of the maximum character ascent and maximum character
+descent of font f."
+
+ (+ (clx:max-char-descent f)
+ (clx:max-char-ascent f)))
+
+;;;--------------------------------------------
+
+(defun make-square-pixmap (size &optional fill-p drawable depth)
+
+ "make-square-pixmap size &optional fill-p drawable depth
+
+Creates and returns a pixmap with the specified parameter attributes.
+Fills the pixmap with a black background if fill-p is true. If not
+provided, depth and drawable are taken from the screen root window."
+
+ (unless drawable (setq drawable *screen-root*))
+ (unless depth (setq depth (clx:drawable-depth drawable)))
+ (let ((pm (clx:create-pixmap :width size
+ :height size
+ :depth depth
+ :drawable drawable)))
+ (when fill-p (clx:draw-rectangle pm (color-gc 'black)
+ 0 0 size size t))
+ pm))
+
+;;;--------------------------------------------
+
+(defmacro aif (test-form then-form &optional else-form)
+
+ "anaphoric if from Graham, On Lisp."
+
+ `(let ((it ,test-form))
+ (if it ,then-form ,else-form)))
+
+;;;--------------------------------------------
+
+(defun find-dashed-color (col)
+
+ "find-dashed-color col
+
+Given the gc for a solid color col, finds and returns the gc for the
+corresponding dashed color. Returns nil if a solid color was not
+supplied. The invisible color maps to invisible."
+
+ (or
+ (aif (find col red :key #'second)
+ (second (find (first it) red-dashed :key #'first)))
+ (aif (find col green :key #'second)
+ (second (find (first it) green-dashed :key #'first)))
+ (aif (find col blue :key #'second)
+ (second (find (first it) blue-dashed :key #'first)))
+ (aif (find col yellow :key #'second)
+ (second (find (first it) yellow-dashed :key #'first)))
+ (aif (find col magenta :key #'second)
+ (second (find (first it) magenta-dashed :key #'first)))
+ (aif (find col cyan :key #'second)
+ (second (find (first it) cyan-dashed :key #'first)))
+ (aif (find col white :key #'second)
+ (second (find (first it) white-dashed :key #'first)))
+ (aif (find col black :key #'second)
+ (second (find (first it) black-dashed :key #'first)))
+ (aif (find col gray :key #'second)
+ (second (find (first it) gray-dashed :key #'first)))
+ (if (find col invisible :key #'second) col)))
+
+;;;--------------------------------------------
+
+(defun find-solid-color (col)
+
+ "find-solid-color col
+
+Given the gc for a dashed color col, finds and returns the gc for the
+corresponding solid color. Returns nil if a dashed color was not
+supplied. The invisible color maps to invisible."
+
+ (or
+ (aif (find col red-dashed :key #'second)
+ (second (find (first it) red :key #'first)))
+ (aif (find col green-dashed :key #'second)
+ (second (find (first it) green :key #'first)))
+ (aif (find col blue-dashed :key #'second)
+ (second (find (first it) blue :key #'first)))
+ (aif (find col yellow-dashed :key #'second)
+ (second (find (first it) yellow :key #'first)))
+ (aif (find col magenta-dashed :key #'second)
+ (second (find (first it) magenta :key #'first)))
+ (aif (find col cyan-dashed :key #'second)
+ (second (find (first it) cyan :key #'first)))
+ (aif (find col white-dashed :key #'second)
+ (second (find (first it) white :key #'first)))
+ (aif (find col black-dashed :key #'second)
+ (second (find (first it) black :key #'first)))
+ (aif (find col gray-dashed :key #'second)
+ (second (find (first it) gray :key #'first)))
+ (if (find col invisible :key #'second) col)))
+
+;;;----------------------------------------------------------
+;;; It seems that Allegro did not quite track between changes in ANSI
+;;; Common Lisp and the old (1989) implementation of CLX - this is a
+;;; temporary hack to prevent a crash when users type control
+;;; characters into textlines.
+
+(in-package :clx)
+
+#+allegro
+(defun default-keysym-translate (display state object)
+ (declare (type display display)
+ (type card16 state)
+ (type t object)
+ (ignore display state)
+ (values t))
+ object)
+
+;;;--------------------------------------------
+;;; End.
diff --git a/slik/src/collections.cl b/slik/src/collections.cl
new file mode 100644
index 0000000..8e0a2f9
--- /dev/null
+++ b/slik/src/collections.cl
@@ -0,0 +1,179 @@
+;;;
+;;; collections
+;;;
+;;; An implemetation of sets and binary relations as Abstract
+;;; Behavioral Types. It uses stuff from the events package so be
+;;; sure to load that first.
+;;;
+;;; 29-May-1992 I. Kalet created
+;;; 2-Jun-1992 I. Kalet modify export list
+;;; 3-Jun-1992 I. Kalet finish relations code
+;;; 24-Jun-1992 I. Kalet move defpackage etc. to config file. Also
+;;; added keyword argument :test to functions that check for membership,
+;;; to default to equal rather than eql and caller may provide
+;;; alternate tests as well.
+;;; 6-Jul-1992 I. Kalet change behavior to event and be: to ev:
+;;; 30-Jun-1994 I. Kalet enforce constraints that insertion and
+;;; deletion preserves order of elements, and adds new elements at
+;;; end, not beginning of list.
+;;; 3-Jan-1995 I. Kalet move defpackage here so this file can be
+;;; standalone or used as a module in a system. NOTE however that
+;;; this module depends on the events module so the events module
+;;; must be loaded first.
+;;; 1-Feb-1996 I. Kalet drop make-package, assume defpackage
+;;; 18-Apr-1997 I. Kalet drop support for old CMU with PCL, assume
+;;; native CLOS
+;;; 29-Jun-1997 I. Kalet use find instead of member, in
+;;; delete-element, so can announce the actual item deleted, not the
+;;; item provided as the parameter. They may not be the same object.
+;;;
+;;;----------------------------------------------------------
+
+
+(defpackage "COLLECTIONS" (:nicknames "COLL")
+ (:use "COMMON-LISP")
+ (:export "MAKE-COLLECTION" "ELEMENTS" "INSERTED" "DELETED"
+ "INSERT-ELEMENT" "DELETE-ELEMENT"
+ "COLLECTION-SIZE" "COLLECTION-MEMBER"
+ "MAKE-RELATION" "PROJECTION" "INVERSE-RELATION"))
+
+;;;----------------------------------------------------------
+
+(in-package :collections)
+
+;;;----------------------------------------------------------
+
+(defclass collection ()
+
+ ((elements :type list
+ :accessor elements
+ :initarg :elements
+ :initform nil
+ :documentation "The list of actual objects in the set.")
+
+ (inserted :type ev:event
+ :accessor inserted
+ :initform (ev:make-event)
+ :documentation "Announced when a new element is inserted.")
+
+ (deleted :type ev:event
+ :accessor deleted
+ :initform (ev:make-event)
+ :documentation "Announced when an element is deleted.")
+
+ )
+
+ (:documentation "The collection class implements the abstract
+behavioral type SET.")
+
+ )
+
+;;;---------------------------------
+
+(defun make-collection (&optional initial-contents)
+
+ "MAKE-COLLECTION &optional initial-contents
+
+returns an instance of a collection, with elements set to the value of
+initial-contents."
+
+ (make-instance 'collection :elements initial-contents))
+
+;;;---------------------------------
+
+(defun insert-element (el coll &key (test #'equal))
+
+ "INSERT-ELEMENT el coll &key test
+
+inserts the object el into the collection coll if not already
+present. The test function if provided is used to test whether to
+insert the element, and defaults to equal. The new element is added
+at the end, not the front of the list."
+
+ (unless (member el (elements coll) :test test)
+ (setf (elements coll) (append (elements coll) (list el)))
+ (ev:announce coll (inserted coll) el)))
+
+;;;---------------------------------
+
+(defun delete-element (el coll &key (test #'equal))
+
+ "DELETE-ELEMENT el coll &key test
+
+deletes the object el from the collection coll if it is present. The
+test function is used to decide if the element is present, and defaults
+to equal. The order of the remaining elements is preserved."
+
+ (let ((item (find el (elements coll) :test test)))
+ (when item
+ (setf (elements coll) (remove item (elements coll)))
+ (ev:announce coll (deleted coll) item))))
+
+;;;---------------------------------
+
+(defun collection-size (coll)
+
+ "COLLECTION-SIZE coll
+
+returns the number of elements in collection coll."
+
+ (length (elements coll)))
+
+;;;---------------------------------
+
+(defun collection-member (el coll &key (test #'equal))
+
+ "COLLECTION-MEMBER el coll &key test
+
+if object el satisfies test for some member of the collection, the
+result of test is returned. The default for test is equal, i.e., it
+tests if el is a member of collection coll. If no element of coll
+satisfies the test, collection-member returns nil."
+
+ (some #'(lambda (item) (funcall test el item))
+ (elements coll)))
+
+;;;---------------------------------
+
+(defclass relation (collection)
+
+ () ; no additional slots
+
+ (:documentation "A relation is a collection in which the elements
+are two element lists, i.e., the relation table is implemented as an
+association list for now.")
+
+ )
+
+;;;---------------------------------
+
+(defun make-relation (&optional initial-elements)
+
+ (make-instance 'relation :elements initial-elements))
+
+;;;---------------------------------
+
+(defun projection (el rel &key (test #'equal))
+
+ "PROJECTION el rel &key test
+
+returns the image or projection of the element el under the relation
+rel using the test function test. The default for test is equal."
+
+ (remove nil (mapcar #'(lambda (pair)
+ (if (apply test (list el (first pair)))
+ (second pair)))
+ (elements rel))))
+
+;;;---------------------------------
+
+(defun inverse-relation (rel)
+
+ "INVERSE-RELATION rel
+
+returns the inverse relation of rel."
+
+ (make-relation (mapcar 'reverse (elements rel))))
+
+;;;---------------------------------
+;;; End.
diff --git a/slik/src/dialboxes.cl b/slik/src/dialboxes.cl
new file mode 100644
index 0000000..95b6633
--- /dev/null
+++ b/slik/src/dialboxes.cl
@@ -0,0 +1,159 @@
+;;;
+;;; dialboxes
+;;;
+;;; The dialbox is a combination of a dial and a textline constrained
+;;; so that the textline displays the value set on the dial.
+;;;
+;;; 12-May-1992 I. Kalet created
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 27-May-1992 I. Kalet fix up type declarations
+;;; 6-Jul-1992 I. Kalet change behavior to event and be: to ev:
+;;; 9-Jul-1992 I. Kalet fix dial-update so blank string sets 0
+;;; degrees
+;;; 8-Oct-1992 I. Kalet add destroy :before method, add missing
+;;; (setf angle) method
+;;; 28-Oct-1992 I. Kalet eliminate pixmap
+;;; 29-Nov-1992 I. Kalet fix minor errors - better positioning of
+;;; title text, provide refresh method so text is redrawn.
+;;; 29-Dec-1992 I. Kalet change angle to degrees instead of radians
+;;; 12-Feb-1993 I. Kalet squeeze and parametrize margins.
+;;; 13-May-1994 I. Kalet use error checking in textline
+;;; 3-Jan-1995 I. Kalet remove proclaim form
+;;; 3-Sep-1995 I. Kalet move announce to correct place. Eliminate
+;;; the busy flag - not needed since textlines don't announce when
+;;; their infos are set, only on RETURN.
+;;;
+
+(in-package :slik)
+
+;;;-----------------------------------------
+
+(defclass dialbox (frame)
+
+ ((the-dial :type dial
+ :accessor the-dial)
+
+ (the-text :type textline
+ :accessor the-text)
+
+ (title-x :type clx:card16
+ :accessor title-x) ; computed and cached
+
+ (title-y :type clx:card16
+ :accessor title-y) ; computed and cached
+
+ (value-changed :type ev:event
+ :accessor value-changed
+ :initform (ev:make-event))
+
+ )
+
+ (:default-initargs :title "")
+
+ (:documentation "A dialbox contains a dial and a textline, and
+constrains the textline to display the value on the dial, and set the
+dial pointer at the value of the textline.")
+
+ )
+
+;;;-----------------------------------------
+
+(defmethod angle ((db dialbox))
+
+ "Returns the angle of the dial in the dialbox"
+
+ (angle (the-dial db))
+ )
+
+;;;-----------------------------------------
+
+(defmethod (setf angle) (new-angle (db dialbox))
+
+ "Sets the angle of the dial in the dialbox"
+
+ (setf (angle (the-dial db)) new-angle)
+ )
+
+;;;-----------------------------------------
+
+(defmethod refresh ((db dialbox))
+
+ "draws the title text."
+
+ (clx:draw-glyphs (window db) (gc-with-font (the-text db))
+ (title-x db) (title-y db) (title db))
+ )
+
+;;;-----------------------------------------
+
+(defun make-dialbox (radius &rest other-initargs
+ &key (font *default-font*)
+ &allow-other-keys)
+
+ "MAKE-DIALBOX radius &rest other-initargs
+
+returns a dialbox with a dial of the specified radius, a textline with
+the size needed for angle values in the specified or default font, and
+with all the other specified parameters, e.g., foreground and
+background colors, etc."
+
+ (let* ((dx 5) ; margin sizes
+ (dy 5)
+ (ds (* 2 (+ radius 5))) ; dial size - dependent on dial specs
+ (width (+ ds (* 2 dx)))
+ (th (+ (font-height font) 10)) ; this 10 is arbitrary
+ (height (+ (* 2 dy) ds (* 2 th))) ; top, bottom, dial, title
+ ; and textline
+ (db (apply #'make-instance 'dialbox
+ :width width :height height other-initargs))
+ )
+ (setf (the-dial db)
+ (apply #'make-dial radius :parent (window db)
+ :ulc-x dx :ulc-y dy other-initargs)
+ (the-text db)
+ (apply #'make-textline ds th :info " 0.0"
+ :parent (window db)
+ :ulc-x dx
+ :ulc-y (+ dy ds th)
+ :numeric t :lower-limit 0.0 :upper-limit 360.0
+ other-initargs)
+ (title-x db) (round (/ (- width
+ (clx:text-width font (title db)))
+ 2))
+ (title-y db) (+ dy ds th -8)) ; arbitrary - needs work
+ (refresh db)
+
+ ;; following is needed so angle can be provided as initpar
+ (setf (info (the-text db)) (format nil "~5,1F" (angle db)))
+
+ ;; when the dial changes, the text updates and the outer event is
+ ;; announced
+ (ev:add-notify db (value-changed (the-dial db))
+ #'(lambda (box d val)
+ (declare (ignore d))
+ (setf (info (the-text box))
+ (format nil "~5,1F" val))
+ (ev:announce box (value-changed box) val)))
+ ;; when the user presses RETURN, setting the angle also causes the
+ ;; previous action, since the dial announces value-changed. No
+ ;; circularity here since setting the textline does not trigger an
+ ;; event, only pressing RETURN does.
+ (ev:add-notify db (new-info (the-text db))
+ #'(lambda (box tl info)
+ (declare (ignore tl))
+ (setf (angle box)
+ (read-from-string info nil 0.0)))) ;; blank = 0
+ db)
+ )
+
+;;;-----------------------------------------
+
+(defmethod destroy :before ((db dialbox))
+
+ "Destroys the dial and the textline first."
+
+ (destroy (the-dial db))
+ (destroy (the-text db))
+ )
+
+;;;-----------------------------------------
diff --git a/slik/src/dialogboxes.cl b/slik/src/dialogboxes.cl
new file mode 100644
index 0000000..cb32695
--- /dev/null
+++ b/slik/src/dialogboxes.cl
@@ -0,0 +1,419 @@
+;;;
+;;; dialogboxes
+;;;
+;;; This module implements some simple dialog boxes using the SLIK
+;;; facility for nested event processing loops. Thus the dialog box
+;;; waits for user input, and events that happen in all the other
+;;; application windows are ignored and discarded. Note that this
+;;; applies only to windows created by the current SLIK application,
+;;; not to other processes that have their own connection to the
+;;; display, i.e. other terminal windows, other applications running
+;;; on the same display...
+;;;
+;;; 28-Oct-1992 I. Kalet created
+;;; 15-Feb-1993 I. Kalet add popup-color-menu
+;;; 3-Aug-1993 I. Kalet add invisible to popup-color-menu
+;;; 16-May-1994 J. Unger add popup-textbox function.
+;;; 3-Jan-1995 I. Kalet move exit-button here because it uses
+;;; confirm, move popup-scroll-menu to scrolling-lists to undo
+;;; circularity there.
+;;; 25-Apr-1997 I. Kalet cosmetics, also add popup-textline to
+;;; textlines, not here, to avoid circularity in dependency graph
+;;; 10-Apr-1999 C. Wilcox changed exit-button to work with the
+;;; new event-handling code.
+;;; 23-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 26-Nov-2000 I. Kalet some cosmetic changes to match default gray
+;;; backgrounds of other widgets and default border styles.
+;;; 21-Jun-2004 I. Kalet add default selection input to popup-menu
+;;;
+
+(in-package :slik)
+
+;;;--------------------------------------
+
+(defparameter *ack-label* "Acknowledge")
+(defparameter *proc-label* "Proceed")
+(defparameter *can-label* "Cancel")
+
+;;;--------------------------------------
+
+(defclass exit-button (button)
+
+ ((confirm-exit :accessor confirm-exit
+ :initarg :confirm-exit
+ :documentation "If not nil, should be a string or
+list of strings that will be used as a confirmation message. This
+specifies that the exit button should confirm before terminating. ")
+
+ )
+
+ (:default-initargs :title "Exit button" :button-type :momentary
+ :label "EXIT" :bg-color 'red :confirm-exit nil)
+
+ (:documentation "A pre-made button that returns t instead of nil.")
+
+ )
+
+;;;--------------------------------------
+
+(defun make-exit-button (width height &rest other-initargs)
+
+ (apply 'make-instance 'exit-button
+ :width width :height height other-initargs))
+
+;;;--------------------------------------
+
+(defmethod process-button-release ((b exit-button) code x y)
+
+ (declare (ignore x y))
+ (when (and (active b)
+ (on b)
+ (= code 1)) ;; left button
+ (setf (on b) nil)
+
+ (when (not (and (confirm-exit b) (not (confirm (confirm-exit b)))))
+ (decf *current-event-level* 1))
+ t))
+
+;;;--------------------------------------
+
+(defclass message-box (frame)
+
+ ((message :reader message
+ :initarg :message
+ :documentation "The list of strings, one string per line,
+that is the contents of the message box.")
+
+ (ack-button :accessor ack-button
+ :documentation "The exit button that says Acknowledge
+and returns from the event loop when pressed.")
+
+ )
+
+ (:default-initargs :title "Message")
+ )
+
+;;;--------------------------------------
+
+(defmethod refresh ((mb message-box))
+
+ "redraws the message in the message box - the button takes care of
+itself."
+
+ (let* ((item-height (+ (font-height (font mb)) 5))
+ (y 0))
+ (dolist (line (message mb))
+ (setq y (+ y item-height))
+ (clx:draw-glyphs (window mb)
+ (color-gc (fg-color mb) (colormap mb))
+ 5 y line))))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((mb message-box)
+ &rest initargs)
+
+ (let* ((win (window mb))
+ (width (width mb))
+ (height (height mb))
+ (ft (font mb))
+ (button-width (+ 10 (clx:text-width ft *ack-label*)))
+ (button-height (+ (font-height ft) *linespace*)))
+ (setf (ack-button mb)
+ (apply #'make-exit-button button-width button-height
+ :label *ack-label* :parent win
+ :ulc-x (round (/ (- width button-width) 2))
+ :ulc-y (- height button-height 5)
+ initargs))
+ (refresh mb)))
+
+;;;--------------------------------------
+
+(defun acknowledge (message &rest initargs &key font &allow-other-keys)
+
+ "acknowledge message &rest initargs
+
+creates a message box for message, a string or list of strings,
+together with an Acknowledge button. Waits for the user to press the
+Acknowledge button, then returns nil. Any other events for windows in
+the same display connection are discarded."
+
+ (push-event-level)
+ (unless (listp message) (setq message (list message)))
+ (let* ((ft (or font *default-font*))
+ (width (apply 'max
+ (+ 10 (clx:text-width ft *ack-label*))
+ (mapcar #'(lambda (item)
+ (clx:text-width ft item))
+ message)))
+ (item-height (+ (font-height ft) *linespace*))
+ (mbox (apply #'make-instance 'message-box
+ :width (+ width 10)
+ :height (+ (* (length message) item-height)
+ item-height ; for button
+ 10) ; space between text and button
+ :message message
+ initargs)))
+ (process-events)
+ (destroy (ack-button mbox))
+ (destroy mbox))
+ (pop-event-level))
+
+;;;--------------------------------------
+
+(defclass confirm-box (frame)
+
+ ((message :reader message
+ :initarg :message
+ :documentation "The list of strings, one string per line,
+that is the contents of the message box.")
+
+ (proc-button :accessor proc-button
+ :documentation "The exit button that says Proceed and
+returns t from the function when pressed.")
+
+ (can-button :accessor can-button
+ :documentation "The exit button that says Cancel and
+returns nil from the function when pressed.")
+
+ (return-value :accessor return-value
+ :documentation "Set by whichever button is pressed.")
+
+ )
+
+ (:default-initargs :title "Confirmation")
+ )
+
+;;;--------------------------------------
+
+(defmethod refresh ((mb confirm-box))
+
+ "exactly like the message box, redraws the message. The buttons
+take care of themselves."
+
+ (let* ((item-height (+ (font-height (font mb)) 5))
+ (y 0))
+ (dolist (line (message mb))
+ (setq y (+ y item-height))
+ (clx:draw-glyphs (window mb)
+ (color-gc (fg-color mb) (colormap mb))
+ 5 y line))))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((mb confirm-box)
+ &rest initargs)
+
+ (let* ((win (window mb))
+ (width (width mb))
+ (height (height mb))
+ (ft (font mb))
+ (button-width (+ 10 (clx:text-width ft *proc-label*)))
+ (button-height (+ (font-height ft) *linespace*))
+ (left-x (round (/ (- width (* 2 button-width) 10) 2))))
+ (setf (proc-button mb)
+ (apply #'make-exit-button button-width button-height
+ :label *proc-label* :parent win
+ :ulc-x left-x
+ :ulc-y (- height button-height 5)
+ :bg-color 'green
+ initargs))
+ (setf (can-button mb)
+ (apply #'make-exit-button button-width button-height
+ :label *can-label* :parent win
+ :ulc-x (- width button-width left-x)
+ :ulc-y (- height button-height 5)
+ initargs))
+ (ev:add-notify mb (button-on (proc-button mb))
+ #'(lambda (box btn)
+ (declare (ignore btn))
+ (setf (return-value box) t)))
+ (ev:add-notify mb (button-on (can-button mb))
+ #'(lambda (box btn)
+ (declare (ignore btn))
+ (setf (return-value box) nil)))
+ (refresh mb)))
+
+;;;--------------------------------------
+
+(defun confirm (message &rest initargs
+ &key font &allow-other-keys)
+
+ "confirm message &rest initargs
+
+creates a confirm box for message, a string or list of strings,
+together with a proceed button and a cancel button. Waits for the
+user to press either button, then returns t if proceed was pressed, or
+nil if cancel was pressed. Any other events for windows in the same
+display connection are discarded."
+
+ (push-event-level)
+ (unless (listp message) (setq message (list message)))
+ (let* ((ft (or font *default-font*))
+ (width (apply 'max
+ (+ (* 2 (clx:text-width ft *proc-label*))
+ 30) ;; 10 for each button, and 10 between
+ (mapcar #'(lambda (item)
+ (clx:text-width ft item))
+ message)))
+ (item-height (+ (font-height ft) *linespace*))
+ (mbox (apply #'make-instance 'confirm-box
+ :width (+ width 10)
+ :height (+ (* (length message) item-height)
+ item-height ; for buttons
+ 10) ; space between text and buttons
+ :message message
+ initargs))
+ (result nil))
+ (process-events)
+ (destroy (proc-button mbox))
+ (destroy (can-button mbox))
+ (setq result (return-value mbox))
+ (destroy mbox)
+ (pop-event-level)
+ result))
+
+;;;--------------------------------------
+
+(defun popup-menu (items &rest initargs
+ &key multiple default &allow-other-keys)
+
+ "popup-menu items &rest initargs &key multiple
+
+displays a menu of the items, a list of strings, at a nested event
+level so the user must choose one or more menu items. If multiple is
+nil, the default, then only one item can be selected and the function
+returns the item number. If multiple is not nil, then multiple
+selections are allowed and the function returns a list of item
+numbers. The initargs are the usual SLIK frame parameters."
+
+ (push-event-level)
+ (let* ((pmenu (apply (if multiple #'make-menu #'make-radio-menu)
+ items :mapped nil initargs))
+ (pmenu-width (width pmenu))
+ (pmenu-win (window pmenu))
+ (ft (font pmenu)) ;; Should buttons be same font as menu???
+ (button-width (+ 10 (clx:text-width ft "Accept")))
+ (button-height (+ (font-height ft) *linespace*))
+ ;; compute menubox size from menu size and accept/cancel
+ ;; button sizes
+ (width (max pmenu-width (+ (* 2 button-width) 20)))
+ (height (+ (height pmenu) button-height 10))
+ (menubox (apply #'make-frame width height initargs))
+ (win (window menubox))
+ (left-x (round (/ (- width (* 2 button-width) 10) 2)))
+ (ok-b (apply #'make-exit-button button-width button-height
+ :label "Accept" :parent win
+ :ulc-x left-x
+ :ulc-y (- height button-height 5)
+ :bg-color 'green
+ initargs))
+ (can-b (apply #'make-exit-button button-width button-height
+ :label *can-label* :parent win
+ :ulc-x (- width button-width left-x)
+ :ulc-y (- height button-height 5)
+ initargs))
+ (return-value nil))
+ (ev:add-notify menubox (button-on can-b)
+ #'(lambda (box btn)
+ (declare (ignore box btn))
+ (setq return-value nil)))
+ (ev:add-notify menubox (selected pmenu)
+ #'(lambda (l a item)
+ (declare (ignore l a))
+ (if multiple (push item return-value)
+ (setq return-value item))))
+ (ev:add-notify menubox (deselected pmenu)
+ #'(lambda (l a item)
+ (declare (ignore l a))
+ (if multiple (setq return-value
+ (remove item return-value)))))
+ (clx:reparent-window pmenu-win win
+ (round (/ (- width pmenu-width) 2))
+ 0) ; center in x, at top for y
+ (clx:map-window pmenu-win)
+ (clx:map-subwindows pmenu-win)
+ (when default (select-button default pmenu))
+ (flush-output)
+ (process-events)
+ ;; don't neet to ev:remove-notify since we are
+ ;; destroying all the controls anyway
+ (destroy pmenu)
+ (destroy ok-b)
+ (destroy can-b)
+ (destroy menubox)
+ (pop-event-level)
+ return-value))
+
+;;;--------------------------------------
+
+(defun popup-color-menu (&rest initargs)
+
+ "popup-color-menu
+
+displays a menu of SLIK named colors, at a nested event level so the
+user must choose one of the colors. No more than one color can be
+selected and the function returns the symbol in the SLIK package for
+that color. If the cancel button is pressed, the function returns
+NIL."
+
+ (let* ((color-list '(red green blue yellow magenta cyan white black
+ gray invisible))
+ (menu-list (mapcar #'symbol-name color-list))
+ (selection (apply #'popup-menu menu-list initargs)))
+ (if selection (nth selection color-list)))) ;; otherwise nil
+
+;;;--------------------------------------
+
+(defun popup-textbox (info width height &rest initargs)
+
+ "popup-textbox info width height &rest initargs
+
+Pops up a textbox, of the specified width and height, at a nested
+event level. The info parameter is a list of strings to initially
+appear in the textbox. When the Accept button is pressed, returns a
+list of strings representing the edited text. If the Cancel button is
+pressed, returns nil."
+
+ (push-event-level)
+ (let* ((frm (apply #'make-frame width height initargs))
+ (frm-win (window frm))
+ (tb (apply #'make-textbox width (- height 40)
+ :parent frm-win :info info initargs))
+ (ft (font tb))
+ (button-width (+ 10 (clx:text-width ft "Accept")))
+ (button-height 30)
+ (left-x (round (/ (- width (* 2 button-width) 10) 2)))
+ (acc-b (apply #'make-exit-button button-width button-height
+ :label "Accept" :parent frm-win
+ :ulc-x left-x
+ :ulc-y (- height button-height 5)
+ :bg-color 'green
+ initargs))
+ (can-b (apply #'make-exit-button button-width button-height
+ :label "Cancel" :parent frm-win
+ :ulc-x (- width button-width left-x)
+ :ulc-y (- height button-height 5)
+ initargs))
+ (return-value nil))
+ (ev:add-notify frm (button-on can-b)
+ #'(lambda (box btn)
+ (declare (ignore box btn))
+ (setq return-value nil)))
+ (ev:add-notify tb (button-on acc-b)
+ #'(lambda (box btn)
+ (declare (ignore box btn))
+ (setq return-value (info tb))))
+ (clx:map-window frm-win)
+ (clx:map-subwindows frm-win)
+ (flush-output)
+ (process-events)
+ (destroy tb)
+ (destroy acc-b)
+ (destroy can-b)
+ (destroy frm)
+ (pop-event-level)
+ return-value))
+
+;;;--------------------------------------
+;;; End.
diff --git a/slik/src/dials.cl b/slik/src/dials.cl
new file mode 100644
index 0000000..f7cc7e5
--- /dev/null
+++ b/slik/src/dials.cl
@@ -0,0 +1,241 @@
+;;;
+;;; dials
+;;;
+;;; A dial is a widget for setting/adjusting an angular value
+;;;
+;;; 07-Apr-1992 I. Kalet written
+;;; 14-Apr-1992 I. Kalet clean up and add X event processing
+;;; 01-May-1992 I. Kalet take out optional force-output-p in draw-pointer
+;;; 06-May-1992 I. Kalet don't export radius - can't be changed
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 27-May-1992 I. Kalet fix up type declarations
+;;; 6-Jul-1992 I. Kalet change be: to ev: and behavior to event
+;;; 6-Oct-1992 I. Kalet change defsetf angle to defmethod (setf
+;;; angle)
+;;; 25-Oct-1992 I. Kalet change refresh and drawing - no more pixmap
+;;; 29-Dec-1992 I. Kalet change angle attribute to degrees, not
+;;; radians
+;;; 22-Mar-1993 I. Kalet delete type declaration of variable index -
+;;; no such variable exists.
+;;; 3-Jan-1995 I. Kalet remove proclaim form and a few style changes
+;;; 3-Sep-1995 I. Kalet enforce range of 0 to 360 and single-float
+;;; 3-Apr-1999 C. Wilcox enabled event look-ahead for :motion-notify
+;;; 23-Apr-1999 I. Kalet changes for multiple colormaps.
+;;;
+
+(in-package :slik)
+
+(defconstant *rad-to-deg* (coerce (/ 180.0 pi) 'single-float))
+(defconstant *deg-to-rad* (coerce (/ pi 180.0) 'single-float))
+(defconstant *pi-over-2* (coerce (/ pi 2.0) 'single-float))
+(defconstant *two-pi* (coerce (* 2.0 pi) 'single-float))
+(defconstant *5-pi-over-2* (coerce (* 5.0 *pi-over-2*) 'single-float))
+
+;;;----------------------------------------
+
+(defclass dial (frame)
+
+ ((angle :type single-float
+ :reader angle ;; setf method provided below
+ :initarg :angle
+ :documentation "The pointer angle in degrees")
+
+ (radius :type clx:card16
+ :reader radius
+ :initarg :radius
+ :documentation "The radius of the dial circle in pixels")
+
+ (pointer :type vector
+ :accessor pointer
+ :initform (make-sequence '(vector clx:card16)
+ 12 :initial-element 0)
+ :documentation "The polygon describing the pointer, in pixel
+coords.")
+
+ (button-down :accessor button-down
+ :initform nil
+ :documentation "True if a mouse button is down while
+the window pointer is inside the dial window.")
+
+ (value-changed :type ev:event
+ :accessor value-changed
+ :initform (ev:make-event)
+ :documentation "Other objects interested in being
+notified when the dial's value has changed should call add-notify
+for this event.")
+
+ )
+
+ (:default-initargs :title "SLIK dial" :angle 0.0 :radius 50
+ :width 120 :height 120)
+
+ (:documentation "A dial as currently configured is meant to display
+and manipulate angular values. angle is the angle the needle should
+point in. Actual value is straight up for 0.0, increasing clockwise,
+but the computations are done in the standard mathematical coordinate
+system, with zero degrees pointing to the right, and increasing
+counter-clockwise.")
+ )
+
+;;;---------------------------------------------
+
+(defun dial-erase-pointer (d)
+
+ "dial-erase-pointer d
+
+Erase dial pointer from window."
+
+ (clx:draw-lines (window d)
+ (color-gc (bg-color d) (colormap d))
+ (pointer d)
+ :relative-p nil :fill-p t :shape :convex))
+
+;;;---------------------------------------------
+
+(defun dial-draw-pointer (d)
+
+ "dial-draw-pointer d
+
+Computes new pointer polygon, draws it in window."
+
+ (let* (;; convert angle to radians first
+ (angle (- *pi-over-2* (* *deg-to-rad* (angle d))))
+ (r (float (radius d)))
+ (wp (+ (/ r 30.0) 2.0)) ;; pointer half-width
+ (sin-a (sin angle))
+ (cos-a (cos angle))
+ (base-x (round (* wp sin-a)))
+ (base-y (round (* wp cos-a)))
+ (xlen (round (* (- r 2.0) cos-a)))
+ (ylen (round (* (- r 2.0) sin-a)))
+ (center (/ (width d) 2))
+ (point-x (+ xlen center))
+ (point-y (- center ylen))
+ (shaft-top-x (+ center (round (* 0.80 xlen))))
+ (shaft-top-y (- center (round (* 0.80 ylen))))
+ (pointer-vector (pointer d)))
+ (declare
+ (type single-float angle wp sin-a cos-a r)
+ (type clx:card16 center base-x base-y xlen ylen point-x point-y
+ shaft-top-x shaft-top-y)
+ (type array pointer-vector))
+ (setf
+ ;; shaft base left
+ (aref pointer-vector 0) (- center base-x)
+ (aref pointer-vector 1) (- center base-y)
+ ;; shaft top left
+ (aref pointer-vector 2) (- shaft-top-x base-x)
+ (aref pointer-vector 3) (- shaft-top-y base-y)
+ ;; arrow tip
+ (aref pointer-vector 4) point-x
+ (aref pointer-vector 5) point-y
+ ;; shaft top right
+ (aref pointer-vector 6) (+ shaft-top-x base-x)
+ (aref pointer-vector 7) (+ shaft-top-y base-y)
+ ;; shaft base right
+ (aref pointer-vector 8) (+ center base-x)
+ (aref pointer-vector 9) (+ center base-y)
+ ;; shaft base left - again
+ (aref pointer-vector 10) (aref pointer-vector 0)
+ (aref pointer-vector 11) (aref pointer-vector 1))
+ ;; draw arrow
+ (clx:draw-lines (window d)
+ (color-gc (fg-color d) (colormap d))
+ (pointer d)
+ :relative-p nil :fill-p t :shape :convex)
+ (flush-output)))
+
+;;;---------------------------------------
+
+(defmethod refresh :before ((d dial))
+
+ "Fills in the circle and the pointer."
+
+ (let ((w (width d)))
+ (clx:draw-arc (window d)
+ (color-gc (border-color d) (colormap d))
+ 0 0 w w 0.0 *two-pi*)
+ (dial-draw-pointer d)))
+
+;;;---------------------------------------
+
+(defun make-dial (radius &rest other-initargs)
+
+ "make-dial radius &rest other-initargs
+
+Makes a dial with the specified radius and other parameters, or
+default values."
+
+ (let* ((w (* 2 (+ radius 5)))
+ (d (apply 'make-instance 'dial :radius radius
+ :width w :height w ;; dials are square
+ other-initargs))) ;; supplied width and height are ignored
+ (push :motion-notify (look-ahead d))
+ (refresh d)
+ d))
+
+;;;---------------------------------------
+
+(defmethod (setf angle) (new-angle (d dial))
+
+ "This is always used by outsiders or X event handlers to set a new
+angle value. New-angle is in degrees."
+
+ (setq new-angle (mod (coerce new-angle 'single-float) 360.0))
+ (setf (slot-value d 'angle) new-angle)
+ (dial-erase-pointer d) ;; uses cached polygon
+ (dial-draw-pointer d)
+ (ev:announce d (value-changed d) new-angle)
+ new-angle)
+
+;;;---------------------------------------
+
+(defun dial-pointer-angle (d x y)
+
+ "dial-pointer-angle d x y
+
+Computes the angle in radians corresponding to the endpoint x,y and
+the dial center, then converts to degrees and returns that."
+
+ (let* ((c (/ (width d) 2))
+ (dx (- x c))
+ (dy (- y c))
+ (len (sqrt (+ (* dx dx) (* dy dy)))))
+ (* *rad-to-deg*
+ (if (zerop len) 0.0
+ (let ((raw (coerce (acos (/ (float dx) len)) 'single-float)))
+ (if (<= dy 0)
+ (if (<= dx 0)
+ (- *5-pi-over-2* raw)
+ (- *pi-over-2* raw))
+ (+ *pi-over-2* raw)))))))
+
+;;;---------------------------------------
+
+(defmethod process-motion-notify ((d dial) x y state)
+
+ (declare (ignore state))
+ (when (button-down d)
+ (setf (angle d) (dial-pointer-angle d x y)))
+ nil)
+
+;;;---------------------------------------
+
+(defmethod process-button-press ((d dial) code x y)
+
+ (when (= code 1) ;; left button
+ (setf (button-down d) t)
+ (setf (angle d) (dial-pointer-angle d x y)))
+ nil)
+
+;;;---------------------------------------
+
+(defmethod process-button-release ((d dial) code x y)
+
+ (declare (ignore x y))
+ (when (= code 1) ;; left button
+ (setf (button-down d) nil))
+ nil)
+
+;;;----------------------------------------
+;;; End.
diff --git a/slik/src/event-loop.cl b/slik/src/event-loop.cl
new file mode 100644
index 0000000..bb21fa1
--- /dev/null
+++ b/slik/src/event-loop.cl
@@ -0,0 +1,323 @@
+;;;
+;;; event-loop
+;;;
+;;; This module contains the functions and variables for the main
+;;; event loop for an application that uses the SLIK toolkit.
+;;;
+;;; 13-Jan-1992 I. Kalet started from Mark Niehaus' controls module
+;;; 05-Apr-1992 I. Kalet change process-x-event to specific event type
+;;; 13-Apr-1992 I. Kalet add default methods for event processing
+;;; generic functions
+;;; 19-May-1992 I. Kalet add terminate function
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 22-Jun-1992 I. Kalet reorder so can compile without loading first
+;;; 27-Oct-1992 I. Kalet add recursive event loop capapility by
+;;; providing a window table stack and push and pop functions.
+;;; 02-Mar-1993 J. Unger comment out part of make-hash-table calls. CMU
+;;; lisp seems to barf on this.
+;;; 3-Jan-1995 I. Kalet take out proclaim form, increase size of
+;;; window table, but keep terminate function here.
+;;; 1-Apr-1999 C. Wilcox add support for background events,
+;;; event look-ahead, and active exposure handling.
+;;; 15-Jun-2000 I. Kalet cosmetic changes.
+;;; 27-Aug-2003 I. Kalet add processing for :client-message X events,
+;;; so that window manager destroy can be intercepted.
+;;;
+
+(in-package :slik)
+
+;;;----------------------------------------------------------------
+
+(defvar *window-table* (make-hash-table :test #'eq :size 1024)
+ "The global variable relating objects to their windows")
+
+(defvar *window-table-stack* nil
+ "The window table stack for creating multiple levels of event
+processing.")
+
+(defvar *current-event-level* 0
+ "This is the slik global variable to define the current event
+level. A level of 0 implies no event processing. We want to
+ensure the constraint that the *current-event-level* is equal to
+the recursion depth of process-events.")
+
+(defvar *background-event-queue* nil
+ "This is a FIFO queue for background events.")
+
+(defvar *active-exposure-enabled* t
+ "When this is true, windows accept exposure events regardless
+of whether they are in the *window-table* or buried within the
+*window-table-stack*")
+
+;;;----------------------------------------------------------------
+;;; Provide default methods for all the generic functions called in
+;;; the event loop below. They just return nil to continue event
+;;; processing.
+;;;----------------------------------------------------------------
+
+(defmethod process-enter-notify ((obj t) x y state)
+
+ (declare (ignore x y state))
+
+ nil)
+
+(defmethod process-leave-notify ((obj t) x y state)
+
+ (declare (ignore x y state))
+
+ nil)
+
+(defmethod process-exposure ((obj t) x y width height count)
+
+ (declare (ignore x y width height count))
+
+ nil)
+
+(defmethod process-button-press ((obj t) code x y)
+
+ (declare (ignore code x y))
+
+ nil)
+
+(defmethod process-button-release ((obj t) code x y)
+
+ (declare (ignore code x y))
+
+ nil)
+
+(defmethod process-motion-notify ((obj t) x y state)
+
+ (declare (ignore x y state))
+
+ nil)
+
+(defmethod process-key-press ((obj t) code state)
+
+ (declare (ignore code state))
+
+ nil)
+
+(defmethod process-client-message ((obj t) type format data)
+
+ (declare (ignore type format data))
+
+ nil)
+
+;;;---------------------------------------------------
+;;; background event support
+;;;---------------------------------------------------
+
+(defun enqueue-bg-event (event)
+
+ "enqueue-bg-event event
+
+adds event to the background processing queue."
+
+ (setf *background-event-queue*
+ (append *background-event-queue* (list event)))
+ nil)
+
+(defun dequeue-bg-event (compare-func)
+
+ "dequeue-bg-event compare-func
+
+removes event from the background processing queue."
+
+ (setf *background-event-queue*
+ (remove-if compare-func *background-event-queue*))
+ nil)
+
+;;;---------------------------------------------------
+
+(defun process-events ()
+
+ "process-events
+
+Handles X events, notifying windows when need be."
+
+ (incf *current-event-level* 1)
+ (let ((my-event-level *current-event-level*))
+ (loop until (< *current-event-level* my-event-level)
+ do
+ (if (not (clx:event-listen *display*))
+ (if *background-event-queue*
+ (let ((ev (pop *background-event-queue*)))
+ (eval ev))
+ ;; this will block until a new event arrives
+ (handle-event-case))
+ (progn (look-ahead-handler)
+ (handle-event-case))))))
+
+;;;---------------------------------------------------
+;;; look-ahead-handler will check peek at the event queue to
+;;; see if look-ahead is enabled for the top event and discard
+;;; all consecutive occurences of the same event except for
+;;; the last one
+;;;---------------------------------------------------
+
+(defun look-ahead-handler ()
+
+ (let ((num-discard 0))
+ (clx:process-event *display* :discard-p nil :peek-p t :timeout 0
+ :handler
+ #'(lambda (&rest args &key event-key window
+ &allow-other-keys)
+ (let ((win (gethash window *window-table*))
+ (queue-length (clx:event-listen *display*)))
+ ;; check to see if win is nil before
+ ;; calling look-ahead
+ (when (and queue-length win
+ (find event-key (look-ahead win)))
+ (setf num-discard
+ (look-ahead-helper 0 event-key window))
+ ))
+ t))
+
+ ;; this loop will throw away num-discard events
+ ;; from the event queue
+ (dotimes (i num-discard)
+ (clx:process-event *display* :discard-p nil :peek-p nil :timeout 0
+ :handler #'(lambda (&rest args) t)))))
+
+;;;---------------------------------------------------
+;;; look-ahead-helper returns the number of consecutive
+;;; occurrences of events on the event queue which have an event
+;;; type equal to event-symbol and a window id equal to window-id
+;;;---------------------------------------------------
+
+(defun look-ahead-helper (iter event-symbol window-id)
+
+ (clx:process-event
+ *display* :discard-p nil :peek-p t :timeout 0
+ :handler
+ #'(lambda (&rest args &key event-key window &allow-other-keys)
+ (if (and (clx:event-listen *display*)
+ (eq event-symbol event-key)
+ (eq window-id window))
+ (look-ahead-helper (+ iter 1) event-key window)
+ iter))))
+
+;;;-------------------------------------
+;;; This function does the actual dispatching of events to be executed.
+;;; If there are no events on the event queue, it will block and wait
+;;; for a new event to arrive
+
+(defun handle-event-case ()
+
+ (clx:event-case (*display* :discard-p nil :force-output-p nil)
+ (:enter-notify (event-window x y state)
+ (process-enter-notify
+ (gethash event-window *window-table*)
+ x y state) t)
+ (:leave-notify (event-window x y state)
+ (process-leave-notify
+ (gethash event-window *window-table*)
+ x y state) t)
+ (:exposure (event-window x y width height count)
+ (let ((win (gethash event-window *window-table*)))
+ (when (and *active-exposure-enabled*
+ *window-table-stack* (not win))
+ (dolist (win-table *window-table-stack*)
+ (if (not win)
+ (setf win (gethash event-window
+ win-table)))))
+ (process-exposure win x y
+ width height count) t))
+ (:button-press (event-window code x y)
+ (process-button-press
+ (gethash event-window *window-table*)
+ code x y) t)
+ (:button-release (event-window code x y)
+ (process-button-release
+ (gethash event-window *window-table*)
+ code x y) t)
+ (:motion-notify (event-window x y state)
+ (process-motion-notify
+ (gethash event-window *window-table*)
+ x y state) t)
+ (:key-press (event-window code state)
+ (process-key-press
+ (gethash event-window *window-table*)
+ code state) t)
+ (:client-message (event-window type format data)
+ (process-client-message
+ (gethash event-window *window-table*)
+ type format data) t)
+ (otherwise () t))) ; just keep processing
+
+;;;-------------------------------------
+
+(defclass object ()
+
+ ((window :type clx:window
+ :accessor window))
+
+ (:documentation "A stub class that defines an accessor function
+named window.") ;; could also accomplish this with defgeneric
+
+ )
+
+;;;-------------------------------------
+
+(defun register (obj)
+
+ "register obj
+
+Adds the object obj to the table of known objects and associated
+windows, so that its process-event method will be called when an X
+event occurs in its window. The object must have a CLX window
+accessible by a call to an accessor function named window."
+
+ (unless (gethash (window obj) *window-table*)
+ (setf (gethash (window obj) *window-table*) obj)))
+
+;;;-------------------------------------
+
+(defun unregister (obj)
+
+ "unregister obj
+
+Removes obj from the table of known objects associated with X events."
+
+ (remhash (window obj) *window-table*))
+
+;;;-------------------------------------
+
+(defun terminate ()
+
+ "terminate
+
+closes the connection to the display opened by initialize and resets
+internal data structures in the SLIK package."
+
+ (clx:close-display *display*)
+ (clrhash *window-table*)
+ "SLIK display connection closed.")
+
+;;;-------------------------------------
+
+(defun push-event-level ()
+
+ "push-event-level
+
+puts the current window table on the stack and creates a new one for
+an inner event processing loop."
+
+ (push *window-table* *window-table-stack*)
+ (setq *window-table* (make-hash-table :test #'eq :size 256)))
+
+;;;-------------------------------------
+
+(defun pop-event-level ()
+
+ "pop-event-level
+
+disposes of the current window table and restores the last one from
+the top of the stack."
+
+ (clrhash *window-table*)
+ (setq *window-table* (pop *window-table-stack*))
+ nil)
+
+;;;-------------------------------------
+;;; End.
diff --git a/slik/src/events.cl b/slik/src/events.cl
new file mode 100644
index 0000000..d6e6a34
--- /dev/null
+++ b/slik/src/events.cl
@@ -0,0 +1,71 @@
+;;;
+;;; events
+;;;
+;;; A very stripped down bare minimum implementation of events, like
+;;; John MacDonald's announcements but much simpler, no global entities.
+;;;
+;;; 14-Apr-1992 I, Kalet written
+;;; 24-Jun-1992 I. Kalet move defpackage etc. to config file
+;;; 03-Jan-1993 I. Kalet modify add-notify so it does replace the
+;;; action function instead of just ignoring the input if an entry is
+;;; already present for a party.
+;;; 17-Sep-1993 I. Kalet fix error in add-notify - test with party,
+;;; not list of party and action
+;;; 3-Jan-1995 I. Kalet move defpackage etc. here from config so this
+;;; file is standalone but can also be a module in a system.
+;;; 1-Feb-1996 I. Kalet drop make-package, assume defpackage.
+;;; 06-Jun-1997 BobGian redefine ADD-NOTIFY: ADJOIN -> CONS.
+;;;
+;;;----------------------------------------------------------
+
+(defpackage "EVENTS" (:nicknames "EV") (:use "COMMON-LISP")
+ (:export "EVENT" "MAKE-EVENT" "ANNOUNCE" "ADD-NOTIFY"
+ "REMOVE-NOTIFY"))
+
+;;;----------------------------------------------------------
+
+(in-package :events)
+
+;;;----------------------------------------------------------
+
+(deftype event () 'list) ; an event is a simple a-list
+
+(defun make-event () nil) ; initially empty
+
+;;;---------------------------------------------------
+
+(defmacro add-notify (party event action)
+
+ "ADD-NOTIFY party event action
+
+Adds the party, action pair to the specified event, which should be
+a place designation suitable for setf."
+
+ `(setf ,event (cons (list ,party ,action)
+ (remove ,party ,event :test #'eq :key #'car))))
+
+;;;---------------------------------------------------
+
+(defmacro remove-notify (party event)
+
+ "REMOVE-NOTIFY party event
+
+removes the entry for party in event."
+
+ `(setf ,event (remove ,party ,event :test #'eq :key #'car)))
+
+;;;---------------------------------------------------
+
+(defun announce (object event &rest args)
+
+ "ANNOUNCE object event &rest args
+
+announces the event, i.e., applies the action part of each entry to
+the party part of each entry, with object and args as additional
+arguments."
+
+ (dolist (entry event) ; event is an a-list
+ (apply (second entry) (first entry) object args)))
+
+;;;---------------------------------------------------
+;;; End.
diff --git a/slik/src/frames.cl b/slik/src/frames.cl
new file mode 100644
index 0000000..68d7f0b
--- /dev/null
+++ b/slik/src/frames.cl
@@ -0,0 +1,344 @@
+;;;
+;;; frames
+;;;
+;;; This file describes the basic SLIK class, the frame
+;;;
+;;; 05-Apr-1992 I. Kalet started
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 27-May-1992 I. Kalet add mapped keyword parameter to make-frame
+;;; 29-May-1992 I. Kalet set default font initarg here
+;;; 8-Oct-1992 I. Kalet change defsetf to defmethod (setf ...
+;;; 27-Oct-1992 I. Kalet enhance erase function, fix draw-border,
+;;; remove pixmap attribute - only in pictures, fix refresh fn.
+;;; 29-Nov-1992 I. Kalet put exposure event here not just in picture,
+;;; and announce it as well as calling refresh. Also delete ulc-x and
+;;; ulc-y slots, since they are not needed.
+;;; 15-Feb-1993 I. Kalet change fg-color and bg-color to have
+;;; accessors, not just readers. Add setf after methods that call
+;;; refresh.
+;;; 3-Jan-1995 I. Kalet fix up some setf methods
+;;; 18-Feb-1996 I. Kalet use new global *screen-root-depth* instead of
+;;; querying every time.
+;;; 4-May-1997 I. Kalet fix error of omission in (setf bg-color)
+;;; method - need to update the clx window, not just set the attribute.
+;;; 1-Apr-1999 C. Wilcox added look-ahead slot.
+;;; 22-Apr-1999 I. Kalet add support for each frame to have its own
+;;; visual and/or colormap instead of the inherited ones.
+;;; 28-May-2000 I. Kalet add support for shaded 3-d borders.
+;;; 26-Nov-2000 I. Kalet change default border-style to :raised and
+;;; default background color to gray. Changes the overall look and
+;;; feel of user interfaces by default.
+;;; 11-Mar-2001 I. Kalet make default foreground and background colors
+;;; and default border style initializable parameters instead of hardcoded.
+;;; 2-Feb-2003 I. Kalet use :around methods for setf fg-color etc. to
+;;; insure that the stuff that has to be done last is done last.
+;;; 27-Aug-2003 I. Kalet when creating a window for a frame, add
+;;; WM_DELETE_WINDOW to the WM_PROTOCOLS property for the window, so
+;;; that a window manager destroy operation can be intercepted. By
+;;; default, the destroy operation is ignored.
+;;; 19-Mar-2007 I. Kalet change initialize-instance method to insure
+;;; that the default visual parameter is a card29, not the keyword :copy.
+;;;
+
+(in-package :slik)
+
+;;;-------------------------------------------
+
+(defclass frame ()
+
+ ((title :type string
+ :accessor title
+ :initarg :title)
+
+ (width :type clx:card16
+ :reader width
+ :initarg :width)
+
+ (height :type clx:card16
+ :reader height
+ :initarg :height)
+
+ (bg-color :type symbol
+ :accessor bg-color
+ :initarg :bg-color
+ :documentation "A symbol in the SLIK package naming a color")
+
+ (fg-color :type symbol
+ :accessor fg-color
+ :initarg :fg-color
+ :documentation "A symbol in the SLIK package naming a color")
+
+ (font :type clx:font
+ :accessor font
+ :initarg :font)
+
+ (border-width :type clx:card8
+ :accessor border-width
+ :initarg :border-width)
+
+ (border-color :type symbol
+ :accessor border-color
+ :initarg :border-color
+ :documentation "A symbol in the SLIK package naming a
+color")
+
+ (border-style :accessor border-style
+ :initarg :border-style
+ :documentation "Border-style is a keyword, :flat for
+the original widget border style, :raised for a sort of raised button
+look, or :lowered for an indented look.")
+
+ (border-gc :accessor border-gc
+ :initform (make-duplicate-gc)
+ :documentation "Set for border width and color
+initially, much faster than using the clx:with-gcontext macro on a
+standard gcontext.")
+
+ (window :type clx:window
+ :accessor window)
+
+ (colormap :type clx:colormap
+ :accessor colormap
+ :initarg :colormap
+ :documentation "The colormap associated with the window
+of the frame. It is usually just a copy of the parent's.")
+
+ (exposure :type ev:event
+ :accessor exposure
+ :initform (ev:make-event)
+ :documentation "Announced when a part of the frame window
+is exposed.")
+
+ (wm-close :type ev:event
+ :accessor wm-close
+ :initform (ev:make-event)
+ :documentation "Announced when the window manager
+ attempts to close a window, usually because the user
+ clicked on the window manager provided close-window icon.")
+
+ (look-ahead :accessor look-ahead
+ :initarg :look-ahead
+ :documentation "When this slot's value is not nil, the
+event handler will look ahead in the event queue to remove duplicate
+events of the specified types.")
+
+ )
+
+ (:default-initargs :title "SLIK frame" :bg-color 'default-bg
+ :fg-color 'default-fg :border-width 1
+ :border-color 'white :font *default-font*
+ :colormap nil :look-ahead nil
+ :border-style *default-border-style*)
+
+ (:documentation "The basic SLIK entity which includes all the CLX
+stuff and of which all other SLIK classes are subclasses.")
+
+ )
+
+;;;----------------------------------------
+
+(defun erase (f)
+
+ "erase f
+
+erases the contents of frame f by setting the entire window of the
+frame to the background color."
+
+ (clx:clear-area (window f))
+ (flush-output))
+
+;;;----------------------------------------
+
+(defun draw-border (f)
+
+ "draw-border f
+
+Draws the border of frame f in border-color, border-width wide. If
+border-width is 0, skip it."
+
+ (when (> (border-width f) 0)
+ (case (border-style f)
+ (:flat (let ((b2 (truncate (/ (border-width f) 2))))
+ (clx:draw-rectangle (window f) (border-gc f)
+ b2 b2
+ (- (width f) (1+ b2))
+ (- (height f) (1+ b2)))))
+ (:raised (clx:draw-lines (window f) (border-gc f)
+ (list 0 (height f) 0 0 (width f) 0))
+ (clx:draw-lines (window f) (color-gc 'black2 (colormap f))
+ (list (- (width f) 1) 0
+ (- (width f) 1) (- (height f) 1)
+ 0 (- (height f) 1))))
+ (:lowered (clx:draw-lines (window f) (color-gc 'black2 (colormap f))
+ (list 1 (height f) 1 1 (width f) 1))
+ (clx:draw-lines (window f) (border-gc f)
+ (list (- (width f) 1) 0
+ (- (width f) 1) (- (height f) 1)
+ 0 (- (height f) 1)))))))
+
+;;;---------------------------------------
+
+(defmethod initialize-instance :after ((f frame)
+ &key parent (mapped t)
+ (ulc-x 0) (ulc-y 0)
+ visual
+ &allow-other-keys)
+
+ "Method for creating the CLX window and pixmap for any SLIK object."
+
+ (unless (colormap f)
+ (setf (colormap f) (clx:window-colormap (or parent *screen-root*))))
+ (setf (window f)
+ (clx:create-window :parent (or parent *screen-root*)
+ :x ulc-x :y ulc-y
+ :width (width f) :height (height f)
+ :depth *screen-root-depth*
+ :visual (or visual
+ (clx:window-visual (or parent
+ *screen-root*)))
+ :colormap (colormap f)
+ :background (clx:gcontext-foreground
+ (color-gc (bg-color f)
+ (colormap f)))
+ :event-mask
+ '(:key-press :button-press :button-release
+ :button-motion :enter-window :leave-window
+ :exposure)
+ ))
+ (setf (clx:wm-protocols (window f))
+ (cons 'WM_DELETE_WINDOW (clx:wm-protocols (window f))))
+ (clx:copy-gcontext (color-gc (border-color f) (colormap f))
+ (border-gc f))
+ (setf (clx:gcontext-line-width (border-gc f)) (border-width f))
+ (setf (clx:wm-name (window f)) (title f))
+ (erase f) ; erase everything initially
+ (draw-border f)
+ (if mapped (clx:map-window (window f)))
+ (flush-output)
+ (register f)
+ f)
+
+;;;---------------------------------------
+
+(defun make-frame (width height &rest other-initargs)
+
+ "make-frame width height &rest other-initargs
+
+Returns a new instance of class frame. Width and height are required.
+The rest of the argument list specifies the initial values for the
+attributes of a frame. If parent is nil, the frame's window is a top
+level window. Otherwise, parent is a CLX window that should be the
+parent of the new frame's window."
+
+ (apply 'make-instance 'frame
+ :width width :height height other-initargs))
+
+;;;---------------------------------------
+
+(defmethod refresh :around ((f frame))
+
+ "refresh f
+
+Calls all the other applicable methods, then draws the border and
+flushes the output queue."
+
+ (call-next-method)
+ (draw-border f)
+ (flush-output))
+
+;;;---------------------------------------
+
+(defmethod refresh ((f frame))
+
+ "refresh f
+
+The primary method for a frame is just a stub."
+
+ nil)
+
+;;;---------------------------------------
+
+(defmethod destroy ((obj frame))
+
+ "destroy obj
+
+Does the CLX calls to unmap the object's window w and free storage
+used. Should do other stuff too."
+
+ (unregister obj)
+ (clx:destroy-window (window obj))
+ (flush-output)
+ (clx:free-gcontext (border-gc obj)))
+
+;;;----------------------------------------
+
+(defmethod (setf title) :before (new-title (f frame))
+
+ "The update function for the title attribute sets the window title
+also."
+
+ (setf (clx:wm-name (window f)) new-title))
+
+;;;----------------------------------------
+
+(defmethod (setf bg-color) :around (new-color (f frame))
+
+ (call-next-method)
+ (setf (clx:window-background (window f))
+ (clx:gcontext-foreground (color-gc new-color (colormap f))))
+ (erase f)
+ (refresh f))
+
+;;;----------------------------------------
+
+(defmethod (setf fg-color) :around (new-color (f frame))
+
+ (declare (ignore new-color))
+ (call-next-method)
+ (refresh f))
+
+;;;----------------------------------------
+
+(defmethod (setf border-color) :around (new-color (f frame))
+
+ "Updates border-gc and redraws the border."
+
+ (call-next-method)
+ (clx:copy-gcontext (color-gc new-color (colormap f)) (border-gc f))
+ (setf (clx:gcontext-line-width (border-gc f)) (border-width f))
+ (draw-border f)
+ (flush-output))
+
+;;;----------------------------------------
+
+(defmethod (setf border-width) :around (new-width (f frame))
+
+ "Updates border-gc and redraws the border."
+
+ (call-next-method)
+ (setf (clx:gcontext-line-width (border-gc f)) new-width)
+ (erase f)
+ (refresh f))
+
+;;;----------------------------------------
+
+(defmethod process-exposure ((f frame) x y width height count)
+
+ "The usual method for handling exposure events for any frame is to
+call the refresh generic function, which calls flush-output too. The
+exposure event is also announced so application code can fill in
+picture data or labels or other."
+
+ (ev:announce f (exposure f) x y width height count)
+ (refresh f)
+ nil)
+
+;;;----------------------------------------
+
+(defmethod process-client-message ((f frame) type format data)
+
+ (ev:announce f (wm-close f) type format data)
+ nil)
+
+;;;----------------------------------------
+;;; End.
diff --git a/slik/src/images.cl b/slik/src/images.cl
new file mode 100644
index 0000000..738651b
--- /dev/null
+++ b/slik/src/images.cl
@@ -0,0 +1,242 @@
+;;;
+;;; images
+;;;
+;;; A collection of basic stuff for computing and displaying images.
+;;;
+;;; 03-May-1992 I. Kalet created
+;;; 24-May-1992 I. Kalet move exported symbols to slik-exports
+;;; 4-Nov-1992 I. Kalet change name of parameter in make-graymap
+;;; 26-Mar-1993 I. Kalet add :bits-per-pixel parameter to call to
+;;; clx:create-image in map-image-to-clx, for CMUCL compatibility.
+;;; 20-Jan-1994 I. Kalet try some optimizations.
+;;; 10-May-1994 I. Kalet prevent index out of range errors in
+;;; make-graymap when window may extend below 0 or above range-top,
+;;; also add image mapping functions for raw gray values.
+;;; 23-May-1994 J. Unger make efficiency enhancements to map-raw-image
+;;; and map-image-to-clx.
+;;; 3-Jan-1995 I. Kalet remove proclaim form and add optional
+;;; parameter to make-graymap and make-raw-graymap
+;;; 31-Jan-1996 I. Kalet take out VAXLISP hack.
+;;; 18-Feb-1996 I. Kalet in map-image-to-clx use new SLIK global
+;;; *image-bits-per-pixel* parameter for compatibility with DEC Alpha,
+;;; VAXstations, etc., also put-image to drawable rather than just
+;;; returning a clx:image data structure.
+;;; 20-Jan-1998 I. Kalet add some optimizations.
+;;; 25-Apr-1999 I. Kalet modify for multiple colormaps.
+;;; 11-Jul-2000 I. Kalet split map-image-to-clx to enable sharing code
+;;; with gl support.
+;;; 3-Sep-2000 I. Kalet can't use a cache of scratch arrays - they
+;;; are returned and put somewhere, so can't reuse them.
+;;;
+
+(in-package :slik)
+
+;;;---------------------------------------------------
+
+(defun make-graymap (window level range-top
+ &key old-map (gray-pixels *default-gray-pixels*))
+
+ "make-graymap window level range-top
+&key old-map (gray-pixels *default-gray-pixels*)
+
+Returns an array of pixel values, one for each possible image array
+value, corresponding to the standard linear gray map used to map CT
+image data to a gray scale displayed image. Level is the image value
+corresponding to the middle of the gray range and window is the width
+of the ramp. The range of gray values is determined by the size of
+the gray-pixels array, which contains the pixel values corresponding
+to each gray level from 0 to the maximum in use on the display.
+Range-top is the highest value that can appear in an image array,
+usually 4095. If old-map is provided, it is used instead of creating
+a new one."
+
+ (declare (type (unsigned-byte 16) window level range-top)
+ (type (simple-array clx:pixel 1) gray-pixels))
+ (let* ((result (or old-map (make-array (1+ range-top)
+ :element-type 'clx:pixel)))
+ (top-gray (1- (length gray-pixels)))
+ (low-ramp (- level (truncate (/ window 2))))
+ (bottom low-ramp) ;; since low-ramp may change
+ (high-ramp (+ low-ramp window))
+ (dark (aref gray-pixels 0)) ;; the black pixel
+ (light (aref gray-pixels top-gray))) ;; the white pixel
+ (declare (type (simple-array clx:pixel 1) result)
+ (type (unsigned-byte 16) top-gray low-ramp high-ramp)
+ (type clx:pixel dark light))
+ ;; the following prevents index out of range errors
+ (if (< low-ramp 0) (setq low-ramp 0))
+ (if (> high-ramp range-top) (setq high-ramp range-top))
+ (do ((i 0 (1+ i))) ((= i low-ramp))
+ (declare (fixnum i))
+ (setf (aref result i) dark))
+ (do ((i low-ramp (1+ i))) ((= i high-ramp))
+ (declare (fixnum i))
+ (setf (aref result i)
+ (aref gray-pixels ;; use bottom, not low-ramp
+ (the fixnum (round (/ (* top-gray (- i bottom))
+ window))))))
+ (do ((i high-ramp (1+ i))) ((> i range-top))
+ (declare (fixnum i))
+ (setf (aref result i) light))
+ result))
+
+;;;----------------------------
+
+(defun map-image (map image &optional result)
+
+ "map-image map image &optional result
+
+returns an array of pixels from image by composing image array with
+the gray map. The map must be an array specifying a pixel value to be
+output for each possible image data value. If the result array is
+provided it is reused, otherwise a new array is created."
+
+ (declare (type (simple-array clx:pixel 1) map)
+ (type (simple-array clx:pixel 2) result)
+ (type (simple-array (unsigned-byte 16) 2) image))
+ (let* ((x-dim (array-dimension image 1))
+ (y-dim (array-dimension image 0))
+ (temparray (or result
+ (case *image-bits-per-pixel*
+ (8 (make-array (list y-dim x-dim)
+ :element-type
+ '(unsigned-byte 8)))
+ (16 (make-array (list y-dim x-dim)
+ :element-type
+ '(unsigned-byte 16)))
+ (32 (make-array (list y-dim x-dim)
+ :element-type
+ '(unsigned-byte 32)))
+ ))))
+ (declare (type fixnum x-dim y-dim))
+ (dotimes (j y-dim)
+ (declare (type fixnum j))
+ (dotimes (i x-dim)
+ (declare (type fixnum i))
+ (setf (aref temparray j i) (aref map (aref image j i)))))
+ temparray))
+
+;;;----------------------------
+
+(defun write-image-clx (image drawable)
+
+ "write-image-clx image drawable
+
+Writes image array to drawable using clx functions. The image array
+should be an array of clx pixels."
+
+ (declare (type (simple-array clx:pixel 2) image))
+ (let ((x-dim (array-dimension image 1))
+ (y-dim (array-dimension image 0)))
+ (declare (type fixnum x-dim y-dim))
+ (clx:put-image drawable (color-gc 'sl:white)
+ (clx:create-image :width x-dim :height y-dim
+ :depth (clx:drawable-depth drawable)
+ :bits-per-pixel *image-bits-per-pixel*
+ :data image
+ :format :z-pixmap)
+ :x 0 :y 0)))
+
+;;;---------------------------------------------------
+
+(defun make-raw-graymap (window level range-top
+ &key old-map (num-pixels *num-gray-pixels*))
+
+ "make-raw-graymap num-pixels window level range-top
+ &key old-map (num-pixels *num-gray-pixels*)
+
+Returns an array of byte values, one for each possible image array
+value, corresponding to the standard linear gray map used to map CT
+image data to a gray scale displayed image. Level is the image value
+corresponding to the middle of the gray range and window is the width
+of the ramp. The range of gray values is determined by num-pixels,
+and the values returned are just numbers in the range from 0 for black
+to num-pixels minus 1, for white. Range-top is the highest value that
+can appear in an image array, usually 4095. If old-map is provided it
+is used instead of creating a new one."
+
+ (let* ((result (or old-map
+ (make-array (1+ range-top)
+ :element-type '(unsigned-byte 8))))
+ (top-gray (1- num-pixels))
+ (low-ramp (- level (truncate (/ window 2))))
+ (bottom low-ramp) ;; since low-ramp may change
+ (high-ramp (+ low-ramp window)))
+ (declare (type (simple-array (unsigned-byte 8) 1) result)
+ (type (unsigned-byte 16)
+ window level range-top top-gray low-ramp high-ramp))
+ ;; the following prevents index out of range errors
+ (if (< low-ramp 0) (setq low-ramp 0))
+ (if (> high-ramp range-top) (setq high-ramp range-top))
+ (do ((i 0 (1+ i))) ((= i low-ramp))
+ (declare (fixnum i))
+ (setf (aref result i) 0)) ;; black
+ (do ((i low-ramp (1+ i))) ((= i high-ramp))
+ (declare (fixnum i))
+ (setf (aref result i) ;; use bottom, not low-ramp
+ (the (unsigned-byte 8)
+ (round (/ (* top-gray (- i bottom)) window)))))
+ (do ((i high-ramp (1+ i))) ((> i range-top))
+ (declare (fixnum i))
+ (setf (aref result i) top-gray))
+ result))
+
+;;;-----------------------------------
+
+(defun map-raw-image (raw-image window level range &optional old-array)
+
+ "map-raw-image raw-image window level range &optional old-array
+
+returns an array of bytes the same dimensions as raw-image, but with
+the values in raw-image converted to gray scale values in the range 0
+to *num-gray-levels* according to the linear ramp determined by window
+and level, the width and center of the ramp. Range is the highest
+value that can occur in the raw-image. If old-array is provided it
+must be the same dimensions as raw-image, and it is recycled instead
+of allocating a new array."
+
+ (declare (fixnum window level range)
+ (type (simple-array (unsigned-byte 8) 2) old-array)
+ (type (simple-array (unsigned-byte 16) 2) raw-image))
+ (let* ((x-dim (array-dimension raw-image 1))
+ (y-dim (array-dimension raw-image 0))
+ (temparray (or old-array
+ (make-array (list y-dim x-dim)
+ :element-type '(unsigned-byte 8))))
+ (map (make-raw-graymap window level range)))
+ (declare (type fixnum x-dim y-dim))
+ (declare (type (simple-array (unsigned-byte 8) 2) temparray))
+ (declare (type (simple-array (unsigned-byte 8)) map))
+ (dotimes (j y-dim)
+ (declare (fixnum j))
+ (dotimes (i x-dim)
+ (declare (fixnum i))
+ (setf (aref temparray j i) (aref map (aref raw-image j i)))))
+ temparray))
+
+;;;-----------------------------------
+
+(defun get-z-array (vox z0 zsize z)
+
+ "get-z-array vox z0 zsize z
+
+extracts and returns a 2-d array from the vox 3-d array, at the
+specified z, given the z origin and overall size in the z direction."
+
+ (declare (type (simple-array (unsigned-byte 16) 3) vox))
+ (let* ((x-dim (array-dimension vox 2))
+ (y-dim (array-dimension vox 1))
+ (nz (1- (array-dimension vox 0)))
+ (index (round (* nz (/ (- z z0) zsize))))
+ (pix (make-array (list y-dim x-dim)
+ :element-type '(unsigned-byte 16))))
+ (declare (type (simple-array (unsigned-byte 16) 2) pix)
+ (type fixnum x-dim y-dim index)
+ (type single-float z z0 zsize))
+ (dotimes (j y-dim)
+ (dotimes (i x-dim)
+ (setf (aref pix j i) (aref vox index j i))))
+ pix))
+
+;;;---------------------------------
+;;; End.
diff --git a/slik/src/initialize.cl b/slik/src/initialize.cl
new file mode 100644
index 0000000..ec0b0d3
--- /dev/null
+++ b/slik/src/initialize.cl
@@ -0,0 +1,386 @@
+;;;
+;;; initialize - contains the SLIK initialize function and its
+;;;associated details. In a separate file to avoid circular
+;;;dependencies with OpenGL support (initialize calls load-gl).
+;;;
+;;; 5-Aug-2004 I. Kalet split off from clx-support. Note that
+;;; initialize loads GL libraries but does not depend on any functions
+;;; in them. The library locations are now configurable variables
+;;; instead of constants.
+;;; 3-Jul-2006 I. Kalet change to new location of X libraries for
+;;; Debian and X.org
+;;; 4-Jan-2009 I. Kalet remove OpenGL library load, move out of SLIK
+;;; 16-Jul-2011 I. Kalet add run-time conditional in initialize for
+;;; Allegro CL, to use the Common Windows function
+;;; open-display-with-auth so can use non-zero display numbers.
+;;;
+
+(in-package :slik)
+
+;;;--------------------------------------------
+
+(defun open-named-fonts ()
+
+ (setq courier-bold-12
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*courier*bold-r*12-120*")))
+ courier-bold-14
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*courier*bold-r*14-140*")))
+ courier-bold-18
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*courier*bold-r*18-180*")))
+ times-bold-12
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*times*bold-r*12-120*")))
+ times-bold-14
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*times*bold-r*14-140*")))
+ times-bold-18
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*times*bold-r*18-180*")))
+ helvetica-medium-12
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*helvetica*medium-r*12-120*")))
+ helvetica-medium-14
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*helvetica*medium-r*14-140*")))
+ helvetica-medium-18
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*helvetica*medium-r*18-180*")))
+ helvetica-bold-12
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*helvetica*bold-r*12-120*")))
+ helvetica-bold-14
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*helvetica*bold-r*14-140*")))
+ helvetica-bold-18
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*helvetica*bold-r*18-180*")))
+ schoolbook-bold-12
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*schoolbook*bold-r*12-120*")))
+ schoolbook-bold-14
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*schoolbook*bold-r*14-140*")))
+ schoolbook-bold-18
+ (clx:open-font *display*
+ (first (clx:list-font-names
+ *display* "*schoolbook*bold-r*18-180*")))
+ )
+ (setq *default-font* (symbol-value *default-font-name*)))
+
+;;;--------------------------------------------
+
+(defun make-primary-gc (colormap)
+
+ "make-primary-gc colormap
+
+Creates the graphic contexts for the primary colors, to save
+performance on drawing in different colors."
+
+ (let ((tmp-black (clx:alloc-color
+ colormap
+ (clx:make-color :red 0.0 :green 0.0 :blue 0.0)))
+ (tmp-white (clx:alloc-color
+ colormap
+ (clx:make-color :red 1.0 :green 1.0 :blue 1.0))))
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 1.0 :green 0.0 :blue 0.0))
+ :background tmp-black))
+ red)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.0 :green 1.0 :blue 0.0))
+ :background tmp-black))
+ green)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.0 :green 0.0 :blue 1.0))
+ :background tmp-black))
+ blue)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 1.0 :green 0.0 :blue 1.0))
+ :background tmp-black))
+ magenta)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.0 :green 1.0 :blue 1.0))
+ :background tmp-black))
+ cyan)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 1.0 :green 1.0 :blue 0.0))
+ :background tmp-black))
+ yellow)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground tmp-white
+ :background tmp-black))
+ white)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground tmp-black
+ :background tmp-white))
+ black)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 2
+ :foreground tmp-black
+ :background tmp-white))
+ black2)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.5 :green 0.5 :blue 0.5))
+ :background tmp-black))
+ gray)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color :red *fg-level*
+ :green *fg-level*
+ :blue *fg-level*))
+ :background tmp-black))
+ default-fg)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color :red *bg-level*
+ :green *bg-level*
+ :blue *bg-level*))
+ :background tmp-black))
+ default-bg)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :font *default-font*
+ :function boole-2 ; signifies DST only, or NO-OP
+ :foreground tmp-white
+ :background tmp-black))
+ invisible)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 1.0 :green 0.0 :blue 0.0))
+ :background tmp-black))
+ red-dashed)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.0 :green 1.0 :blue 0.0))
+ :background tmp-black))
+ green-dashed)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.0 :green 0.0 :blue 1.0))
+ :background tmp-black))
+ blue-dashed)
+ (push (list colormap (clx:create-gcontext
+ :line-style :dash
+ :drawable *screen-root*
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 1.0 :green 0.0 :blue 1.0))
+ :background tmp-black))
+ magenta-dashed)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.0 :green 1.0 :blue 1.0))
+ :background tmp-black))
+ cyan-dashed)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 1.0 :green 1.0 :blue 0.0))
+ :background tmp-black))
+ yellow-dashed)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground tmp-white
+ :background tmp-black))
+ white-dashed)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground tmp-black
+ :background tmp-white))
+ black-dashed)
+ (push (list colormap (clx:create-gcontext
+ :drawable *screen-root*
+ :line-style :dash
+ :font *default-font*
+ :line-width 1
+ :foreground (clx:alloc-color
+ colormap
+ (clx:make-color
+ :red 0.5 :green 0.5 :blue 0.5))
+ :background tmp-black))
+ gray-dashed)))
+
+;;;--------------------------------------------
+
+(defun assign-gray-pixels (colormap num-pixels)
+
+ "assign-gray-pixels colormap num-pixels
+
+Requests num-pixels gray scale values from the colormap for shared use
+and assigns them to a color table, which is returned. This table is
+indexed from 0 through num-pixels - 1. Its entries are the pixel
+values in the colormap corresponding to the allocated gray scale
+values (which do not necessarily start at colormap entry 0 or are
+necessarily contiguous)."
+
+ (let ((val 0.0)
+ (inc (float (/ (1- num-pixels))))
+ (gray-pixels (make-array num-pixels :element-type 'clx:pixel)))
+ (declare (single-float val inc)
+ (fixnum num-pixels))
+ (dotimes (i num-pixels gray-pixels)
+ (setf (aref gray-pixels i)
+ (clx:alloc-color colormap
+ (clx:make-color :red val :green val :blue val)))
+ (incf val inc))))
+
+;;;--------------------------------------------
+
+(defun initialize (&optional (host *host*) (alloc-gray t))
+
+ "initialize &optional (host *host*) (alloc-gray t)
+
+Opens the display on specified host, sets the global variables for the
+toolkit (including *host*), allocates a bunch of gray levels in the
+screen default colormap unless disabled by providing a nil value for
+alloc-gray, and returns T if successful."
+
+ (let* ((colon-pos (position #\: host))
+ (hostname (subseq host 0 colon-pos))
+ (disp-no (if colon-pos
+ (let ((remainder (subseq host (1+ colon-pos))))
+ (read-from-string (subseq remainder 0
+ (position #\. remainder))))
+ 0)))
+ (if host (setq *host* hostname))
+ (if (setq *display*
+ #+allegro (cw::open-display-with-auth hostname disp-no)
+ #-allegro (clx:open-display hostname :display disp-no))
+ (progn (setq *screen* (clx:display-default-screen *display*))
+ (setq *screen-default-colormap*
+ (clx:screen-default-colormap *screen*))
+ (setq *screen-root* (clx:screen-root *screen*))
+ (setq *screen-root-depth* (clx:screen-root-depth
+ *screen*))
+ (setq *image-bits-per-pixel*
+ (clx:pixmap-format-bits-per-pixel
+ (find *screen-root-depth*
+ (clx:display-pixmap-formats *display*)
+ :key #'clx:pixmap-format-depth)))
+ (open-named-fonts)
+ (make-primary-gc *screen-default-colormap*)
+ (if alloc-gray
+ (setf *default-gray-pixels*
+ (assign-gray-pixels *screen-default-colormap*
+ *num-gray-pixels*)))
+ ;; event handling state initialization
+ (setf *current-event-level* 0)
+ (setf *background-event-queue* nil)
+ nil)
+ (format nil "Could not open display ~A on ~A~%" disp-no hostname))))
+
+;;;--------------------------------------------
+;;; End.
diff --git a/slik/src/menus.cl b/slik/src/menus.cl
new file mode 100644
index 0000000..2a3089d
--- /dev/null
+++ b/slik/src/menus.cl
@@ -0,0 +1,187 @@
+;;;
+;;; menus
+;;;
+;;; A simple menu class which provides a vertical menu from a list of
+;;; strings, announces selection or deselection, and provides the item
+;;; number. The programmer using this has to provide an action
+;;; function that knows what to do with the menu item number.
+;;;
+;;; 30-Apr-1992 I. Kalet created
+;;; 15-May-1992 I. Kalet add radio-menu
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 26-May-1992 I. Kalet make sure buttons have ulc-x set to 0
+;;; 2-Jul-1992 I. Kalet change be: to ev: and behavior to event
+;;; 6-Jul-1992 I. Kalet take out unnecessary sl: prefixes and
+;;; radio-menu-button-on function
+;;; 8-Oct-1992 I. Kalet add select-button and deselect-button methods
+;;; 28-Oct-1992 I. Kalet use parameter *linespace*
+;;; 3-Jan-1995 I. Kalet insure that you cannot deselect a button in a
+;;; radio menu.
+;;;
+
+(in-package :slik)
+
+;;;------------------------------------
+
+(defclass menu (frame)
+
+ ((items :type list
+ :accessor items
+ :initarg :items
+ :documentation "This is a list of strings that are the text
+items appearing on the menu.")
+
+ (selected :type ev:event
+ :accessor selected
+ :initform (ev:make-event)
+ :documentation "Announced when the user selects an item
+from the menu, by pressing the left mouse button when the pointer is
+over an item.")
+
+ (deselected :type ev:event
+ :accessor deselected
+ :initform (ev:make-event)
+ :documentation "Announced when the user deselects an item
+from the menu, which corresponds to the menu button being turned off,
+which in turn depends on the type of buttons that are created.")
+
+ (buttons :type list
+ :accessor buttons
+ :documentation "Each menu item is implemented by a button.
+We need to keep track of them in order to know which item is selected
+or deselected and to be able to destroy them when the menu is destroyed.")
+
+ )
+
+ (:default-initargs :title "SLIK menu" :items nil :buttons nil)
+
+ (:documentation "A menu is a vertical array of text items to choose
+from with the mouse left button.")
+
+ )
+
+;;;------------------------------------
+
+(defmethod initialize-instance :after ((m menu) &rest other-initargs
+ &key item-height
+ &allow-other-keys)
+
+ (let ((width (width m))
+ (ulc-y (- item-height)) ; so first one is at 0
+ )
+ (setf (buttons m)
+ (mapcar #'(lambda (item)
+ (apply 'make-button width item-height
+ :parent (window m)
+ :ulc-x 0
+ :ulc-y (setq ulc-y (+ ulc-y item-height))
+ :label item other-initargs))
+ (items m)))
+ ))
+
+;;;------------------------------------
+
+(defun make-menu (items &rest other-initargs &key font &allow-other-keys)
+
+ "MAKE-MENU items &rest other-initargs
+
+Returns a menu using each of the items as a menu text item."
+
+ (let* ((ft (or font *default-font*))
+ (max-item-width (apply 'max
+ (mapcar #'(lambda (item)
+ (clx:text-width ft item))
+ items)))
+ (item-height (+ (font-height ft) *linespace*))
+ (m (apply 'make-instance 'menu
+ :width (+ max-item-width 10)
+ :height (* (length items) item-height)
+ :items items
+ :item-height item-height
+ other-initargs))
+ )
+ (mapc #'(lambda (b)
+ (ev:add-notify m (button-on b) #'menu-button-on)
+ (ev:add-notify m (button-off b) #'menu-button-off))
+ (buttons m))
+ m))
+
+;;;------------------------------------
+
+(defun menu-button-on (m b)
+
+ "MENU-BUTTON-ON m b
+
+is the action function that each button in the menu calls when it is
+turned on. It in turn just announces SELECTED with the button number
+as a parameter."
+
+ (ev:announce m (selected m) (position b (buttons m)))
+ )
+
+;;;------------------------------------
+
+(defun menu-button-off (m b)
+
+ "MENU-BUTTON-OFF m b
+
+is the action function that each button in the menu calls when it is
+turned off. It in turn just announces DESELECTED with the button number
+as a parameter."
+
+ (ev:announce m (deselected m) (position b (buttons m)))
+ )
+
+;;;------------------------------------
+
+(defmethod select-button (button-no (m menu))
+
+ "Sets button button-no on."
+
+ (setf (on (nth button-no (buttons m))) t)
+ )
+
+;;;------------------------------------
+
+(defmethod deselect-button (button-no (m menu))
+
+ "Sets button button-no off."
+
+ (setf (on (nth button-no (buttons m))) nil)
+ )
+
+;;;------------------------------------
+
+(defmethod destroy :before ((m menu))
+
+ (mapc #'destroy (buttons m))
+ )
+
+;;;------------------------------------
+
+(defun make-radio-menu (items &rest other-initargs)
+
+ "MAKE-RADIO-MENU items &rest other-initargs
+
+Returns a menu using each of the items as a menu text item, exactly as
+for MAKE-MENU, with the additional constraint that when a menu item is
+selected any other item that is selected will be deselected."
+
+ (let ((m (apply #'make-menu items other-initargs)))
+ (mapc #'(lambda (b)
+ (ev:add-notify m (button-on b)
+ #'(lambda (m1 b1)
+ (setf (active b1) nil)
+ (mapc #'(lambda (other-b)
+ (when (and (on other-b)
+ (not (eq b1 other-b)))
+ (setf (on other-b) nil)
+ (setf (active other-b) t)
+ ))
+ (buttons m1))
+ (ev:announce m1 (selected m1)
+ (position b1 (buttons m1))))))
+ (buttons m))
+ m))
+
+;;;------------------------------------
diff --git a/slik/src/pictures.cl b/slik/src/pictures.cl
new file mode 100644
index 0000000..c9022c1
--- /dev/null
+++ b/slik/src/pictures.cl
@@ -0,0 +1,772 @@
+;;;
+;;; pictures
+;;;
+;;; A picture is a SLIK frame with some process- methods that forward
+;;; X events to interested parties using the announcement of events.
+;;;
+;;; 6-Jul-1992 I. Kalet created
+;;; 8-Oct-1992 I. Kalet add forwarding of exposure events
+;;; 25-Oct-1992 I. Kalet only pictures now have pixmaps so must add it
+;;; here. Also, pixmap is set to window background.
+;;; 12-Nov-1992 I. Kalet move exposure event to frame
+;;; 28-Jan-1994 I. Kalet add pickable objects rectangle, circle, segment
+;;; 17-Apr-1994 I. Kalet add square pickable object, other enhancements
+;;; 25-Apr-1994 I. Kalet change color attribute to gcontext, not symbol
+;;; 22-May-1994 I. Kalet don't update pickable object location on
+;;; pointer motion, just announce - provide update-pickable-object
+;;; generic function so application can do it if desired.
+;;; 24-May-1994 J. Unger finish implementation of segment pickable obj.
+;;; 20-Jun-1994 J. Unger factor out point-near-segment code from picked
+;;; method for segment pickable obj (so can be called elsewhere).
+;;; 25-Jul-1994 J. Unger make enabled attrib of pickable-obj an
+;;; initarg
+;;; 3-Jan-1995 I. Kalet delete unnecessary draw method for square
+;;; 7-May-1997 BobGian changed (EXPT (some-form) 2) to inline squaring
+;;; with LET to avoid multiple evaluation of (some-form).
+;;; 23-Apr-1999 I. Kalet changes for multiple colormaps.
+;;; 21-Jul-2000 I. Kalet enable look-ahead for motion-notify events.
+;;; 26-Nov-2000 I. Kalet make default bg-color black here since it is
+;;; gray in the general case.
+;;;
+
+(in-package :slik)
+
+;;;--------------------------------
+
+(defclass picture (frame)
+
+ ((pixmap :accessor pixmap
+ :initarg :pixmap
+ :documentation "The pixmap is set to the window background,
+and can be used for foreground/background applications like line
+graphics over images.")
+
+ (pick-list :type list
+ :accessor pick-list
+ :initform nil
+ :documentation "The list of pickable objects to be
+checked before announcing button down/up and pointer move events.")
+
+ (enter-notify :type ev:event
+ :accessor enter-notify
+ :initform (ev:make-event)
+ :documentation "Announced when the picture window
+receives an X enter-notify event.")
+
+ (leave-notify :type ev:event
+ :accessor leave-notify
+ :initform (ev:make-event)
+ :documentation "Announced when the picture window
+receives an X leave-notify event.")
+
+ (button-press :type ev:event
+ :accessor button-press
+ :initform (ev:make-event)
+ :documentation "Announced when the picture window
+receives an X button-press event.")
+
+ (button-release :type ev:event
+ :accessor button-release
+ :initform (ev:make-event)
+ :documentation "Announced when the picture window
+receives an X button-release event.")
+
+ (motion-notify :type ev:event
+ :accessor motion-notify
+ :initform (ev:make-event)
+ :documentation "Announced when the picture window
+receives an X motion-notify event.")
+
+ (key-press :type ev:event
+ :accessor key-press
+ :initform (ev:make-event)
+ :documentation "Announced when the picture window
+receives an X key-press event.")
+
+ )
+
+ (:default-initargs :bg-color 'black :border-style :flat)
+
+ (:documentation "A picture is simply a SLIK frame that passes on
+announcements of X events so application code can register with it to
+handle them in any way it wishes without interfering with or knowing
+about SLIK X event processing or the internal details of other SLIK
+objects.")
+
+ )
+
+;;;--------------------------------
+
+(defun erase-bg (pic)
+
+ "erase-bg pic
+
+erases both the pixmap and the window of the picture pic."
+
+ (clx:draw-rectangle (pixmap pic)
+ (color-gc (bg-color pic) (colormap pic))
+ 0 0
+ (width pic) (height pic)
+ t)
+ (clx:clear-area (window pic))
+ (flush-output))
+
+;;;--------------------------------
+
+(defun make-picture (width height &rest other-initargs)
+
+ "make-picture width height &rest other-initargs
+
+returns an instance of a picture with blank pixmap and window."
+
+ (apply #'make-instance 'picture :width width :height height
+ other-initargs))
+
+;;;--------------------------------
+
+(defmethod initialize-instance :after ((pic picture) &rest initargs)
+
+ "adds the extra initialization for pictures to that of frames."
+
+ (declare (ignore initargs))
+ (let* ((w (window pic))
+ (px (clx:create-pixmap :width (width pic)
+ :height (height pic)
+ :depth (clx:drawable-depth w)
+ :drawable w)))
+ (setf (pixmap pic) px
+ (clx:window-background w) px)
+ (push :motion-notify (look-ahead pic))
+ (erase-bg pic)
+ (draw-border pic)
+ (flush-output)
+ pic))
+
+;;;--------------------------------
+
+(defmethod destroy :after ((obj picture))
+
+ (clx:free-pixmap (pixmap obj)))
+
+;;;--------------------------------
+
+(defmethod process-enter-notify ((p picture) x y state)
+
+ "Forwards an announcement to registered parties."
+
+ (ev:announce p (enter-notify p) x y state))
+
+;;;--------------------------------
+
+(defmethod process-leave-notify ((p picture) x y state)
+
+ "Forwards an announcement to registered parties."
+
+ (ev:announce p (leave-notify p) x y state))
+
+;;;--------------------------------
+
+(defmethod process-key-press ((p picture) code state)
+
+ "Forwards an announcement to registered parties."
+
+ (ev:announce p (key-press p) code state))
+
+;;;--------------------------------
+
+(defun display-picture (pic)
+
+ "display-picture pic
+
+copies the background pixmap to the window and draws the pickable
+objects and border in the window."
+
+ (clx:clear-area (window pic))
+ (refresh pic))
+
+;;;--------------------------------
+;;; pickable objects begin here
+;;;--------------------------------
+
+(defclass pickable-object ()
+
+ ((object :accessor object
+ :initarg :object
+ :documentation "The object associated with this pickable
+object.")
+
+ (color :type clx:gcontext
+ :accessor color
+ :initarg :color
+ :documentation "The clx gcontext specifying the color in
+which to draw the pickable object.")
+
+ (enabled :accessor enabled
+ :initarg :enabled
+ :documentation "Enabled indicates that this pickable
+object can receive and process selection events. If nil it ignores
+them and is not drawn in refresh operations.")
+
+ (active :accessor active
+ :initform nil
+ :documentation "Active indicates whether this region is
+picked, i.e., it got selected and the mouse button is still down.")
+
+ (selected :type ev:event
+ :accessor selected
+ :initform (ev:make-event)
+ :documentation "Announced when the mouse button is
+pressed while the pointer is within the pick region.")
+
+ (deselected :type ev:event
+ :accessor deselected
+ :initform (ev:make-event)
+ :documentation "Announced when the mouse button is
+released while the pointer is within the pick region and the region is
+active.")
+
+ (motion :type ev:event
+ :accessor motion
+ :initform (ev:make-event)
+ :documentation "Announced when the pointer moves while this
+pickable object is active.")
+
+ )
+
+ (:default-initargs :color (color-gc 'white) :enabled t)
+
+ (:documentation "A pickable object defines a region in a picture
+which is responsive to button press, i.e., selection operations.")
+
+ )
+
+;;;--------------------------------
+
+(defun add-pickable-obj (po pic)
+
+ "add-pickable-obj po pic
+
+adds the pickable object po to the pick list of picture pic. The
+parameter po can also be a list of pickable objects."
+
+ (if (listp po)
+ (dolist (ob po) (push ob (pick-list pic)))
+ (push po (pick-list pic))))
+
+;;;--------------------------------
+
+(defun find-pickable-objs (obj pic)
+
+ "find-pickable-objs obj pic
+
+returns a list of all pickable objects in the pick list of picture
+pic, that correspond to object obj."
+
+ ;; returns just the first one for now
+ (list (find obj (pick-list pic) :key #'object)))
+
+;;;--------------------------------
+
+(defun remove-pickable-objs (obj pic)
+
+ "remove-pickable-objs obj pic
+
+replaces the pick list in pic with a new list in which all pickable
+objects corresponding to obj are omitted. Returns the new list."
+
+ (setf (pick-list pic)
+ (remove obj (pick-list pic) :key #'object)))
+
+;;;--------------------------------
+
+(defmethod picked ((obj pickable-object) code x y)
+
+ "default method - should use defgeneric instead, for these."
+
+ (declare (ignore code x y))
+ nil)
+
+;;;--------------------------------
+
+(defmethod draw ((obj pickable-object) pic)
+
+ "default method - renders obj into the window of the picture pic."
+
+ (declare (ignore pic))
+ nil)
+
+;;;--------------------------------
+
+(defmethod refresh ((pic picture))
+
+ (dolist (obj (pick-list pic))
+ (if (enabled obj) (draw obj pic))))
+
+;;;--------------------------------
+
+(defmethod process-button-press ((p picture) code x y)
+
+ "Forwards an announcement to registered parties or announces a
+pick."
+
+ (unless (dolist (obj (pick-list p))
+ (when (and (enabled obj) (picked obj code x y))
+ (setf (active obj) t)
+ (ev:announce obj (selected obj) code x y)
+ (return t)))
+ (ev:announce p (button-press p) code x y)))
+
+;;;--------------------------------
+
+(defmethod process-button-release ((p picture) code x y)
+
+ "Forwards an announcement to registered parties or announces a
+pick."
+
+ (unless (dolist (obj (pick-list p))
+ (when (active obj)
+ (setf (active obj) nil)
+ (ev:announce obj (deselected obj))
+ (return t)))
+ (ev:announce p (button-release p) code x y)))
+
+;;;--------------------------------
+
+(defmethod process-motion-notify ((p picture) x y state)
+
+ "Forwards an announcement to registered parties or, if a pickable
+object is active, announces a pickable object motion event."
+
+ (unless (dolist (obj (pick-list p))
+ (when (active obj)
+ (ev:announce obj (motion obj) x y state)
+ (return t)))
+ (ev:announce p (motion-notify p) x y state)))
+
+;;;--------------------------------
+;;; the pickable objects themselves
+;;;--------------------------------
+
+(defclass rectangle (pickable-object)
+
+ ((ulc-x :type fixnum
+ :accessor ulc-x
+ :initarg :ulc-x
+ :documentation "The x coordinate, window relative, of the
+upper left corner of the rectangular sensitive region.")
+
+ (ulc-y :type fixnum
+ :accessor ulc-y
+ :initarg :ulc-y
+ :documentation "The y coordinate, window relative, of the
+upper left corner of the rectangular sensitive region.")
+
+ (width :type fixnum
+ :accessor width
+ :initarg :width
+ :documentation "The width in pixels, of the rectangular
+sensitive region.")
+
+ (height :type fixnum
+ :accessor height
+ :initarg :height
+ :documentation "The y coordinate, window relative, of the
+lower right corner of the rectangular sensitive region.")
+
+ (filled :type (member t nil)
+ :accessor filled
+ :initarg :filled
+ :documentation "A boolean specifying whether the rectangle
+is drawn filled or open.")
+
+ (last-x :type fixnum
+ :accessor last-x
+ :documentation "A cache for doing translations.")
+
+ (last-y :type fixnum
+ :accessor last-y
+ :documentation "A cache for doing translations.")
+
+ )
+
+ (:default-initargs :filled nil)
+
+ (:documentation "A rectangular sensitive region, for example, a grab
+box.")
+
+ )
+
+;;;--------------------------------
+
+(defmethod draw ((obj rectangle) pic)
+
+ (clx:draw-rectangle (window pic) (color obj)
+ (ulc-x obj) (ulc-y obj)
+ (width obj) (height obj)
+ (filled obj)))
+
+;;;--------------------------------
+
+(defmethod update-pickable-object ((obj rectangle) x y)
+
+ "translate from last position to the new position"
+
+ (setf (ulc-x obj) (+ (ulc-x obj) (- x (last-x obj)))
+ (ulc-y obj) (+ (ulc-y obj) (- y (last-y obj)))
+ (last-x obj) x
+ (last-y obj) y))
+
+;;;--------------------------------
+
+(defmethod initialize-instance :after ((obj rectangle) &rest initargs)
+
+ (declare (ignore initargs))
+ (setf (last-x obj) (+ (ulc-x obj) (truncate (/ (width obj) 2)))
+ (last-y obj) (+ (ulc-y obj) (truncate (/ (height obj) 2)))))
+
+;;;--------------------------------
+
+(defun make-rectangle (obj ulc-x ulc-y width height &rest keyargs)
+
+ "make-rectangle obj ulc-x ulc-y width height &rest keyargs
+
+returns a rectangle pickable object at the specified place, associated
+with object obj."
+
+ (apply #'make-instance 'rectangle
+ :object obj
+ :ulc-x ulc-x :ulc-y ulc-y
+ :width width :height height
+ keyargs))
+
+;;;--------------------------------
+
+(defmethod picked ((obj rectangle) code x y)
+
+ "checks if x y is in the rectangle"
+
+ (declare (ignore code))
+ (let ((xu (ulc-x obj))
+ (yu (ulc-y obj)))
+ (and (>= x xu)
+ (>= y yu)
+ (<= x (+ xu (width obj)))
+ (<= y (+ yu (height obj))))))
+
+;;;--------------------------------
+
+(defclass square (rectangle)
+
+ ((x-center :type fixnum
+ :accessor x-center
+ :initarg :x-center
+ :documentation "The x coordinate of the square center.")
+
+ (y-center :type fixnum
+ :accessor y-center
+ :initarg :y-center
+ :documentation "The y coordinate of the square center.")
+
+ )
+
+ ;; ulc-x, ulc-y, height need to be bound, but the initial values
+ ;; don't matter because they are reset after creation
+ (:default-initargs :ulc-x 0 :ulc-y 0 :width 6 :height 6)
+
+ (:documentation "A square sensitive area.")
+
+ )
+
+;;;--------------------------------
+
+(defun set-square-corners (s)
+
+ "set-square-corners s
+
+sets the rectangle slots from the center and width slots."
+
+ (let ((hw (round (/ (width s) 2))))
+ (setf (ulc-x s) (- (x-center s) hw)
+ (ulc-y s) (- (y-center s) hw))))
+
+;;;--------------------------------
+
+(defmethod initialize-instance :after ((s square) &rest initargs)
+
+ (declare (ignore initargs))
+ (set-square-corners s))
+
+;;;--------------------------------
+
+(defmethod (setf x-center) :after (new-x (s square))
+
+ (declare (ignore new-x))
+ (set-square-corners s))
+
+;;;--------------------------------
+
+(defmethod (setf y-center) :after (new-y (s square))
+
+ (declare (ignore new-y))
+ (set-square-corners s))
+
+;;;--------------------------------
+
+(defmethod (setf width) :after (new-w (s square))
+
+ (setf (height s) new-w) ;; for draw method and picked method
+ (set-square-corners s))
+
+;;;--------------------------------
+
+(defmethod update-pickable-object ((obj square) x y)
+
+ "just put in the new position"
+
+ (setf (x-center obj) x
+ (y-center obj) y))
+
+;;;--------------------------------
+
+(defun make-square (obj x y &rest keyargs)
+
+ "make-square obj x y &rest keyargs
+
+returns a square pickable object at the specified place, associated
+with object obj."
+
+ (apply #'make-instance 'square
+ :object obj
+ :x-center x :y-center y
+ keyargs))
+
+;;;--------------------------------
+
+(defclass circle (pickable-object)
+
+ ((x-center :type fixnum
+ :accessor x-center
+ :initarg :x-center
+ :documentation "The x coordinate of the circle center.")
+
+ (y-center :type fixnum
+ :accessor y-center
+ :initarg :y-center
+ :documentation "The y coordinate of the circle center.")
+
+ (radius :type fixnum
+ :accessor radius
+ :initarg :radius
+ :documentation "The radius in pixels of the circle.")
+
+ (filled :type (member t nil)
+ :accessor filled
+ :initarg :filled
+ :documentation "A boolean specifying whether the circle is
+drawn filled or open.")
+
+ )
+
+ (:default-initargs :radius 4 :filled nil)
+
+ (:documentation "A circular sensitive area.")
+
+ )
+
+;;;--------------------------------
+
+(defmethod draw ((obj circle) pic)
+
+ (let* ((r (radius obj))
+ (width (* 2 r)))
+ (clx:draw-arc (window pic) (color obj)
+ (- (x-center obj) r)
+ (- (y-center obj) r)
+ width width
+ 0.0 *two-pi* ;; constant from dials module
+ (filled obj))))
+
+;;;--------------------------------
+
+(defmethod update-pickable-object ((obj circle) x y)
+
+ "just put in the new position"
+
+ (setf (x-center obj) x
+ (y-center obj) y))
+
+;;;--------------------------------
+
+(defun make-circle (obj x y &rest keyargs)
+
+ "make-circle obj x y &rest keyargs
+
+returns a circle pickable object at the specified place, associated
+with object obj."
+
+ (apply #'make-instance 'circle
+ :object obj
+ :x-center x :y-center y
+ keyargs))
+
+;;;--------------------------------
+
+(defmethod picked ((obj circle) code x y)
+
+ "check for within circle"
+
+ (declare (ignore code))
+ (let ((x-val (- x (x-center obj)))
+ (y-val (- y (y-center obj))))
+ (<= (sqrt (+ (* x-val x-val)
+ (* y-val y-val)))
+ (radius obj))))
+
+;;;--------------------------------
+
+(defclass segment (pickable-object)
+
+ ((x1 :type fixnum
+ :accessor x1
+ :initarg :x1
+ :documentation "The x coordinate of end 1.")
+
+ (y1 :type fixnum
+ :accessor y1
+ :initarg :y1
+ :documentation "The y coordinate of end 1.")
+
+ (x2 :type fixnum
+ :accessor x2
+ :initarg :x2
+ :documentation "The x coordinate of end 2.")
+
+ (y2 :type fixnum
+ :accessor y2
+ :initarg :y2
+ :documentation "The y coordinate of end 2.")
+
+ (last-x :type fixnum
+ :accessor last-x
+ :documentation "A cache for doing translations.")
+
+ (last-y :type fixnum
+ :accessor last-y
+ :documentation "A cache for doing translations.")
+
+ (thickness :type fixnum
+ :accessor thickness
+ :initarg :thickness
+ :documentation "The number of pixels thick the
+line segment should be drawn.")
+
+ (tolerance :type fixnum
+ :accessor tolerance
+ :initarg :tolerance
+ :documentation "The number of pixels away from the line
+segment the pointer can be and still be considered on the segment.")
+
+ )
+
+ (:default-initargs :thickness 1 :tolerance 1)
+
+ (:documentation "A line segment sensitive region, like a tube, that
+can be selected and dragged.")
+
+ )
+
+;;;--------------------------------
+
+(defmethod draw ((obj segment) pic)
+
+ (unless (zerop (thickness obj))
+ (clx:draw-line
+ (window pic) (color obj) (x1 obj) (y1 obj) (x2 obj) (y2 obj))))
+
+;;;--------------------------------
+
+(defmethod update-pickable-object ((obj segment) x y)
+
+ "translate from last position to the new position"
+
+ (setf (x1 obj) (+ (x1 obj) (- x (last-x obj)))
+ (x2 obj) (+ (x2 obj) (- x (last-x obj)))
+ (y1 obj) (+ (y1 obj) (- y (last-y obj)))
+ (y2 obj) (+ (y2 obj) (- y (last-y obj)))
+ (last-x obj) x
+ (last-y obj) y))
+
+;;;--------------------------------
+
+(defmethod initialize-instance :after ((obj segment) &rest initargs)
+
+ (declare (ignore initargs))
+ (setf (last-x obj) (truncate (+ (x1 obj) (x2 obj)) 2)
+ (last-y obj) (truncate (+ (y1 obj) (y2 obj)) 2))
+ (when (< 1 (thickness obj))
+ (let ((gc (sl:make-duplicate-gc (color obj))))
+ (setf (clx:gcontext-line-width gc) (thickness obj))
+ (setf (color obj) gc))))
+
+;;;--------------------------------
+
+(defun make-segment (obj x1 y1 x2 y2 &rest keyargs)
+
+ "make-segment obj x1 y1 x2 y2 &rest keyargs
+
+returns an instance of a segment with specified endpoints."
+
+ (apply #'make-instance 'segment
+ :object obj
+ :x1 x1 :y1 y1 :x2 x2 :y2 y2
+ keyargs))
+
+;;;--------------------------------
+
+(defun point-near-segment (x y x1 y1 x2 y2 tolerance)
+
+ "point-near-segment x y x1 y1 x2 y2 tolerance
+
+Returns t iff the point (x y) is within tolerance pixels of the segment
+with endpoints (x1 y1) and (x2 y2)."
+
+ ;; Translate and rotate the segment so that it sits at (0,0) (x,0)
+ ;; on the x axis, then apply the same transformation to the point.
+ ;; The point will be near the segment if its y value is smaller than
+ ;; the threshold, and its x value lies between 0 and that of the
+ ;; other end of the segment.
+
+ (let* ((xt (- x x1))
+ (yt (- y y1))
+ (x2t (- x2 x1))
+ (y2t (- y2 y1))
+ (theta (atan y2t x2t))
+ (sin-theta (sin theta))
+ (cos-theta (cos theta))
+ (xr (+ (* xt cos-theta) (* yt sin-theta)))
+ (yr (- (* yt cos-theta) (* xt sin-theta)))
+ (x2r (+ (* x2t cos-theta) (* y2t sin-theta))))
+ (and (or (<= 0.0 xr x2r)
+ (<= x2r xr 0.0))
+ (or (<= 0.0 yr tolerance)
+ (<= (- tolerance) yr 0.0)))))
+
+;;;-----------------------------------
+
+(defmethod picked ((obj segment) code x y)
+
+ "check if x y is within tolerance pixels of segment"
+
+ (declare (ignore code))
+ (point-near-segment x y (x1 obj) (y1 obj) (x2 obj) (y2 obj)
+ (tolerance obj)))
+
+;;;-----------------------------------
+
+(defmethod destroy :after ((obj segment))
+
+ (when (< 1 (thickness obj))
+ (clx:free-gcontext (color obj))))
+
+;;;-----------------------------------
+;;; End.
diff --git a/slik/src/postscript.cl b/slik/src/postscript.cl
new file mode 100644
index 0000000..c473b44
--- /dev/null
+++ b/slik/src/postscript.cl
@@ -0,0 +1,407 @@
+;;;
+;;; postscript
+;;;
+;;; This module contains a collection of little functions that provide
+;;; a higher level interface to Postscript text and graphics output.
+;;;
+;;; 30-Apr-1998 I. Kalet written
+;;; 19-May-1998 I. Kalet move prism-logo here from charts, parametrize
+;;; it, add draw-rectangle.
+;;; 13-Oct-1998 I. Kalet add support for gray scale image output as
+;;; background to the graphics, and put clipping into a separate
+;;; function.
+;;; 7-May-1999 I. Kalet optimize draw-image
+;;; 18-Jun-1999 J. Zeman add draw-grid function
+;;; 15-Jun-2000 I. Kalet cosmetic changes in documentation.
+;;; 13-Aug-2000 I. Kalet add function for drawing a mesh inside a polygon.
+;;; 12-Mar-2001 I. Kalet change PS version to level 2 and use level 2
+;;; device control to select paper and orientation from pagewidth and
+;;; pageheight.
+;;;
+;;;---------------------------------------------
+
+(defpackage "POSTSCRIPT" (:nicknames "PS") (:use "COMMON-LISP")
+ (:export "DRAW-IMAGE" "DRAW-LINE" "DRAW-LINES" "DRAW-POINT"
+ "DRAW-POLY-MESH" "DRAW-RECTANGLE" "DRAW-TEXT"
+ "DRAW-GRID" "FINISH-PAGE" "INDENT" "INITIALIZE"
+ "NEWLINE" "PRISM-LOGO" "PUT-TEXT"
+ "SET-CLIP" "SET-FONT" "SET-GRAPHICS" "SET-POSITION"
+ "TRANSLATE-ORIGIN"))
+
+;;;---------------------------------------------
+
+(in-package :postscript)
+
+;;;---------------------------------------------
+
+(defun initialize (strm left bottom width height
+ &optional (pagewidth 8.5) (pageheight 11.0))
+
+ "initialize strm left bottom width height
+ &optional (pagewidth 8.5) (pageheight 11.0)
+
+Writes to the output stream strm a collection of low level subroutine
+definitions used by the Postscript package, and sets the margins and
+clipping area according to the parameters, left bottom width height,
+which are in inches."
+
+ ;; write a short prologue (required for some print spoolers
+ (format strm "%!PS-Adobe-2.0~%")
+ (format strm "%%Creator: Prism Postscript system~%")
+ (format strm "%%EndComments~%")
+
+ ;; define conversion from inches to points
+ (format strm "/inch {72 mul} def~%")
+
+ ;; set paper size selection
+ (format strm "<</PageSize [~A ~A]>> setpagedevice~%"
+ (round (* pagewidth 72)) (round (* pageheight 72)))
+
+ ;; set some layout parameters
+ (format strm "/leftmargin ~A inch def~%" left)
+ (format strm "/topmargin ~A inch def~%" (- pageheight height bottom))
+ (format strm "/textwidth ~A inch def~%" width)
+ (format strm "/textheight ~A inch def~%" height)
+ (format strm "/pagewidth ~A inch def~%" pagewidth)
+ (format strm "/pageheight ~A inch def~%" pageheight)
+
+ (set-clip strm left bottom width height)
+
+ ;; define text type size parameter and set a default
+ (format strm "/size 12 def~%" ) ;; default value - 12 pt
+
+ ;; define and initialize horizontal and vertical position
+ ;; parameters, where hpos is used for column indentation
+ (format strm "/vpos ~A inch size sub def~%" (+ bottom height))
+ (format strm "/hpos leftmargin def hpos vpos moveto~%")
+
+ ;; define a font setting command and set a default
+ (format strm "/choosefont {findfont size scalefont setfont} def~%")
+ (format strm "/Courier choosefont~%")
+
+ ;; define the newline command - uses hpos
+ (format strm "/newline ")
+ (format strm "{/vpos vpos size sub def hpos vpos moveto} def~%")
+
+ ;; that's all for now...
+ nil)
+
+;;;---------------------------------------------
+
+(defun set-clip (strm left bottom width height)
+
+ "set-clip strm left bottom width height
+
+set the clipping window according to the margins and size specified,
+relative to the current origin."
+
+ (format strm "newpath ~A inch ~A inch moveto~%" left bottom)
+ (format strm "~A inch ~A inch lineto~%" left (+ bottom height))
+ (format strm "~A inch ~A inch lineto~%"
+ (+ left width) (+ bottom height))
+ (format strm "~A inch ~A inch lineto closepath clip~%"
+ (+ left width) bottom))
+
+;;;---------------------------------------------
+
+(defun set-font (strm fontname size)
+
+ "set-font strm fontname size
+
+writes the commands to select the specified font by name and set the
+current type size to size, in points."
+
+ (format strm "/size ~A def /~A choosefont~%" size fontname))
+
+;;;---------------------------------------------
+
+(defun set-position (strm horiz vert)
+
+ "set-position strm horiz vert
+
+sets the current text position to horiz and vert in inches, allowing
+for the left margin, where vert is the distance down from the top.
+This assumes that the origin is at the lower left corner of the page."
+
+ (format strm "newpath ~A inch leftmargin add~%" horiz)
+ (format strm "/vpos pageheight topmargin sub ~A inch sub def~%" vert)
+ (format strm "vpos moveto~%"))
+
+;;;---------------------------------------------
+
+(defun put-text (strm str)
+
+ "put-text strm str
+
+writes the string str at the current position and sets the current
+position to the beginning of the next line."
+
+ (format strm "(~A) show newline~%" str))
+
+;;;---------------------------------------------
+
+(defun translate-origin (strm x y)
+
+ "translate-origin strm x y
+
+translates the origin by a displacement of x and y inches from the
+current origin."
+
+ (format strm "~A inch ~A inch translate~%" x y))
+
+;;;---------------------------------------------
+
+(defun indent (strm indentation)
+
+ "indent strm indentation
+
+sets the horizontal position to indentation in inches, to make columns
+that are not at the left margin. To reset, pass in a value of 0."
+
+ (format strm "/hpos leftmargin ~A inch add def~%" indentation))
+
+;;;---------------------------------------------
+
+(defun set-graphics (strm &key color width pattern)
+
+ "set-graphics strm &key color width pattern
+
+sets the current color, line width and line dash pattern according to
+color, a list of RGB values, width, a number, and pattern, a string
+containing a Postscript dash array with brackets, and a number, the
+offset. If a parameter is omitted, that graphic attribute is not
+changed."
+
+ (if color (apply #'format strm "~A ~A ~A setrgbcolor~%" color))
+ (if width (format strm "~A setlinewidth~%" width))
+ (if pattern (format strm "~A setdash~%" pattern)))
+
+;;;---------------------------------------------
+
+(defun draw-image (strm x y width height xpix ypix image)
+
+ "draw-image strm x y width height xpix ypix image
+
+draws a gray scale image with lower left corner at position x,y in
+inches relative to the current origin, in a rectangle of dimensions
+width and height, in inches, from the array, image, of 8-bit bytes,
+which is xpix columns by ypix rows. The byte values are assumed to
+range between 0 and 127."
+
+ (declare (type (simple-array (unsigned-byte 8) 2) image))
+ (let ((hexarray (make-array 128 :element-type 'string)))
+ (declare (type (simple-array string (128)) hexarray))
+ (dotimes (i 128)
+ (setf (aref hexarray i) (format nil "~2,'0X" (* 2 i))))
+ (format strm "gsave~%")
+ ;; use a string buffer one raster line in length
+ (format strm "/pixels ~A string def~%" xpix)
+ (format strm "~A inch ~A inch translate~%" x y)
+ (format strm "~A inch ~A inch scale~%" width height)
+ (format strm "~A ~A 8~%" xpix ypix)
+ (format strm "[~A 0 0 ~A 0 ~A]~%" xpix (- ypix) ypix)
+ ;; read a raster line of hex at a time from the PS file
+ (format strm "{currentfile pixels readhexstring pop}~%image~%~%")
+ ;; the hex data follow - write 32 bytes per line
+ (let ((counter 0))
+ (declare (fixnum counter))
+ (dotimes (j ypix)
+ (declare (fixnum j))
+ (dotimes (i xpix)
+ (declare (fixnum i))
+ ;; princ seems to be faster than format here...
+ (princ (aref hexarray (aref image j i)) strm)
+ (when (= (incf counter) 32)
+ (setq counter 0)
+ (terpri strm)))))
+ (format strm "~%~%")
+ (format strm "~A inch ~A inch scale~%" (/ 1.0 width) (/ 1.0 height))
+ (format strm "~A inch ~A inch translate grestore~%" (- x) (- y))))
+
+;;;---------------------------------------------
+
+(defun draw-line (strm x1 y1 x2 y2)
+
+ "draw-line strm x1 y1 x2 y2
+
+draws a line from x1, y1 to x2, y2, coordinates in inches, relative to
+the current origin, in the current color, line width and dash
+pattern. The path is reset before drawing."
+
+ (format strm
+ "newpath ~A inch ~A inch moveto ~A inch ~A inch lineto stroke~%"
+ x1 y1 x2 y2))
+
+;;;---------------------------------------------
+
+(defun draw-lines (strm vertex-list &optional close fill)
+
+ "draw-lines strm vertex-list &optional close fill
+
+draws the lines specified by vertex-list, a list of x,y pairs, vertex
+coordinates in inches, as a series of connected segments, in the
+current color, line width and dash pattern, optionally filling with
+the current color."
+
+ (let ((start (first vertex-list)))
+ (format strm "newpath ~A inch ~A inch moveto~%"
+ (first start) (second start))
+ (dolist (vert (rest vertex-list))
+ (format strm " ~A inch ~A inch lineto~%"
+ (first vert) (second vert)))
+ (if close (format strm " closepath"))
+ (format strm " ~A~%" (if fill "fill" "stroke"))))
+
+;;;---------------------------------------------
+
+(defun draw-rectangle (strm x y w h &optional fill)
+
+ "draw-rectangle strm x y w h &optional fill
+
+draws the rectangle specified by lower left corner x,y and width w and
+height h, in the current color, line width and dash pattern."
+
+ (let ((x2 (+ x w))
+ (y2 (+ y h)))
+ (format strm
+ "newpath ~A inch ~A inch moveto ~A inch ~A inch lineto~%"
+ x y x2 y)
+ (format strm "~A inch ~A inch lineto ~A inch ~A inch lineto~%"
+ x2 y2 x y2)
+ (format strm "closepath ~A~%" (if fill "fill" "stroke"))))
+
+;;;---------------------------------------------
+
+(defun draw-text (strm x y chars)
+
+ "draw-text strm x y chars
+
+draws the string chars starting at location x, y in inches in the
+current coordinate system, without starting a new line or changing the
+text line pointers."
+
+ (format strm "~A inch ~A inch moveto (~A) show~%" x y chars))
+
+;;;---------------------------------------------
+
+(defun draw-point (strm x y label size)
+
+ "draw-point strm x y label
+
+draws a plus mark whose lines are size long, at the location x, y and
+a label to the upper right."
+
+ (let ((delta (* 0.5 size)))
+ (draw-line strm (- x delta) y (+ x delta) y)
+ (draw-line strm x (- y delta) x (+ y delta))
+ (draw-text strm (+ x delta) y label)))
+
+;;;---------------------------------------------
+
+(defun draw-grid (strm width height columns rows)
+
+ "draw-grid strm width height columns rows
+
+Writes to strm a postscript-defined grid width inches wide, height
+inches high, and with the amount of rows and columns specified. It
+requires a defined current drawing position, which becomes the lower
+left corner of grid. The final drawing position is the same as the
+start position."
+
+ (setf height (* 72 height))
+ (setf width (* 72 width))
+ (format strm "gsave~%") ;; store position
+ ;; set up loops to draw columns and rows.
+ (format strm "~A {0 ~A rlineto ~A ~A rmoveto} repeat~%" (+ columns 1)
+ height (float(/ width columns)) (* -1 height))
+ ;; draw lines, then back to start
+ (format strm "stroke grestore gsave~%")
+ (format strm "~A {~A 0 rlineto ~A ~A rmoveto} repeat~%" (+ rows 1)
+ width (* -1 width) (float (/ height rows)))
+ (format strm "stroke grestore ~%"))
+
+;;;---------------------------------------------
+
+(defun draw-poly-mesh (strm polygon mesh-size)
+
+ "draw-poly-mesh strm polygon mesh-size
+
+fills the region defined by polygon with a mesh whose line spacing is
+mesh-size, in the current color, restoring the current drawing
+position and clip region after completion. Only the mesh lines are
+drawn. The space between the lines is undisturbed."
+
+ (format strm "gsave~%")
+ (let* ((start (first polygon))
+ (xlist (mapcar #'first polygon))
+ (ylist (mapcar #'second polygon))
+ (llc-x (apply #'min xlist))
+ (wid (- (apply #'max xlist) llc-x))
+ (llc-y (apply #'min ylist))
+ (hgt (- (apply #'max ylist) llc-y)))
+ (format strm "newpath ~A inch ~A inch moveto~%"
+ (first start) (second start))
+ (dolist (vert (rest polygon))
+ (format strm " ~A inch ~A inch lineto~%"
+ (first vert) (second vert)))
+ (format strm "clip~%")
+ (format strm "~A inch ~A inch moveto~%" llc-x llc-y)
+ (draw-grid strm wid hgt
+ (round (/ wid mesh-size)) (round (/ hgt mesh-size)))
+ (format strm "grestore~%")))
+
+;;;---------------------------------------------
+
+(defun finish-page (strm &optional newpage)
+
+ "finish-page strm &optional newpage
+
+outputs the current page and optionally starts a new one."
+
+ (format strm "showpage~%")
+ (when newpage
+ (format strm "/vpos pageheight topmargin sub def newline~%")))
+
+;;;----------------------------------------------------
+
+(defun prism-logo (strm ulc-x ulc-y version)
+
+ "prism-logo strm ulc-x ulc-y version
+
+writes Postscript commands to stream strm that will produce a Prism
+logo with version string specified, at location ulc-x ulc-y, relative
+to the current origin, with the values in inches."
+
+ (format strm "gsave~%")
+ (format strm
+"2 setlinecap 2 setlinejoin
+~A inch ~A inch translate
+0.8 0.8 scale
+3 setlinewidth
+% Polyline - the red trace
+1.0 0 0 setrgbcolor
+newpath 17 -53 moveto 52 -30 lineto 224 -30 lineto stroke
+% Polyline - the green trace
+0 1.0 0 setrgbcolor
+newpath 17 -54 moveto 58 -40 lineto 114 -40 lineto stroke
+% Polyline - the blue trace
+0 0 1.0 setrgbcolor
+newpath 17 -55 moveto 59 -50 lineto 114 -50 lineto stroke
+0 0 0 setrgbcolor
+% Polyline - the input trace
+newpath 0 -70 moveto 16 -53 lineto stroke
+% Polyline - the triangle
+newpath 39 0 moveto 69 -70 lineto 9 -70 lineto closepath stroke
+/Helvetica findfont 14.000 scalefont setfont
+134 -55 moveto (~A) show
+/Helvetica-Bold findfont 18.000 scalefont setfont
+64 -20 moveto
+(Prism RTP system) show
+1.25 1.25 scale
+~A inch ~A inch translate
+/Courier findfont 12.000 scalefont setfont~%"
+ulc-x ulc-y version (- ulc-x) (- ulc-y))
+(format strm "grestore ~%"))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/slik/src/readouts.cl b/slik/src/readouts.cl
new file mode 100644
index 0000000..aac1d82
--- /dev/null
+++ b/slik/src/readouts.cl
@@ -0,0 +1,160 @@
+;;;
+;;; readouts
+;;;
+;;; not much to these - just a box displaying some text or a number
+;;;
+;;; 21-Apr-1992 I. Kalet created
+;;; 01-May-1992 I. Kalet use erase, add a destroy method
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 29-May-1992 I. Kalet default font in frame not here
+;;; 7-Jul-1992 I. Kalet make set-info a generic function so textline
+;;; can produce the announcement described in the SLIK Programmer's
+;;; Guide
+;;; 8-Oct-1992 I. Kalet take out :initarg for info-x, replace defsetf
+;;; info with defmethod (setf info), replace clx:create-gcontext with
+;;; SLIK function make-duplicate-gc
+;;; 25-Oct-1992 I. Kalet eliminate pixmap and fix up refresh
+;;; 3-Jan-1995 I. Kalet remove proclaim form and add setf method for
+;;; changing fg-color.
+;;; 23-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 26-Nov-2000 I. Kalet explicitly make default border-style flat
+;;; since for frames in general it is now raised.
+;;; 2-Feb-2003 I. Kalet make setf fg-color an :after method now that
+;;; the method for frames is an :around.
+;;;
+
+(in-package :slik)
+
+;;;------------------------------------------
+
+(defclass readout (frame)
+
+ ((info :type string
+ :reader info ; a primary setf method is provided below...
+ :initarg :info
+ :documentation "The value stored here is always a string, but
+the setf method accepts any data input and converts it to a string.")
+
+ (label :type string
+ :accessor label
+ :initarg :label)
+
+ (info-x :type clx:card16
+ :accessor info-x)
+
+ (info-y :type clx:card16
+ :accessor info-y)
+
+ (gc-with-font :accessor gc-with-font
+ :initform (make-duplicate-gc)
+ :documentation "A cached graphic context for drawing
+in the font for this readout instead of the default font. Much faster
+than using the with-gcontext macro.")
+
+ )
+
+ (:default-initargs :title "SLIK Readout" :info "" :label ""
+ :border-style :flat)
+
+ (:documentation "A readout is a passive box that displays whatever
+data is written to it. By default the text is vertically centered and
+starts 10 pixels in from the left.")
+ )
+
+;;;----------------------------------------
+
+(defmethod initialize-instance :after ((r readout) &rest initargs)
+
+ "Much setup done here so it can also be used by the textline class."
+
+ (declare (ignore initargs))
+ (let* ((w (width r))
+ (h (height r))
+ (f (font r))
+ (font-descent (clx:max-char-descent f))
+ (info-width (clx:text-width f (info r)))
+ (label-width (clx:text-width f (label r))))
+ (setf (info-x r) (if (= info-width 0) (+ label-width 10)
+ (+ (round (/ (- w info-width label-width) 2))
+ label-width))
+ (info-y r) (- h (round (/ (- h (font-height f)) 2)) font-descent))
+ (clx:copy-gcontext (color-gc (fg-color r) (colormap r))
+ (gc-with-font r))
+ (setf (clx:gcontext-font (gc-with-font r)) f)
+ (when (> label-width 0)
+ (clx:draw-glyphs (window r) (gc-with-font r) ; draw the label
+ (- (info-x r) label-width) (info-y r)
+ (label r)))))
+
+;;;--------------------------------------
+
+(defun update-info (r)
+
+ "Erase and rewrite only the info region, leave the label."
+
+ (let* ((start-x (info-x r))
+ (erase-width (- (width r) start-x))
+ (w (window r)))
+ (clx:draw-rectangle w (color-gc (bg-color r) (colormap r))
+ start-x 0 erase-width (height r) t)
+ (clx:draw-glyphs w (gc-with-font r)
+ start-x (info-y r) (info r))
+ (draw-border r)
+ (flush-output)))
+
+;;;--------------------------------------
+
+(defmethod (setf fg-color) :after (new-col (r readout))
+
+ (clx:copy-gcontext (color-gc new-col (colormap r))
+ (gc-with-font r))
+ (setf (clx:gcontext-font (gc-with-font r)) (font r)))
+
+;;;--------------------------------------
+
+(defmethod refresh :after ((r readout))
+
+ "Draw the label and the info."
+
+ (let* ((lab (label r))
+ (lw (clx:text-width (font r) lab))
+ (ix (info-x r))
+ (iy (info-y r))
+ (w (window r))
+ (gc (gc-with-font r)))
+ (if (> lw 0) ;; draw the label
+ (clx:draw-glyphs w gc (- ix lw) iy (label r)))
+ (clx:draw-glyphs w gc ix iy (info r))))
+
+;;;----------------------------------------
+
+(defun make-readout (width height &rest other-initargs)
+
+ "make-readout width height &rest other-initargs
+
+Returns a readout with the specified parameters. If the info
+parameter is provided it is centered as well as possible."
+
+ (let ((r (apply 'make-instance 'readout
+ :width width :height height other-initargs)))
+ (refresh r)
+ r))
+
+;;;--------------------------------------
+
+(defmethod (setf info) (new-info (r readout))
+
+ "This setf method takes any input and creates a string that is the
+LISP printed representation of the input, and stores that string."
+
+ (setf (slot-value r 'info) (format nil "~A" new-info))
+ (update-info r))
+
+;;;--------------------------------------
+
+(defmethod destroy :before ((r readout))
+
+ (clx:free-gcontext (gc-with-font r)))
+
+;;;--------------------------------------
+;;; End.
diff --git a/slik/src/scroll-frames.cl b/slik/src/scroll-frames.cl
new file mode 100644
index 0000000..f573bf5
--- /dev/null
+++ b/slik/src/scroll-frames.cl
@@ -0,0 +1,179 @@
+;;;
+;;; scroll-frames
+;;;
+;;; Provides a horizontal scroll window for sliding through a series
+;;; of pictures (provided by the caller), including the capability to
+;;; page through subsets if the entire lists is too big to fit in the X
+;;; window system address space.
+;;;
+;;; 8-Sep-2003 I. Kalet created with ideas from popup-scroll-menu and
+;;; the Prism filmstrip.
+;;;
+
+(in-package :slik)
+
+;;;--------------------------------------
+
+(defconstant *scrollbar-height* 20)
+
+;;;----------------------------------------
+
+(defclass scroll-frame (frame)
+
+ ((width :type fixnum
+ :accessor width
+ :initarg :width
+ :documentation "The width of the overall scroll-frame,
+ specified by the caller.")
+
+ (pictures :type list
+ :accessor pictures
+ :initarg :pictures
+ :documentation "The list of SLIK pictures that can be
+ displayed in the scroll-frame. They should be supplied
+ unmapped.")
+
+ (index :type fixnum
+ :accessor index
+ :initarg :index
+ :documentation "The index of the selected picture in the
+ list of pictures.")
+
+ (new-index :type ev:event
+ :accessor new-index
+ :initform (ev:make-event)
+ :documentation "Announced when the user selects a
+ picture by clicking on it.")
+
+ (offset :type fixnum
+ :accessor offset
+ :initform 0
+ :documentation "The index of the first picture in the
+ currently scrollable subset of the picture list.")
+
+ (scroll-window :accessor scroll-window
+ :documentation "The parent window of all the
+ pictures currently in the displayable list, fits
+ within the scroll-frame, and only those pictures
+ whose x coordinate puts them in the displayable part
+ are visible.")
+
+ (scrollbar :accessor scrollbar
+ :documentation "Used to move through the currently
+ displayable pictures.")
+
+ (page-button :accessor page-button
+ :documentation "Used to move to the next subset of
+ pictures, when there are too many to map all at once
+ in the X address space.")
+
+ )
+
+ (:default-initargs :pictures nil :width 768 :index 0)
+
+ (:documentation "The scroll-frame provides a display of a linear
+ sequence of pictures that can be scrolled horizontally in a fixed
+ viewport.")
+
+ )
+
+;;;----------------------------------------
+
+(defmethod initialize-instance :after ((scr scroll-frame)
+ &rest initargs)
+
+ "parallels the scrolling list...most constants defined elsewhere in
+ SLIK."
+
+ (let* ((background-color (color-gc (bg-color scr) (colormap scr)))
+ (background (clx:gcontext-foreground background-color))
+ (pixmap-height (clx:drawable-height
+ (pixmap (first (pictures scr)))))
+ )
+ (setf (scroll-window scr)
+ (clx:create-window :parent (window scr)
+ :x 0 :y 0
+ :width (width scr)
+ :height (+ *scrollbar-height* pixmap-height)
+ :depth *screen-root-depth*
+ :background background))
+ (clx:map-window (scroll-window scr))
+ (setf (scrollbar scr)
+ (make-scrollbar (width s) *scrollbar-height*
+ *scroll-minimum* *scroll-maximum*
+ :parent (window scr)
+ :ulc-x 0 :ulc-y pixmap-height))
+ ;; as scrollbar moves right, scroll-window moves left (and vice-versa)
+ (ev:add-notify scr (value-changed (scrollbar scr))
+ #'(lambda (sl sb setting)
+ (declare (ignore sb))
+ (setf (clx:drawable-x (scroll-window sl))
+ (round (* (- (width sl)
+ (clx:drawable-width (scroll-window sl)))
+ (- *scroll-maximum* setting))))
+ (clx:display-finish-output *display*)))
+ ))
+
+;;;----------------------------------------
+
+(defun make-scroll-frame (width picture-list &rest initargs)
+
+ "make-scroll-frame width picture-list &rest initargs
+
+returns a scroll-frame of the specified width in pixels, with the
+picture-list positioned to show the first picture in the list at the
+left-most position in the frame, unless otherwise specified in the
+initargs."
+
+ (apply #'make-instance 'scroll-frame
+ :width width :pictures picture-list initargs))
+
+;;;----------------------------------------
+
+(defmethod (setf index) :after (new (scr scroll-frame))
+
+ (ev:announce scr (new-index scr) new))
+
+;;;----------------------------------------
+
+(defun add-picture (pic scr place)
+
+ "Provides a way for a client to add a new picture in the list scr at
+ a place indexed by place."
+
+ ;; use insert from misc.cl, like in filmstrip and insert-button in
+ ;; scrolling list
+
+ )
+
+;;;----------------------------------------
+
+(defun delete-picture (pic scr)
+
+ "Provides a way for a client to remove a picture from the list scr."
+
+
+ )
+
+;;;----------------------------------------
+
+(defun display-scroll-frame (scr)
+
+ "Updates the display for scroll-frame scr, usually after some change
+ is made to one or more of the pixmaps in the picture list."
+
+ )
+
+;;;----------------------------------------
+
+(defmethod destroy :before ((scr scroll-frame))
+
+ "dsetroys the scroll-frame and its components, but does not do
+ anything to the picture list, except unmap it."
+
+ (destroy (scrollbar scr))
+ (aif (page-button scr) (destroy it))
+ (clx:destroy-window (scroll-window scr)))
+
+;;;----------------------------------------
+;;; End.
diff --git a/slik/src/scrollbars.cl b/slik/src/scrollbars.cl
new file mode 100644
index 0000000..2ea71b2
--- /dev/null
+++ b/slik/src/scrollbars.cl
@@ -0,0 +1,177 @@
+;;;
+;;; scrollbars
+;;;
+;;; 12-Aug-1998 M. Lease written. Support for scrolling via holding
+;;; down the increment or decrement button is not yet added.
+;;; 23-Nov-1998 I. Kalet include a real event, and forward slider
+;;; announcement, rather than depend on event implementation details.
+;;; Also add a destroy method.
+;;;
+
+(in-package :slik)
+
+;;;------------------------------------------
+
+(defclass scrollbar (frame)
+
+ ((slider :type slider
+ :accessor slider
+ :initarg :slider
+ :documentation "The knob and bar of the scrollbar.")
+
+ (btn-incr :type icon-button
+ :accessor btn-incr
+ :initarg :btn-incr
+ :documentation "The button to increment the current setting.")
+
+ (btn-decr :type icon-button
+ :accessor btn-decr
+ :initarg :btn-decr
+ :documentation "The button to decrement the current setting.")
+
+ (scroll-size :type single-float
+ :accessor scroll-size
+ :initarg :scroll-size
+ :initform 0.0
+ :documentation "Amount by which the setting is
+incremented or decremented when the appropriate button is pressed.")
+
+ (value-changed :type ev:event
+ :accessor value-changed
+ :initform (ev:make-event)
+ :documentation "Announced when the scrollbar knob
+moves, whether it is by the slider moving or the arrow buttons.")
+
+ )
+
+ (:default-initargs :title "SLIK scrollbar" :orient :vertical)
+
+ (:documentation "A scrollbar is a compound SLIK widget composed of a
+slider and two arrow buttons. Just as the sliderbox complements the
+slider by allowing the setting to be changed via a textbox, the
+scrollbar complements the slider by allowing the setting to be
+incremented or decremented a fixed amount via arrow buttons.")
+ )
+
+;;;------------------------------------------
+
+(defun make-scrollbar (width height min max &rest other-initargs)
+
+ (apply #'make-instance 'scrollbar :width width :height height
+ :minimum min :maximum max other-initargs))
+
+;;;------------------------------------------
+
+(defmethod initialize-instance :after ((s scrollbar)
+ &rest other-initargs
+ &key orient minimum maximum
+ &allow-other-keys)
+
+ (let ((width (width s))
+ (height (height s))
+ (win (window s))
+ (btn-side) (slider-width) (slider-height) (btn-decr-dir)
+ (btn-incr-dir) (btn-incr-x) (btn-decr-y) (slider-x)
+ (slider-y) (setting))
+ (if (eq orient :vertical)
+ (progn
+ (setq btn-side width)
+ (setq slider-width width)
+ (setq slider-height (- height (* 2 btn-side)))
+ (setq btn-decr-dir :down)
+ (setq btn-incr-dir :up)
+ (setq btn-incr-x 0)
+ (setq btn-decr-y (+ btn-side slider-height))
+ (setq slider-x 0)
+ (setq slider-y btn-side)
+ (setq setting maximum))
+ (progn
+ (setq btn-side height)
+ (setq slider-width (- width (* 2 btn-side)))
+ (setq slider-height height)
+ (setq btn-decr-dir :left)
+ (setq btn-incr-dir :right)
+ (setq btn-incr-x (+ btn-side slider-width))
+ (setq btn-decr-y 0)
+ (setq slider-x btn-side)
+ (setq slider-y 0)
+ (setq setting minimum)))
+ (setf (btn-decr s) (apply 'make-arrow-button btn-side btn-side
+ btn-decr-dir
+ :ulc-x 0 :ulc-y btn-decr-y
+ :parent win
+ other-initargs))
+ (setf (btn-incr s) (apply 'make-arrow-button btn-side btn-side
+ btn-incr-dir
+ :ulc-x btn-incr-x :ulc-y 0
+ :parent win
+ other-initargs))
+ (setf (slider s) (apply 'make-slider slider-width
+ slider-height minimum maximum
+ :setting setting
+ :ulc-x slider-x :ulc-y slider-y
+ :parent win
+ other-initargs)))
+ (ev:add-notify s (button-on (btn-decr s))
+ #'(lambda (sbar b)
+ (declare (ignore b))
+ (setf (setting sbar)
+ (max (- (setting sbar) (scroll-size sbar))
+ (minimum (slider sbar))))))
+ (ev:add-notify s (button-on (btn-incr s))
+ #'(lambda (sbar b)
+ (declare (ignore b))
+ (setf (setting sbar)
+ (min (+ (setting sbar) (scroll-size sbar))
+ (maximum (slider sbar))))))
+ (ev:add-notify s (value-changed (slider s))
+ #'(lambda (sbar sl newval)
+ (declare (ignore sl))
+ (ev:announce sbar (value-changed sbar) newval))))
+
+;;;------------------------------------------
+
+(defmethod setting ((s scrollbar))
+
+ (setting (slider s)))
+
+;;;------------------------------------------
+
+(defmethod (setf setting) (val (s scrollbar))
+
+ (setf (setting (slider s)) val))
+
+;;;------------------------------------------
+
+(defmethod maximum ((s scrollbar))
+
+ (maximum (slider s)))
+
+;;;------------------------------------------
+
+(defmethod (setf maximum) (val (s scrollbar))
+
+ (setf (maximum (slider s)) val))
+
+;;;------------------------------------------
+
+(defmethod knob-scale ((s scrollbar))
+
+ (knob-scale (slider s)))
+
+;;;------------------------------------------
+
+(defmethod (setf knob-scale) (val (s scrollbar))
+
+ (setf (knob-scale (slider s)) val))
+
+;;;------------------------------------------
+
+(defmethod destroy :before ((s scrollbar))
+
+ (destroy (slider s))
+ (destroy (btn-incr s))
+ (destroy (btn-decr s)))
+
+;;;------------------------------------------
+;;; End.
diff --git a/slik/src/scrolling-lists.cl b/slik/src/scrolling-lists.cl
new file mode 100644
index 0000000..37f5d10
--- /dev/null
+++ b/slik/src/scrolling-lists.cl
@@ -0,0 +1,548 @@
+;;;
+;;; scrolling-lists
+;;;
+;;; A scrolling list contains a list of items like a menu, along with
+;;; a scrollbar, in case the list is too long to display all of it in
+;;; the available area. These lists only scroll vertically.
+;;;
+;;; 25-May-1992 I. Kalet created
+;;; 26-May-1992 I. Kalet don't use menus - use unmapped buttons.
+;;; 4-Jun-1992 I. Kalet delete-button also deselects
+;;; 6-Jul-1992 I. Kalet make scroll-bar half the width of the
+;;; available space, add make-radio-scrolling-list and
+;;; make-list-button, change behavior to event and be: to ev:
+;;; 8-Oct-1992 I. Kalet change select-button, deselect-button to
+;;; generic functions instead of ordinary functions. Add optional
+;;; button-type parameter to make-list-button.
+;;; 25-Oct-1992 I. Kalet eliminate pixmap, make delete-button generic
+;;; 5-Nov-1992 I. Kalet change make-list-button parameters from
+;;; optional to keyword (justify and button-type)
+;;; 29-Nov-1992 I. Kalet take out reference to ulc-x and ulc-y
+;;; 6-Aug-1993 I. Kalet finally implement delete with middle mouse
+;;; button, include keyword parameter enable-delete.
+;;; 10-Jan-1995 I. Kalet insure that in a radio-scrolling-list, user
+;;; cannot deselect the selected button, also put popup-scroll-menu
+;;; here to remove circularity with dialogboxes. Also change destroy
+;;; method to destroy the buttons instead of deleting them. This
+;;; should be faster.
+;;; 19-Jul-1995 I. Kalet change scrollbar behavior to simply move top
+;;; of bar to pointer location, and track (slowly...) with motion.
+;;; 23-Jun-1997 I. Kalet fix insert-button for radio-scrolling-list to
+;;; just do that button, and when a button is turned off, reactivate
+;;; it.
+;;; 4-Jun-1998 I. Kalet fix place-button to be more judicious.
+;;; 16-Jun-1998 I. Kalet make popup scroll more efficient.
+;;; 25-Aug-1998 M. Lease now uses slik scrollbar, more efficient, maps
+;;; all items and so limits the maximum number of items to be (max
+;;; 16-bit signed int / button-height) since clx uses a 16-bit int to
+;;; hold drawable-y value. Deleting buttons not tested; Prism should be
+;;; be built using the revised scrolling-lists for testing.
+;;; make-list-button now inserts buttons; popup-scroll-menu not tested
+;;; with this change.
+;;; 29-Nov-1998 I. Kalet change defmethod to defun in some places,
+;;; change make-list-button back to previous API and define
+;;; make-and-insert-list-button to do both create and insert. Fix
+;;; button delete, other stuff.
+;;; 16-Dec-1998 I. Kalet if more items in popup-scroll-menu than fit
+;;; in X address space, add a page button and segment the items into
+;;; pages.
+;;; 22-Mar-1999 I. Kalet add a reorder function that accepts a
+;;; reordered list of the existing buttons, replaces the old list, and
+;;; resets the button y coordinates to correspond to the new order.
+;;; 23-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;;
+
+;; testing cvs
+
+(in-package :slik)
+
+;;;--------------------------------------
+
+(defconstant *scrollbar-width* 20)
+
+;;; use these limits on the scrollbar to simplify the translation
+;;; of scrollbar setting to drawable-y pos of btn-win
+
+(defconstant *scroll-minimum* 0.0)
+(defconstant *scroll-maximum* 1.0)
+
+(defconstant *scrollwindow-maxsize* 32767
+ "limit of size of scrollable window")
+
+;;;--------------------------------------
+
+(defclass scrolling-list (frame)
+
+ ((buttons :type list
+ :accessor buttons
+ :initform nil
+ :documentation "List of buttons in the scrolling list.")
+
+ (enable-delete :accessor enable-delete
+ :initarg :enable-delete
+ :initform nil
+ :documentation "Boolean variable, if t, allows
+delete of button with middle mouse button. If nil, ignores middle
+mouse button clicks.")
+
+ (button-height :type clx:card16
+ :accessor button-height
+ :documentation "The computed height that buttons in
+this scrolling-list should be, based on the specified font.")
+
+ (button-width :type clx:card16
+ :accessor button-width
+ :documentation "The computed width that buttons in
+this scrolling-list should be, based on the width of the
+scrolling-list and the width of the scroll-bar.")
+
+ (btn-win :type clx:window
+ :accessor btn-win
+ :documentation "Parent window of buttons.")
+
+ (scrollbar :type scrollbar
+ :accessor scrollbar)
+
+ (inserted :type ev:event
+ :accessor inserted
+ :initform (ev:make-event)
+ :documentation "Announced when an item is inserted into
+the list.")
+
+ (deleted :type ev:event
+ :accessor deleted
+ :initform (ev:make-event)
+ :documentation "Announced when an item is deleted from the
+list.")
+
+ (selected :type ev:event
+ :accessor selected
+ :initform (ev:make-event)
+ :documentation "Announced when an item in the list is
+selected.")
+
+ (deselected :type ev:event
+ :accessor deselected
+ :initform (ev:make-event)
+ :documentation "Announced when an item in the list is
+deselected.")
+
+ )
+
+ (:default-initargs :title "SLIK Scrolling List")
+
+ (:documentation "The scrolling-list contains a list of buttons and a
+scroll bar. In case only part of the list of buttons is visible, the
+scroll bar enables the user to change the portion that appears in the
+window.")
+
+ )
+
+;;;--------------------------------------
+
+(defun make-list-button (s label &key (justify :left)
+ (button-type :hold) (ulc-y 0))
+
+ "make-list-button s label &key justify button-type ulc-y
+
+Returns an instance of a SLIK button with width and height sized to
+fit scrolling-list s, and with the specified label, positioning and
+button type. The default for justify is :left, for button-type is
+hold, and for ulc-y is 0. The button gets the same graphic
+characteristics as the scrolling-list, i.e., foreground color,
+background color, border color, etc."
+
+ (make-button (button-width s) (button-height s)
+ :parent (btn-win s)
+ :ulc-y ulc-y :mapped nil :font (font s)
+ :bg-color (bg-color s)
+ :fg-color (fg-color s)
+ :border-width (border-width s)
+ :border-color (border-color s)
+ :label label
+ :justify justify
+ :button-type button-type))
+
+;;;--------------------------------------
+
+(defun init-button (b s)
+
+ "init-button b s
+
+sets up event notification for button b."
+
+ (ev:add-notify s (button-on b)
+ #'(lambda (sc bt)
+ (ev:announce sc (selected sc) bt)))
+ (ev:add-notify s (button-off b)
+ #'(lambda (sc bt)
+ (ev:announce sc (deselected sc) bt)))
+ (ev:add-notify s (button-2-on b)
+ #'(lambda (scr btn)
+ (if (and (enable-delete scr)
+ (confirm (concatenate 'string
+ "Delete " (label btn))))
+ (delete-button btn scr)))))
+
+;;;--------------------------------------
+
+(defun update-scrollbar (s)
+
+ (let ((s-ht (height s))
+ (bw-ht (clx:drawable-height (btn-win s))))
+ (setf (knob-scale (scrollbar s))
+ (float (min 1 (/ s-ht bw-ht))))
+ (setf (scroll-size (scrollbar s))
+ (if (<= bw-ht s-ht) 0
+ (/ (button-height s) (- bw-ht s-ht))))))
+
+;;;--------------------------------------
+
+(defmethod (setf items) (items (s scrolling-list))
+
+ "removes any buttons in scrolling list s and makes new buttons with
+labels from items, a list of strings."
+
+ (mapc #'destroy (buttons s))
+ (let ((button-y 0))
+ (setf (buttons s)
+ (mapcar #'(lambda (item)
+ (prog1
+ (make-list-button s item :ulc-y button-y)
+ (incf button-y (button-height s))))
+ items)))
+ (dolist (b (buttons s)) (init-button b s))
+ (clx:map-subwindows (btn-win s))
+ (update-scrollbar s)
+ (setf (setting (scrollbar s)) *scroll-maximum*))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((s scrolling-list)
+ &rest other-initargs
+ &key items
+ &allow-other-keys)
+
+ #| frames cannot be of height 0, so in the case that there are no
+ initial items we'll set the height to 1 pixel and just let
+ everthing be one pixel off (it won't be noticable) |#
+
+ (let* ((background-color (color-gc (bg-color s) (colormap s)))
+ (background (clx:gcontext-foreground background-color))
+ (btn-win-height))
+ (setf (button-height s) (+ (font-height (font s)) 10))
+ (setf (button-width s) (- (width s) *scrollbar-width*))
+ (setq btn-win-height (max 1 (* (button-height s) (length items))))
+ (setf (btn-win s) (clx:create-window :parent (window s)
+ :x *scrollbar-width*
+ :y 0
+ :width (button-width s)
+ :height btn-win-height
+ :depth *screen-root-depth*
+ :background background))
+ (clx:map-window (btn-win s))
+ (setf (scrollbar s) (make-scrollbar *scrollbar-width* (height s)
+ *scroll-minimum* *scroll-maximum*
+ :parent (window s)
+ :ulc-x 0 :ulc-y 0))
+ ;; as scrollbar moves down, btn-win moves up (and vice-versa)
+ (ev:add-notify s (value-changed (scrollbar s))
+ #'(lambda (sl sb setting)
+ (declare (ignore sb))
+ (setf (clx:drawable-y (btn-win sl))
+ (round (* (- (height sl)
+ (clx:drawable-height (btn-win sl)))
+ (- *scroll-maximum* setting))))
+ (clx:display-finish-output *display*)))
+ (when items (setf (items s) items))))
+
+;;;-------------------------------------
+
+(defun make-scrolling-list (width height &rest other-initargs)
+
+ "make-scrolling-list width height &rest other-initargs
+
+returns an instance of a scrolling list with the specified
+parameters."
+
+ (apply #'make-instance 'scrolling-list
+ :width width :height height
+ other-initargs))
+
+;;;--------------------------------------
+
+(defmethod destroy :before ((s scrolling-list))
+
+ "Destroys the buttons and scrollbar. It is up to the caller to take
+care of removing event notifications if necessary or turning buttons
+off first."
+
+ (mapc #'destroy (buttons s))
+ (destroy (scrollbar s))
+ (clx:destroy-window (btn-win s)))
+
+;;;--------------------------------------
+
+(defun make-and-insert-list-button (s label &rest other-args)
+
+ (let ((b (apply 'make-list-button s label other-args)))
+ (insert-button b s)
+ b))
+
+;;;--------------------------------------
+
+(defmethod insert-button ((b button) (s scrolling-list))
+
+ "insert-button b s
+
+inserts the button b, into the scrolling list s, at the end."
+
+ (init-button b s)
+ (setf (buttons s) (append (buttons s) (list b)))
+ (setf (clx:drawable-y (window b)) (clx:drawable-height (btn-win s)))
+ (clx:map-window (window b))
+ (incf (clx:drawable-height (btn-win s)) (button-height s))
+ (update-scrollbar s)
+ (ev:announce s (inserted s) b))
+
+;;;--------------------------------------
+
+(defmethod delete-button ((b button) (s scrolling-list))
+
+ "delete-button b s
+
+deletes the button b from the scrolling list s"
+
+ (let ((y-removed-at (clx:drawable-y (window b))))
+ (deselect-button b s)
+ (setf (buttons s) (remove b (buttons s)))
+ (destroy b)
+ (dolist (btn (buttons s))
+ (when (> (clx:drawable-y (window btn)) y-removed-at)
+ (decf (clx:drawable-y (window btn)) (button-height s))))
+ (decf (clx:drawable-height (btn-win s)) (button-height s))
+ (update-scrollbar s)
+ (ev:announce s (deleted s) b)))
+
+;;;--------------------------------------
+
+(defmethod select-button (b (s scrolling-list))
+
+ "select-button b s
+
+selects button b in scrolling-list s, i.e., adds the button to the
+selected button set, if not already selected."
+
+ (if (and (member b (buttons s))
+ (not (on b)))
+ (setf (on b) t)))
+
+;;;--------------------------------------
+
+(defmethod deselect-button (b (s scrolling-list))
+
+ "deselect-button b s
+
+deselects button b in scrolling-list s, i.e., removes the button from
+the selected button set, if it is on, i.e., selected."
+
+ (if (and (member b (buttons s))
+ (on b))
+ (setf (on b) nil)))
+
+;;;--------------------------------------
+
+(defun reorder-buttons (scr btn-list)
+
+ "reorder-buttons scr btn-list
+
+replaces the buttons in scr with btn-list, a reordered list of the
+SAME buttons, and updates the y coordinates of their windows to
+reflect the new order."
+
+ (let* ((bthgt (height (first (buttons scr))))
+ (bt-y (- bthgt)))
+ (setf (buttons scr) btn-list)
+ (mapc #'(lambda (bt)
+ (setf (clx:drawable-y (window bt)) (incf bt-y bthgt)))
+ (buttons scr))))
+
+;;;--------------------------------------
+
+(defclass radio-scrolling-list (scrolling-list)
+
+ () ;; no additional slots, just different actions for events
+
+ (:documentation "A radio-scrolling-list is a scrolling-list with the
+constraint that no more than one item can be selected at any time.")
+
+ )
+
+;;;------------------------------------
+
+(defun set-radio-button (b s)
+
+ "This function provides an action function for button-on that turns
+off any others when it is turned on."
+
+ (ev:add-notify s (button-on b)
+ #'(lambda (scr bt)
+ (setf (active bt) nil)
+ (mapc #'(lambda (other-b)
+ (when (and (on other-b)
+ (not (eq bt other-b)))
+ (setf (on other-b) nil)
+ (setf (active other-b) t)))
+ (buttons scr))
+ (ev:announce scr (selected scr) bt)))
+ (ev:add-notify s (button-off b)
+ #'(lambda (scr bt)
+ (setf (active bt) t)
+ (ev:announce scr (deselected scr) bt))))
+
+;;;--------------------------------------
+
+(defmethod (setf items) :after (items (r radio-scrolling-list))
+
+ (declare (ignore items))
+ (mapc #'(lambda (b) (set-radio-button b r)) (buttons r)))
+
+;;;--------------------------------------
+
+(defun make-radio-scrolling-list (width height &rest other-initargs)
+
+ "make-radio-scrolling-list width height &rest other-initargs
+
+Returns an instance of a scrolling-list that is constrained to have no
+more than one item selected at any time. When an item is selected, it
+deselects any other item that is selected."
+
+ (apply #'make-instance 'radio-scrolling-list
+ :width width :height height other-initargs))
+
+;;;------------------------------------
+
+(defmethod insert-button :after ((b button) (s radio-scrolling-list))
+
+ (set-radio-button b s))
+
+;;;--------------------------------------
+
+(defun popup-scroll-menu (items width height &rest initargs
+ &key multiple font &allow-other-keys)
+
+ "popup-scroll-menu items width height &rest initargs &key multiple
+
+displays a scrolling list of the items, a list of strings, at a nested
+event level so the user may choose one or more menu items. If
+multiple is nil, the default, then only one item can be selected and
+the function returns the item number. If multiple is not nil, then
+multiple selections are allowed and the function returns a list of
+item numbers. Since a scrolling list is limited by the X window
+address space, if the size of the items list is too large, a page
+button is included and the list is displayed a page at a time. The
+initargs are the usual SLIK frame parameters."
+
+ (push-event-level)
+ (let* ((ft (or font *default-font*)) ;; default for frames
+ (button-height (+ (font-height ft) *linespace*))
+ (maxitems (round (/ *scrollwindow-maxsize* button-height)))
+ (listsize (length items))
+ (offset 0)
+ ;; use only a page at a time from items if necessary
+ (current-page (if (< listsize maxitems) items
+ (subseq items 0 maxitems)))
+ (scrmenu (apply (if multiple #'make-scrolling-list
+ #'make-radio-scrolling-list)
+ width height :mapped nil
+ :items current-page
+ initargs))
+ (scrmenu-win (window scrmenu))
+ (button-width (+ 10 (clx:text-width ft "Accept")))
+ ;; compute menubox size from menu size and accept/cancel
+ ;; button sizes, and page button if needed
+ (boxwidth (max width (+ (* 2 button-width)
+ (if (< listsize maxitems) 20
+ (+ 30 button-width)))))
+ (boxheight (+ height button-height 10))
+ (menubox (apply #'make-frame boxwidth boxheight initargs))
+ (win (window menubox))
+ (left-x (round (/ (- boxwidth (* 2 button-width)
+ (if (< listsize maxitems) 10
+ (+ 20 button-width)))
+ 2)))
+ (ok-b (apply #'make-exit-button button-width button-height
+ :label "Accept" :parent win
+ :ulc-x left-x
+ :ulc-y (- boxheight button-height 5)
+ :bg-color 'green
+ initargs))
+ (can-b (apply #'make-exit-button button-width button-height
+ :label "Cancel" :parent win
+ :ulc-x (+ left-x button-width 10)
+ :ulc-y (- boxheight button-height 5)
+ initargs))
+ (page-b (unless (< listsize maxitems)
+ (apply #'make-button button-width button-height
+ :label "Page" :parent win
+ :ulc-x (+ left-x (* 2 (+ button-width 10)))
+ :ulc-y (- boxheight button-height 5)
+ :bg-color 'yellow
+ :button-type :momentary
+ initargs)))
+ (return-value nil))
+ (ev:add-notify menubox (button-on can-b)
+ #'(lambda (box btn)
+ (declare (ignore box btn))
+ (setq return-value nil)))
+ (ev:add-notify menubox (selected scrmenu)
+ #'(lambda (box scr btn)
+ (declare (ignore box))
+ ;; find out where in the list the selected
+ ;; button occurs and use that index
+ (let ((itemno (+ offset
+ (position btn (buttons scr)))))
+ (if multiple (push itemno return-value)
+ (setq return-value itemno)))))
+ (ev:add-notify menubox (deselected scrmenu)
+ #'(lambda (box scr btn)
+ (declare (ignore box))
+ (if multiple
+ (setq return-value
+ (remove (+ offset
+ (position btn (buttons scr)))
+ return-value)))))
+ (if page-b (ev:add-notify scrmenu (button-on page-b)
+ #'(lambda (s btn)
+ (declare (ignore btn))
+ ;; go to next page, or beginning of list
+ (setf offset (+ offset maxitems))
+ (if (> offset listsize)
+ (setq offset 0))
+ (setf current-page
+ (subseq items offset (min listsize
+ (+ offset
+ maxitems))))
+ ;; update scrolling list with new buttons
+ (setf (items s) current-page))))
+ (clx:reparent-window scrmenu-win win ;; center in x, at top for y
+ (round (/ (- boxwidth width) 2)) 0)
+ (refresh scrmenu)
+ (clx:map-window scrmenu-win)
+ (clx:map-subwindows scrmenu-win)
+ (clx:map-window (window (scrollbar scrmenu)))
+ (clx:map-subwindows (window (scrollbar scrmenu)))
+ (flush-output)
+ (process-events)
+ ;; don't neet remove-notify - we are destroying all the controls anyway
+ (destroy scrmenu)
+ (destroy ok-b)
+ (destroy can-b)
+ (if page-b (destroy page-b))
+ (destroy menubox)
+ (pop-event-level)
+ (if (listp return-value) (sort return-value #'<)
+ return-value)))
+
+;;;--------------------------------------
+;;; End.
diff --git a/slik/src/sliderboxes.cl b/slik/src/sliderboxes.cl
new file mode 100644
index 0000000..0c05e4c
--- /dev/null
+++ b/slik/src/sliderboxes.cl
@@ -0,0 +1,318 @@
+;;;
+;;; sliderboxes
+;;;
+;;; A sliderbox has a slider and a textline in it like a dialbox.
+;;;
+;;; 13-May-1992 I. Kalet created
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 27-May-1992 I. Kalet fix up type declarations
+;;; 6-Jul-1992 I. Kalet change be: to ev: and behavior to event
+;;; 29-Nov-1992 I. Kalet finish
+;;; 12-Feb-1993 I. Kalet squeeze and parametrize margins
+;;; 13-May-1994 I. Kalet add range checking with new textline code
+;;; 3-Jan-1995 I. Kalet remove proclaim form, take range checking out
+;;; of slider-update.
+;;; 3-Sep-1995 I. Kalet rearrange announce, etc. since textlines
+;;; don't announce when info is set - no need for busy flag. Also,
+;;; move most initialization to initialize-instance method so
+;;; subclasses don't duplicate it. This requires caching some
+;;; initialization parameters as local attributes.
+;;; 4-May-1997 I. Kalet don't overload the title attribute - add the
+;;; label attribute to be used in the textline. Don't use it in the
+;;; limit textlines in the adjustable sliderbox.
+;;; 15-Mar-1999 I. Kalet add display-limits attribute, default to t,
+;;; so backward compatible. Also, explicitly set slider border width,
+;;; so can make a sliderbox without border, but slider will still look ok.
+;;; 11-Mar-2001 I. Kalet explicitly set textline border style - it
+;;; does not default correctly.
+;;; 16-Aug-2002 J. Sager add label-slider-box class
+;;; 20-Sep-2002 I. Kalet a little cosmetic cleanup
+;;;
+
+(in-package :slik)
+
+;;;---------------------------------------------
+
+(defparameter *sx* 5 "Sliderbox left and right margins in pixels")
+
+(defparameter *sy* 5 "Sliderbox top margin in pixels")
+
+;;;---------------------------------------------
+
+(defclass sliderbox (frame)
+
+ ((sl-width :type clx:card16
+ :initarg :sl-width
+ :accessor sl-width
+ :documentation "Slider width - initialization parameter
+captured in call to make-instance.")
+
+ (sl-height :type clx:card16
+ :initarg :sl-height
+ :accessor sl-height
+ :documentation "Slider height - initialization parameter
+captured in call to make-instance.")
+
+ (sl-min :type single-float
+ :initarg :sl-min
+ :accessor sl-min
+ :documentation "Minimum value allowed - initialization
+parameter captured in call to make-instance.")
+
+ (sl-max :type single-float
+ :initarg :sl-max
+ :accessor sl-max
+ :documentation "Maximum value allowed - initialization
+parameter captured in call to make-instance.")
+
+ (display-limits :type (member t nil)
+ :initarg :display-limits
+ :accessor display-limits
+ :documentation "Flag to indicate whether to show
+the upper and lower limits, sl-max and sl-min.")
+
+ (digits :type single-float
+ :initarg :digits
+ :accessor digits
+ :documentation "The widest number that will appear in the
+textline, for sizing the textline - initialization parameter captured
+in call to make-instance.")
+
+ (the-slider :type slider
+ :accessor the-slider)
+
+ (the-text :type textline
+ :accessor the-text)
+
+ (label :type string
+ :initarg :label
+ :accessor label
+ :documentation "The label that appears in the textline.")
+
+ (min-x :type clx:card16
+ :accessor min-x
+ :documentation "Specifies location of text showing minimum
+value in slider - computed and cached")
+
+ (min-y :type clx:card16
+ :accessor min-y
+ :documentation "See min-x")
+
+ (max-x :type clx:card16
+ :accessor max-x
+ :documentation "Specifies location of text showing maximum
+value in slider - computed and cached")
+
+ (max-y :type clx:card16
+ :accessor max-y
+ :documentation "See max-x")
+
+ (value-changed :type ev:event
+ :accessor value-changed
+ :initform (ev:make-event)
+ :documentation "This event is for the sliderbox
+as a whole, not the individual components.")
+
+ )
+
+ (:default-initargs :label "" :display-limits t)
+
+ (:documentation "A sliderbox contains a slider and a textline,
+constrained so the textline displays the value on the slider, and the
+slider is set to the value typed in on the textline.")
+
+ )
+
+;;;------------------------------------------
+
+(defmethod minimum ((sb sliderbox))
+
+ (minimum (the-slider sb)))
+
+;;;------------------------------------------
+
+(defmethod maximum ((sb sliderbox))
+
+ (maximum (the-slider sb)))
+
+;;;------------------------------------------
+
+(defmethod refresh ((sb sliderbox))
+
+ "Draws the min and max labels if required."
+
+ (when (display-limits sb)
+ (clx:draw-glyphs (window sb) (gc-with-font (the-text sb))
+ (min-x sb) (min-y sb)
+ (format nil "~A" (minimum sb)))
+ (clx:draw-glyphs (window sb) (gc-with-font (the-text sb))
+ (max-x sb) (max-y sb)
+ (format nil "~A" (maximum sb)))))
+
+;;;------------------------------------------
+
+(defmethod setting ((sb sliderbox))
+
+ "Returns the current setting of the slider in the sliderbox."
+
+ (setting (the-slider sb)))
+
+;;;------------------------------------------
+
+(defmethod (setf setting) (new-setting (sb sliderbox))
+
+ "Sets the setting of the slider in the sliderbox."
+
+ (setf (setting (the-slider sb)) new-setting))
+
+;;;------------------------------------------
+
+(defun make-sliderbox (sl-width sl-height min max digits
+ &rest other-initargs
+ &key (font *default-font*)
+ &allow-other-keys)
+
+ "make-sliderbox sl-width sl-height min max digits
+ &rest other-initargs
+
+Returns an instance of a sliderbox with the specified parameters. The
+digits parameter is a number that is used to determine how big to make
+the textline, to accomodate the setting values to whatever significant
+digits are needed by the application."
+
+ (apply #'make-instance 'sliderbox
+ :sl-width sl-width :sl-height sl-height
+ :sl-min min :sl-max max :digits digits
+ :width (+ sl-width (* 2 *sx*))
+ ;; allow 5 pixels above and below textline, and same inside
+ ;; textline above and below the text, for total of 20
+ :height (+ *sy* sl-height (font-height font) 20)
+ other-initargs))
+
+;;;------------------------------------------
+
+(defmethod initialize-instance :after ((sb sliderbox)
+ &rest other-initargs)
+
+ (let* ((sl-height (sl-height sb))
+ (sl-width (sl-width sb))
+ (min (sl-min sb))
+ (max (sl-max sb))
+ (digits (digits sb))
+ (width (width sb))
+ (font (font sb))
+ (fh (font-height font))
+ (th (+ fh 10)) ;; textline height
+ (tw (+ (clx:text-width font (format nil "~A" digits))
+ (clx:text-width font (label sb))
+ 20)) ;; 10 pixels margin on each side
+ (win (window sb)))
+
+ (setf (the-slider sb) (apply #'make-slider
+ sl-width sl-height min max
+ :parent win
+ :ulc-x *sx* :ulc-y *sy*
+ :border-width 1
+ other-initargs)
+ (the-text sb) (apply #'make-textline tw th
+ :parent win
+ :ulc-x (round (/ (- width tw) 2))
+ :ulc-y (+ *sy* sl-height 5)
+ :border-width 1
+ :border-style
+ (if (eql *default-border-style* :flat)
+ :flat :lowered)
+ :numeric t :lower-limit min :upper-limit max
+ other-initargs) ;; includes label
+ (min-x sb) *sx*
+ (min-y sb) (+ (* 2 *sy*) sl-height fh)
+ (max-x sb) (- width *sx*
+ (if (typep sb 'label-sliderbox)
+ (clx:text-width font (format nil "~A"
+ (max-label sb)))
+ (clx:text-width font (format nil "~A" max))))
+ (max-y sb) (min-y sb))
+ (refresh sb)
+ (setf (info (the-text sb)) (setting sb))
+ (ev:add-notify sb (value-changed (the-slider sb))
+ #'(lambda (box sl val)
+ (declare (ignore sl))
+ (setf (info (the-text box)) val)
+ (ev:announce box (value-changed box) val)))
+ (ev:add-notify sb (new-info (the-text sb))
+ #'(lambda (box tl info)
+ (declare (ignore tl))
+ (setf (setting box) (read-from-string info))))))
+
+;;;------------------------------------------
+
+(defmethod destroy :before ((sb sliderbox))
+
+ "Destroys the slider and the textline first."
+
+ (destroy (the-slider sb))
+ (destroy (the-text sb)))
+
+;;;---------------------------------------------
+
+(defclass label-sliderbox (sliderbox)
+
+ ((min-label :type string
+ :initarg :min-label
+ :reader min-label
+ :documentation "The label that appears under the minimum.
+Not resetable.")
+ (max-label :type string
+ :initarg :max-label
+ :reader max-label
+ :documentation "The label that appears under the maximum.
+Not resettable.")
+
+ )
+
+ (:default-initargs :min-label "" :max-label "")
+
+ (:documentation "A label-sliderbox is just like a sliderbox, but it
+ displays a min-label and a max-label. Display limits is disabled.")
+
+)
+
+;;;---------------------------------------------
+
+(defun make-label-sliderbox (sl-width sl-height min max digits
+ &rest other-initargs
+ &key (font *default-font*)
+ &allow-other-keys)
+
+ "make-label-sliderbox sl-width sl-height min max digits min-digits
+ max-digits &rest other-initargs
+
+Returns an instance of a label-sliderbox with the specified parameters.
+The digits, min-digits, and max-digits parameters is a number that is
+used to determine how big to make the textline and labels, to accomodate the
+setting values to whatever significant digits are needed by the application."
+
+ (apply #'make-instance 'label-sliderbox
+ :sl-width sl-width :sl-height sl-height
+ :sl-min min :sl-max max :digits digits
+ :width (+ sl-width (* 2 *sx*))
+ ;; allow 5 pixels above and below textline, and same inside
+ ;; textline above and below the text, for total of 20
+ :height (+ *sy* sl-height (font-height font) 20)
+ other-initargs))
+
+;;;------------------------------------------
+
+(defmethod refresh ((sb label-sliderbox))
+
+ "Draws the min and max labels always."
+
+ (clx:draw-glyphs (window sb) (gc-with-font (the-text sb))
+ (min-x sb) (min-y sb)
+ (format nil "~A" (min-label sb)))
+ (clx:draw-glyphs (window sb) (gc-with-font (the-text sb))
+ (max-x sb) (max-y sb)
+ (format nil "~A" (max-label sb))))
+
+;;;------------------------------------------
+;;; End.
diff --git a/slik/src/sliders.cl b/slik/src/sliders.cl
new file mode 100644
index 0000000..e0417f2
--- /dev/null
+++ b/slik/src/sliders.cl
@@ -0,0 +1,307 @@
+;;;
+;;; sliders
+;;;
+;;; A slider has a rectangular knob that moves along a track, and
+;;; adjusts a real value (float) similarly to the dial, but with
+;;; range specified by two parameters, for the upper and lower end.
+;;;
+;;; 26-Apr-1992 I. Kalet written
+;;; 27-Apr-1992 I. Kalet minor adjustments
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 27-May-1992 I. Kalet fix up type declarations
+;;; 6-Jul-1992 I. Kalet change be: to ev: and behavior to event
+;;; 8-Oct-1992 I. Kalet change defsetf setting to
+;;; defmethod (setf setting)
+;;; 25-Oct-1992 I. Kalet eliminate pixmap, fix up refresh
+;;; 29-Nov-1992 I. Kalet fix up method for setf setting, fix knob initargs
+;;; 21-Apr-1994 J. Unger put scale-factor and slot-zero initialization code
+;;; in its own function, since it's called elsewhere (adj-sliderboxes).
+;;; 25-Apr-1994 J. Unger omit some unused variables in init-inst.
+;;; 3-Jan-1995 I. Kalet remove proclaim form
+;;; 3-Sep-1995 I. Kalet enforce single-float for setting
+;;; 26-Aug-1998 M. Lease revamped while adding support for scrollbars.
+;;; 3-Nov-1998 I. Kalet make maximum and minimum accessors instead of
+;;; readers.
+;;; 12-Jan-1999 I. Kalet always coerce new setting value in setf
+;;; method, and continue to announce value-changed even when value is
+;;; the same.
+;;; 2-Apr-1999 C. Wilcox enabled event look-ahead for slider drags.
+;;; 23-Apr-1999 I. Kalet changes for multiple colormaps.
+;;;
+
+(in-package :slik)
+
+;;;------------------------------------------
+
+(defconstant *knob-thickness* (/ 2 3))
+(defconstant *slot-offset* 5)
+(defconstant *slot-thickness* (/ 1 6))
+(defconstant *default-knob-scale* 0.03)
+
+;;;------------------------------------------
+
+(defclass slider (frame)
+
+ ((setting :type single-float
+ :accessor setting
+ :initarg :setting
+ :documentation "The slider's current setting")
+
+ (minimum :type single-float
+ :accessor minimum
+ :initarg :minimum)
+
+ (maximum :type single-float
+ :accessor maximum
+ :initarg :maximum)
+
+ (orient :type (member :horizontal :vertical)
+ :reader orient
+ :initarg :orient
+ :initform :horizontal
+ :documentation "Values increase left-to-right for
+horizontal sliders, bottom-to-top for vertical sliders.")
+
+ (knob-scale :type single-float
+ :accessor knob-scale
+ :initarg :knob-scale
+ :initform *default-knob-scale*
+ :documentation "Positive float <= 1.0 describing ratio of
+knob size to slot size.")
+
+ (knob-width :type clx:card16
+ :accessor knob-width)
+
+ (knob-height :type clx:card16
+ :accessor knob-height)
+
+ (slot-ulc-x :type clx:card16
+ :accessor slot-ulc-x)
+
+ (slot-ulc-y :type clx:card16
+ :accessor slot-ulc-y)
+
+ (slot-width :type clx:card16
+ :accessor slot-width)
+
+ (slot-height :type clx:card16
+ :accessor slot-height)
+
+ (drag-offset :type fixnum
+ :accessor drag-offset)
+
+ (dragging-knob :type (member t nil)
+ :accessor dragging-knob
+ :initform nil
+ :documentation "Flag indicating whether the user is
+currently dragging the knob.")
+
+ (value-changed :type ev:event
+ :accessor value-changed
+ :initform (ev:make-event))
+
+ )
+
+ (:default-initargs :title "SLIK slider")
+
+ (:documentation "A slider provides a control for manipulating a real
+or integer value.")
+ )
+
+;;;------------------------------------------
+
+(defun make-slider (width height min max &rest other-initargs)
+
+ (let ((s (apply 'make-instance 'slider :width width :height height
+ :minimum min :maximum max other-initargs)))
+ (push :motion-notify (look-ahead s))
+ (refresh s)
+ s))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((s slider) &rest other-initargs)
+
+ (declare (ignore other-initargs))
+ (if (eq (orient s) :vertical)
+ (progn
+ (setf (knob-width s) (round (* (width s) *knob-thickness*)))
+ (setf (slot-width s) (round (* (width s) *slot-thickness*)))
+ (setf (slot-height s) (- (height s) (* *slot-offset* 2))))
+ (progn
+ (setf (knob-height s) (round (* (height s) *knob-thickness*)))
+ (setf (slot-width s) (- (width s) (* *slot-offset* 2)))
+ (setf (slot-height s) (round (* (height s) *slot-thickness*)))))
+ (setf (slot-ulc-x s) (round (/ (- (width s) (slot-width s)) 2)))
+ (setf (slot-ulc-y s) (round (/ (- (height s) (slot-height s)) 2)))
+ (unless (slot-boundp s 'setting)
+ (setf (slot-value s 'setting) (/ (+ (maximum s) (minimum s)) 2.0)))
+ (scale-knob s))
+
+;;;------------------------------------------
+
+(defmethod (setf setting) :around (new-setting (s slider))
+
+ (setq new-setting (coerce new-setting 'single-float))
+ (unless (= new-setting (setting s))
+ (erase-knob s)
+ (if (> new-setting (maximum s)) (setq new-setting (maximum s)))
+ (if (< new-setting (minimum s)) (setq new-setting (minimum s)))
+ (setf (slot-value s 'setting) new-setting)
+ (slider-draw s))
+ (ev:announce s (value-changed s) new-setting)
+ new-setting)
+
+;;;------------------------------------------
+
+(defun knob-ulc-x (s)
+
+ (if (eq (orient s) :vertical)
+ (round (/ (- (width s) (knob-width s)) 2))
+ (+ (slot-ulc-x s) (knob-offset s))))
+
+;;;------------------------------------------
+
+(defun knob-ulc-y (s)
+
+ (if (eq (orient s) :vertical)
+ (- (height s) *slot-offset* (knob-offset s) (knob-height s))
+ (round (/ (- (height s) (knob-height s)) 2))))
+
+;;;------------------------------------------
+
+(defun knob-offset (s)
+
+ (round (* (/ (- (setting s) (minimum s))
+ (- (maximum s) (minimum s)))
+ (knob-range s))))
+
+;;;------------------------------------------
+
+(defun knob-range (s)
+
+ (if (eq (orient s) :vertical)
+ (- (slot-height s) (knob-height s))
+ (- (slot-width s) (knob-width s))))
+
+;;;------------------------------------------
+
+(defmethod (setf knob-scale) :around (new-scale (s slider))
+
+ (erase-knob s)
+ (call-next-method)
+ (scale-knob s)
+ (slider-draw s)
+ new-scale)
+
+;;;------------------------------------------
+
+(defun scale-knob (s)
+
+ (if (eq (orient s) :vertical)
+ (setf (knob-height s) (round (* (slot-height s) (knob-scale s))))
+ (setf (knob-width s) (round (* (slot-width s) (knob-scale s))))))
+
+;;;------------------------------------------
+
+(defmethod refresh :before ((s slider))
+
+ (slider-draw s))
+
+;;;------------------------------------------
+
+(defun erase-knob (s)
+
+ "erase-knob s
+
+replaces the knob with the background color. This function used instead
+of 'erase' in order to avoid flickering."
+
+ (clx:draw-rectangle (window s)
+ (color-gc (bg-color s) (colormap s))
+ (knob-ulc-x s) (knob-ulc-y s)
+ (knob-width s) (knob-height s)
+ t))
+
+;;;------------------------------------------
+
+(defun slider-draw (s)
+
+ (clx:draw-rectangle (window s)
+ (color-gc (fg-color s) (colormap s))
+ (slot-ulc-x s) (slot-ulc-y s)
+ (slot-width s) (slot-height s)
+ nil)
+ (clx:draw-rectangle (window s)
+ (color-gc (fg-color s) (colormap s))
+ (knob-ulc-x s) (knob-ulc-y s)
+ (knob-width s) (knob-height s)
+ t)
+ (flush-output))
+
+;;;------------------------------------------
+
+(defmethod process-button-press ((s slider) button-id x y)
+
+ (when (and (= button-id *button-1*) (plusp (knob-range s)))
+ (setf (dragging-knob s) t)
+ (if (is-pt-in-rect x y (knob-ulc-x s) (knob-ulc-y s)
+ (knob-width s) (knob-height s))
+ (setf (drag-offset s) (if (eq (orient s) :vertical)
+ (- y (knob-ulc-y s))
+ (- x (knob-ulc-x s))))
+ (progn
+ (setf (drag-offset s) 0)
+ (update-setting s x y))))
+ nil)
+
+;;;------------------------------------------
+
+(defmethod process-motion-notify ((s slider) x y state)
+
+ (declare (ignore state))
+ (when (dragging-knob s)
+ (update-setting s x y))
+ nil)
+
+;;;------------------------------------------
+
+(defmethod process-button-release ((s slider) button-id x y)
+
+ (declare (ignore x y))
+ (when (= button-id *button-1*)
+ (setf (dragging-knob s) nil))
+ nil)
+
+;;;------------------------------------------
+
+(defun update-setting (s x y)
+
+ (let ((knob-offset (restrict-range
+ (if (eq (orient s) :vertical)
+ (+ (- (height s) *slot-offset* y
+ (knob-height s)) (drag-offset s))
+ (- x *slot-offset* (drag-offset s)))
+ 0 (knob-range s))))
+ (setf (setting s)
+ (+ (minimum s) (* (/ knob-offset (knob-range s))
+ (- (maximum s) (minimum s)))))))
+
+;;;------------------------------------------
+
+;;; ### this is much too general to be here
+
+(defun is-pt-in-rect (x y ulc-x ulc-y width height)
+
+ (and (>= x ulc-x) (>= y ulc-y)
+ (<= x (+ ulc-x width)) (<= y (+ ulc-y height))))
+
+;;;------------------------------------------
+
+;;; ### this is much too general to be here
+
+(defun restrict-range (val minimum maximum)
+ (max (min val maximum) minimum))
+
+;;;------------------------------------------
+;;; End.
diff --git a/slik/src/slik.cl b/slik/src/slik.cl
new file mode 100644
index 0000000..c9066e5
--- /dev/null
+++ b/slik/src/slik.cl
@@ -0,0 +1,124 @@
+;;;
+;;; slik
+;;;
+;;; contains the definition of the slik package and any other
+;;; initializations for it.
+;;;
+;;; 30-Jul-2003 I. Kalet derived from slik-system
+;;; 21-Jun-2004 I. Kalet put CLX nickname here - it belongs with SLIK
+;;; 16-Jul-2004 BobGian add IN-PACKAGE form - silences compiler complaint.
+;;; 31-Jan-2005 A. Simms removed in-package call
+;;; 22-Mar-2007 I. Kalet put require :clx here so don't need to
+;;; preload in the lisp image.
+;;; 26-Jun-2009 I. Kalet wrap require in eval-when to avoid warning,
+;;; also add require acldns for standalone image build
+;;; 16-Jul-2011 I. Kalet add require :xcw for allegro, to load
+;;; open-display-with-auth function that handles non-zero display no.
+;;;
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+allegro (require :xcw) ;; also loads clx
+ #-allegro (require :clx))
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (require :acldns)) ;; autoload needed for non-local X connection
+
+;;;-------------------------------------
+;;; In most lisps, must add CLX as nickname to XLIB.
+
+#+(or allegro cmu clisp)
+(rename-package "XLIB" "XLIB"
+ (cons "CLX" (package-nicknames
+ (find-package "XLIB"))))
+
+;;;-------------------------------------
+
+(defpackage "SLIK"
+ (:nicknames "SL")
+ (:use "COMMON-LISP")
+ (:export "*BG-LEVEL*" "*DEFAULT-BORDER-STYLE*"
+ "*DEFAULT-FONT-NAME*" "*FG-LEVEL*" "*NUM-GRAY-PIXELS*"
+ "ACKNOWLEDGE" "ACTIVE" "ADD-PICKABLE-OBJ"
+ "ALLOW-BUTTON-2" "ANGLE"
+ "ASSIGN-GRAY-PIXELS"
+ "BG-COLOR" "BG-GRAY" "BLACK" "BLACK-DASHED" "BLUE"
+ "BLUE-DASHED" "BORDER-COLOR" "BORDER-WIDTH"
+ "BUTTON-2-ON"
+ "BUTTON-HEIGHT" "BUTTON-OFF" "BUTTON-ON"
+ "BUTTON-PRESS" "BUTTON-RELEASE" "BUTTON-WIDTH"
+ "BUTTONS"
+ "CELL-OBJECT" "COLOR" "COLOR-GC" "COLORMAP"
+ "CONFIRM" "CONFIRM-EXIT" "CONTENTS"
+ "COURIER-BOLD-12" "COURIER-BOLD-14"
+ "COURIER-BOLD-18"
+ "CYAN" "CYAN-DASHED"
+ "DELETE-BUTTON" "DELETED"
+ "DEQUEUE-BG-EVENT" "DESELECT-BUTTON"
+ "DESELECTED" "DESTROY" "DISPLAY-PICTURE"
+ "DRAW-BORDER" "DRAW-PLOT-LINES"
+ "ENABLED" "ENTER-NOTIFY" "ENQUEUE-BG-EVENT"
+ "ERASE" "ERASE-BG"
+ "ERASE-CONTENTS" "EXPOSURE"
+ "FG-COLOR" "FILLED" "FIND-PICKABLE-OBJS"
+ "FIND-DASHED-COLOR" "FIND-SOLID-COLOR"
+ "FLUSH-OUTPUT" "FONT" "FONT-HEIGHT" "FRAME"
+ "GET-Z-ARRAY" "GL-COLOR" "GRAY" "GRAY-DASHED"
+ "GREEN" "GREEN-DASHED"
+ "HEIGHT" "HELVETICA-BOLD-12" "HELVETICA-BOLD-14"
+ "HELVETICA-BOLD-18" "HELVETICA-MEDIUM-12"
+ "HELVETICA-MEDIUM-14" "HELVETICA-MEDIUM-18" "HOST"
+ "INFO" "INITIALIZE" "INSERT-BUTTON" "INSERTED"
+ "INVISIBLE" "ITEMS"
+ "KEY-PRESS" "KNOB-SCALE"
+ "LABEL" "LEAVE-NOTIFY"
+ "MAGENTA" "MAGENTA-DASHED"
+ "MAKE-2D-PLOT"
+ "MAKE-ADJUSTABLE-SLIDERBOX" "MAKE-ARROW-BUTTON"
+ "MAKE-BUTTON" "MAKE-CIRCLE"
+ "MAKE-DIAL" "MAKE-DIALBOX"
+ "MAKE-DUPLICATE-GC" "MAKE-EXIT-BUTTON"
+ "MAKE-FRAME" "MAKE-GRAYMAP" "MAKE-GL-BUFFER"
+ "MAKE-ICON-BUTTON" "MAKE-LABEL-SLIDERBOX"
+ "MAKE-LIST-BUTTON"
+ "MAKE-AND-INSERT-LIST-BUTTON"
+ "MAKE-MENU" "MAKE-PICTURE" "MAKE-PRIMARY-GC"
+ "MAKE-RADIO-MENU"
+ "MAKE-RADIO-SCROLLING-LIST" "MAKE-RAW-GRAYMAP"
+ "MAKE-READOUT" "MAKE-RECTANGLE" "MAKE-SCROLLBAR"
+ "MAKE-SCROLLING-LIST" "MAKE-SEGMENT"
+ "MAKE-SLIDER" "MAKE-SLIDERBOX" "MAKE-SPREADSHEET"
+ "MAKE-SQUARE" "MAKE-SQUARE-PIXMAP" "MAKE-TEXTBOX"
+ "MAKE-TEXTLINE"
+ "MAP-IMAGE" "MAP-RAW-IMAGE"
+ "MAXIMUM" "MAXIMUM-CHANGED" "MINIMUM"
+ "MINIMUM-CHANGED" "MOTION" "MOTION-NOTIFY"
+ "NEW-INFO" "NEW-SLIDER-VAL"
+ "OBJECT" "ON"
+ "PICTURE" "PICK-LIST" "PIXMAP"
+ "POINT-NEAR-SEGMENT" "POP-EVENT-LEVEL"
+ "POPUP-COLOR-MENU" "POPUP-MENU"
+ "POPUP-SCROLL-MENU" "POPUP-TEXTBOX"
+ "POPUP-TEXTLINE" "PRINT-2DPLOT"
+ "PROCESS-EVENTS" "PUSH-EVENT-LEVEL"
+ "RED" "RED-DASHED" "REMOVE-PICKABLE-OBJS"
+ "REMOVE-SERIES" "REORDER-BUTTONS"
+ "SCHOOLBOOK-BOLD-12" "SCHOOLBOOK-BOLD-14"
+ "SCHOOLBOOK-BOLD-18" "SELECT-BUTTON" "SELECT-GL"
+ "SELECTED" "SET-BUTTON" "SET-CONTENTS" "SETTING"
+ "SPREADSHEET" "SERIES-COLL"
+ "TERMINATE" "THICKNESS" "TIMES-BOLD-12"
+ "TIMES-BOLD-14" "TIMES-BOLD-18"
+ "TITLE" "TOLERANCE"
+ "ULC-X" "ULC-Y" "UPDATE-PICKABLE-OBJECT"
+ "UPDATE-SERIES" "USER-INPUT"
+ "VALUE-CHANGED"
+ "WHITE" "WHITE-DASHED" "WIDTH" "WINDOW"
+ "WRITE-IMAGE-CLX" "WRITE-IMAGE-GL"
+ "X1" "X2" "X-CENTER" "X-SLIDER-VAL"
+ "Y-SLIDER-VAL"
+ "Y1" "Y2" "Y-CENTER" "YELLOW" "YELLOW-DASHED"
+ ))
+
+;;;-------------------------------------
+;;; End.
diff --git a/slik/src/spreadsheets.cl b/slik/src/spreadsheets.cl
new file mode 100644
index 0000000..f6e6e8b
--- /dev/null
+++ b/slik/src/spreadsheets.cl
@@ -0,0 +1,289 @@
+;;;
+;;; spreadsheets - a first cut at a general spreadsheet facility for
+;;; use in the Prism system.
+;;;
+;;; 1-Sep-1997 I. Kalet started from point dose panels.
+;;; 24-Sep-1997 I. Kalet continuing design.
+;;; 10-Dec-1997 I. Kalet move to the SLIK package.
+;;; 23-Dec-1997 I. Kalet simplify and build.
+;;; 27-Feb-1998 I. Kalet add 5 pixel borders and make arrow buttons a
+;;; little smaller than their cell size. Add some convenience
+;;; functions.
+;;; 19-Dec-1999 I. Kalet pass on initargs of spreadsheet to individual
+;;; cell widgets, with cell specs superceding any duplicate initargs.
+;;; 25-Apr-2000 I. Kalet add cell-object function, to access the
+;;; widget of a cell, e.g., to change the fg or bg color.
+;;; 4-Feb-2001 I. Kalet enforce border style :flat for readouts, and
+;;; adaptive for textlines, otherwise otherargs makes it :raised
+;;; 5-May-2002 I. Kalet add an announcement for button-off as well as
+;;; button-on for the various button types.
+;;;
+
+(in-package :slik)
+
+;;;---------------------------------------------
+
+(defclass spreadsheet (frame)
+
+ ((cells :accessor cells
+ :documentation "An array of the widgets that appear on the
+spreadsheet panel, to display and modify some or all of the values.
+There can be more or less or the same number of cells as values to be
+controlled, but the cells are fixed in position on the panel, and the
+assignment of values to cells may change during use.")
+
+ (row-heights :accessor row-heights
+ :initarg :row-heights
+ :documentation "A list of row heights in pixels.")
+
+ (col-widths :accessor col-widths
+ :initarg :col-widths
+ :documentation "A list of column widths in pixels.")
+
+ (cell-specs :accessor cell-specs
+ :initarg :cell-specs
+ :documentation "An array of cell specifications, each
+of which may be nil for an empty cell, or a list of information to be
+used to create the cell at that position in the spreadsheet. This
+list contains in order, the keyword identifying the cell type, the
+initial contents, and if the cell type is numeric, there should be two
+additional values, the lower limit and the upper limit.")
+
+ (user-input :accessor user-input
+ :initform (ev:make-event)
+ :documentation "Announced when any widget that can
+accept user input actually receives some user input, i.e., the user
+presses a button or enters a new value in a textline and presses the
+RETURN key.")
+
+ )
+
+ (:default-initargs :title "SLIK spreadsheet")
+
+ (:documentation "A general purpose spreadsheet facility.")
+
+ )
+
+;;;---------------------------------------------
+
+(defun make-spreadsheet (row-hgts col-wds cell-specs &rest pars)
+
+ (apply #'make-instance 'spreadsheet
+ :width (apply #'+ 10 col-wds)
+ :height (apply #'+ 10 row-hgts)
+ :row-heights row-hgts
+ :col-widths col-wds
+ :cell-specs cell-specs
+ pars))
+
+;;;---------------------------------------------
+
+(defmethod initialize-instance :after ((pan spreadsheet)
+ &rest initargs)
+
+ (let* ((win (window pan))
+ (hgts (row-heights pan))
+ (wids (col-widths pan))
+ (rows (length hgts))
+ (cols (length wids))
+ (specs (cell-specs pan))
+ (cells (make-array (list rows cols) :initial-element nil))
+ (x 5)
+ (y 5))
+ (setf (cells pan) cells)
+ ;; go through the lists and make all the widgets
+ (dotimes (i rows)
+ (let ((hgt (nth i hgts))
+ (local-i i))
+ (dotimes (j cols)
+ (let ((wid (nth j wids))
+ (cell-spec (aref specs i j)))
+ (when cell-spec
+ (let ((cell-type (first cell-spec))
+ (init-info (second cell-spec))
+ (ll (third cell-spec))
+ (ul (fourth cell-spec))
+ (otherargs (append (nthcdr 4 cell-spec) initargs))
+ (local-j j))
+ (setf (aref cells i j)
+ (case cell-type
+ (:label (apply #'make-readout wid hgt
+ :ulc-x x :ulc-y y :parent win
+ :info init-info
+ :border-width 0
+ otherargs))
+ (:readout (apply #'make-readout wid hgt
+ :ulc-x x :ulc-y y :parent win
+ :border-style :flat
+ otherargs))
+ (:text (apply #'make-textline wid hgt
+ :ulc-x x :ulc-y y :parent win
+ :border-style
+ (if (eql *default-border-style* :flat)
+ :flat :lowered)
+ otherargs))
+ (:number (apply #'make-textline wid hgt
+ :ulc-x x :ulc-y y :parent win
+ :numeric t
+ :lower-limit ll :upper-limit ul
+ :border-style
+ (if (eql *default-border-style* :flat)
+ :flat :lowered)
+ otherargs))
+ (:button (apply #'make-button wid hgt
+ :label init-info
+ :ulc-x x :ulc-y y :parent win
+ otherargs))
+ (:left-arrow (apply #'make-arrow-button
+ (- wid 10) (- hgt 10)
+ :left
+ :ulc-x (+ x 5) :ulc-y (+ y 5)
+ :parent win
+ otherargs))
+ (:right-arrow (apply #'make-arrow-button
+ (- wid 10) (- hgt 10)
+ :right
+ :ulc-x (+ x 5) :ulc-y (+ y 5)
+ :parent win
+ otherargs))
+ (:up-arrow (apply #'make-arrow-button
+ (- wid 10) (- hgt 10)
+ :up
+ :ulc-x (+ x 5) :ulc-y (+ y 5)
+ :parent win
+ otherargs))
+ (:down-arrow (apply #'make-arrow-button
+ (- wid 10) (- hgt 10)
+ :down
+ :ulc-x (+ x 5) :ulc-y (+ y 5)
+ :parent win
+ otherargs))))
+ ;; the following was deferred so that init-info will
+ ;; not be centered in these cases
+ (if (and (member cell-type '(:readout :text :number))
+ init-info)
+ (setf (info (aref cells i j)) init-info))
+ (case cell-type
+ (:text
+ (ev:add-notify pan (new-info (aref cells i j))
+ #'(lambda (pnl wdgt newstuff)
+ (declare (ignore wdgt))
+ (ev:announce pnl (user-input pnl)
+ local-i local-j
+ newstuff))))
+ (:number
+ (ev:add-notify pan (new-info (aref cells i j))
+ #'(lambda (pnl wdgt newstuff)
+ (declare (ignore wdgt))
+ (ev:announce pnl (user-input pnl)
+ local-i local-j
+ (read-from-string
+ newstuff)))))
+ ((:button :left-arrow :right-arrow
+ :up-arrow :down-arrow)
+ (ev:add-notify pan (button-off (aref cells i j))
+ #'(lambda (pnl wdgt)
+ (declare (ignore wdgt))
+ (ev:announce pnl (user-input pnl)
+ local-i local-j 0)))
+ (ev:add-notify pan (button-on (aref cells i j))
+ #'(lambda (pnl wdgt)
+ (declare (ignore wdgt))
+ (ev:announce pnl (user-input pnl)
+ local-i local-j 1)))
+ (ev:add-notify pan (button-2-on (aref cells i j))
+ #'(lambda (pnl wdgt)
+ (declare (ignore wdgt))
+ (ev:announce pnl (user-input pnl)
+ local-i local-j 2)))
+ ))))
+ (incf x wid))) ;; for next widget in row
+ (incf y hgt) ;; for next row
+ (setf x 5) ;; start at beginning of row
+ ))))
+
+;;;---------------------------------------------
+
+(defmethod destroy :before ((pan spreadsheet))
+
+ "Releases X resources used by this panel."
+
+ (let ((cell-array (cells pan)))
+ (dotimes (i (length (row-heights pan)))
+ (dotimes (j (length (col-widths pan)))
+ (let ((cell (aref cell-array i j)))
+ (if cell (destroy cell)))))))
+
+;;;---------------------------------------------
+
+(defun contents (sheet row col)
+
+ "contents sheet row col
+
+returns the contents of the widget in spreadsheet sheet at place row,
+col. If the widget is a button, the label is returned, if it is a
+textline or readout, the info is returned. Other widget types are
+ignored."
+
+ (let ((widget (aref (cells sheet) row col)))
+ (cond ((typep widget 'readout) (info widget))
+ ((typep widget 'button) (label widget))
+ (t nil))))
+
+;;;---------------------------------------------
+
+(defun set-contents (sheet row col newval)
+
+ "set-contents sheet row col newval
+
+updates the contents of the widget in spreadsheet sheet at place row,
+col. The newval parameter should be a string. If the widget is a
+button, the label is updated, if it is a textline or readout, the info
+is updated. Other widget types are ignored."
+
+ (let ((widget (aref (cells sheet) row col)))
+ (cond ((typep widget 'readout)
+ (setf (info widget) newval))
+ ((typep widget 'button)
+ (setf (label widget) newval))
+ (t nil))))
+
+;;;---------------------------------------------
+
+(defun erase-contents (sheet row col)
+
+ "erase-contents sheet row col
+
+erases the readout or textline in position row, col to blank, and
+resets the border color if a textline."
+
+ (let ((tl (aref (cells sheet) row col)))
+ (setf (info tl) "")
+ (erase tl) ;; border width otherwise not reset right
+ (when (typep tl 'textline)
+ (setf (border-width tl) (border-width-cache tl))
+ (setf (border-color tl) (border-color-cache tl)))))
+
+;;;---------------------------------------------
+
+(defun set-button (sheet row col newval)
+
+ "set-button sheet row col newval
+
+sets the button at row, col to on or off according as newval is
+non-nil or nil."
+
+ (setf (on (aref (cells sheet) row col)) newval))
+
+;;;---------------------------------------------
+
+(defun cell-object (sheet i j)
+
+ "cell-object sheet i j
+
+returns the actual SLIK widget in spreadsheet sheet at position i,j"
+
+ (aref (cells sheet) i j))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/slik/src/textboxes.cl b/slik/src/textboxes.cl
new file mode 100644
index 0000000..0c0389f
--- /dev/null
+++ b/slik/src/textboxes.cl
@@ -0,0 +1,317 @@
+;;;
+;;; textboxes
+;;;
+;;; A textbox is a very simple screen-oriented editing facility, for
+;;; editing multiple lines of text.
+;;;
+;;; 13-May-1994 J. Unger implemented
+;;; 18-May-1994 I. Kalet fix default initarg for info, provide an
+;;; event to notify when text changes.
+;;; 19-May-1994 J. Unger add setf method for info attribute.
+;;; 26-Jul-1994 J. Unger fix calls to flush-output (take no parameters).
+;;; 03-Oct-1994 J. Unger add 'ENTER' as synonym for 'RETURN' key.
+;;; 29-Jan-1995 I. Kalet definitions of keysym constants moved to
+;;; clx-support, correct omission of default for info keyword
+;;; 31-Jan-1996 I. Kalet delete extra values allegedly returned by
+;;; keycode->character in process-hey-press.
+;;; 23-Apr-1999 I. Kalet changes to support multiple colormaps.
+;;; 27-May-2000 I. Kalet compute cursor x position from current text
+;;; using clx:text-width, not max, to accomodate proportional fonts.
+;;; 26-Nov-2000 I. Kalet change default border-style to :lowered
+;;; 11-Mar-2001 I. Kalet make default border-style adaptive to general
+;;; default, if flat, make textboxes flat too, otherwise lowered.
+;;; 14-Mar-2002 I. Kalet add another slot, scroll, that when nil does
+;;; not allow additional lines that would be outside the visible
+;;; region of the textbox.
+;;; 2-Jul-2004 I. Kalet fix error in insert-line that allows new
+;;; lines in the middle exceeding the space even when scroll is nil.
+;;;
+
+(in-package :slik)
+
+;;;--------------------------------------
+
+(defclass textbox (frame)
+
+ ((info :type list
+ :accessor info
+ :initarg :info
+ :documentation "A list of strings, the data being edited.")
+
+ (new-info :type ev:event
+ :accessor new-info
+ :initform (ev:make-event)
+ :documentation "Announced whenever any text is changed,
+i.e., new characters, delete characters, new line, delete line, but
+not cursor motion.")
+
+ (row-height :type fixnum
+ :accessor row-height
+ :documentation "The height of a line of text.")
+
+ (row-offset :type fixnum
+ :accessor row-offset
+ :initarg row-offset
+ :documentation "The row number of the first visible row.")
+
+ (gc-with-font :accessor gc-with-font
+ :initform (make-duplicate-gc)
+ :documentation "A cached graphic context for drawing
+in the font for this textbox instead of the default font. Much faster
+than using the with-gcontext macro.")
+
+ (cursor-row :type fixnum
+ :accessor cursor-row
+ :initarg :cursor-row
+ :documentation "Cursor row number. Updated when cursor
+is moved up or down.")
+
+ (scroll :accessor scroll
+ :initarg :scroll
+ :documentation "If nil, the text lines do not move up or
+ down and no additional lines are accepted beyond those visible.")
+
+ )
+ (:default-initargs :title "Text input" :info '("")
+ :cursor-row 0 :row-offset 0 :scroll t
+ :border-style (if (eql *default-border-style* :flat)
+ :flat :lowered))
+
+ (:documentation "A textbox is a simple screen-oriented text editor.")
+ )
+
+;;;--------------------------------------
+
+(defmethod (setf info) :after (new-info (tb textbox))
+
+ "Resets the textbox to an initial state if new info is submitted to
+it. Adjusts the cursor column so that it is always at the end of the
+first row. Also erases & refreshes tb to display new info."
+
+ (declare (ignore new-info))
+ (setf (row-offset tb) 0)
+ (setf (cursor-row tb) 0)
+ (erase tb)
+ (refresh tb))
+
+;;;--------------------------------------
+
+(defmethod initialize-instance :after ((tb textbox) &rest initargs)
+
+ (declare (ignore initargs))
+ (setf (row-height tb) (+ (font-height (font tb)) 6))
+ (clx:copy-gcontext (color-gc (fg-color tb) (colormap tb))
+ (gc-with-font tb))
+ (setf (clx:gcontext-font (gc-with-font tb)) (font tb))
+ (setf (row-offset tb) 0)
+ (setf (cursor-row tb) 0))
+
+;;;--------------------------------------
+
+(defun draw-textbox-cursor (tb color)
+
+ (let* ((h (row-height tb))
+ (fac (truncate h 4))
+ (x (+ 11 (clx:text-width (font tb)
+ (nth (+ (row-offset tb) (cursor-row tb))
+ (info tb)))))
+ (y (* (cursor-row tb) (row-height tb))))
+ (clx:draw-line (window tb) color x (+ y fac) x (+ y h fac))))
+
+;;;--------------------------------------
+
+(defmethod refresh :after ((tb textbox))
+
+ "Draw the lines of info and the cursor."
+
+ (let* ((win (window tb))
+ (gc (gc-with-font tb))
+ (h (row-height tb))
+ (y h))
+ (dolist (line (subseq (info tb) (row-offset tb)))
+ (clx:draw-glyphs win gc 10 y line)
+ (incf y h))
+ (draw-textbox-cursor tb gc)))
+
+;;;--------------------------------------
+
+(defun move-textbox-cursor (tb direction)
+
+ "move-textbox-cursor tb direction
+
+Moves textbox tb's cursor either in the specified direction, one of
+:up or :down. The cursor is placed at the end of the line to which it
+is moved."
+
+ (draw-textbox-cursor tb (color-gc (bg-color tb) (colormap tb)))
+ (case direction
+ (:up (if (plusp (cursor-row tb))
+ (decf (cursor-row tb))
+ (unless (zerop (row-offset tb))
+ (decf (row-offset tb))
+ (erase tb)
+ (refresh tb))))
+ (:down (when (< (cursor-row tb)
+ (- (length (info tb)) (row-offset tb) 1))
+ (if (< (cursor-row tb)
+ (- (round (/ (height tb) (row-height tb))) 2))
+ (incf (cursor-row tb))
+ (when (scroll tb)
+ (incf (row-offset tb))
+ (erase tb)
+ (refresh tb))))))
+ (draw-textbox-cursor tb (color-gc (fg-color tb) (colormap tb)))
+ (flush-output))
+
+;;;--------------------------------------
+
+(defmacro insert-at (loc item list)
+
+ "insert-at loc item list
+
+Inserts item into position loc in list - loc should be between 0 and
+(length list) inclusive."
+
+ `(if (zerop ,loc)
+ (setf ,list (cons ,item ,list))
+ (let ((end (nthcdr (1- ,loc) ,list)))
+ (setf (rest end) (cons ,item (rest end))))))
+
+;;;--------------------------------------
+
+(defmacro delete-at (loc list)
+
+ "delete-at loc list
+
+Deletes the item at location loc from list."
+
+ `(if (zerop ,loc)
+ (setf ,list (rest ,list))
+ (let ((end (nthcdr (1- ,loc) ,list)))
+ (setf (rest end) (rest (rest end))))))
+
+;;;--------------------------------------
+
+(defun insert-line (tb)
+
+ "insert-line tb
+
+Puts a newline into textbox tb beneath the current cursor location, if
+allowed, i.e., the number of lines is not limited. If we're at the
+bottom of the textbox, move all the text up a line."
+
+ (let ((vert-line-limit (truncate (/ (height tb) (row-height tb)))))
+ (when (or (scroll tb)
+ (< (length (info tb)) vert-line-limit))
+ (insert-at (+ 1 (cursor-row tb) (row-offset tb)) "" (info tb))
+ (if (< (cursor-row tb) (- vert-line-limit 1))
+ (incf (cursor-row tb))
+ (incf (row-offset tb)))
+ (erase tb)
+ (refresh tb)
+ (ev:announce tb (new-info tb)))))
+
+;;;--------------------------------------
+
+(defun delete-line (tb)
+
+ "delete-line tb
+
+Removes the line in textbox tb at the current cursor row; moves the
+cursor to the previous row. Does nothing if the cursor is already on
+the top row."
+
+ (when (plusp (+ (cursor-row tb) (row-offset tb)))
+ (delete-at (+ (cursor-row tb) (row-offset tb)) (info tb))
+ (if (plusp (cursor-row tb))
+ (decf (cursor-row tb))
+ (decf (row-offset tb)))
+ (erase tb)
+ (refresh tb)
+ (ev:announce tb (new-info tb))))
+
+;;;--------------------------------------
+
+(defun insert-character (tb chr)
+
+ "insert-character tb chr
+
+Inserts a character after the cursor."
+
+ (draw-textbox-cursor tb (color-gc (bg-color tb) (colormap tb)))
+ (let ((n (+ (cursor-row tb) (row-offset tb))))
+ (setf (nth n (info tb))
+ (concatenate 'string (nth n (info tb)) (string chr))))
+ (refresh tb) ;; refreshing is quick enough to do here
+ (ev:announce tb (new-info tb)))
+
+;;;--------------------------------------
+
+(defun delete-character (tb)
+
+ "delete-character tb
+
+Deletes the character immediately before the cursor."
+
+ (let ((n (+ (cursor-row tb) (row-offset tb))))
+ (draw-textbox-cursor tb (color-gc (bg-color tb) (colormap tb)))
+ (setf (nth n (info tb))
+ (subseq (nth n (info tb)) 0 (- (length (nth n (info tb))) 1)))
+ (clx:draw-rectangle (window tb)
+ (color-gc (bg-color tb) (colormap tb))
+ (+ 10 (clx:text-width (font tb) (nth n (info tb))))
+ (+ (* (cursor-row tb) (row-height tb)) 6)
+ (clx:max-char-width (font tb))
+ (row-height tb)
+ t)
+ (draw-textbox-cursor tb (color-gc (fg-color tb) (colormap tb)))
+ (flush-output))
+ (ev:announce tb (new-info tb)))
+
+;;;--------------------------------------
+
+(defmethod process-key-press ((tb textbox) code state)
+
+ "This method finds out which key was pressed and updates the
+textbox. Graphic characters, the up/down arrows, Newline, Return,
+Rubout, and Backspace are accepted."
+
+ (let* ((keysym (clx:keycode->keysym *display* code 0))
+ (chr (clx:keycode->character *display* code state)))
+ (cond
+ ((= keysym *up-arrow-keysym*) (move-textbox-cursor tb :up))
+ ((= keysym *down-arrow-keysym*) (move-textbox-cursor tb :down))
+ ((or (member chr '(#\Newline #\Return))
+ (= keysym *kp-enter-keysym*))
+ (insert-line tb))
+ ((member chr '(#\Rubout #\Backspace))
+ (if (string-equal "" (nth (+ (row-offset tb) (cursor-row tb))
+ (info tb)))
+ (delete-line tb)
+ (delete-character tb)))
+ ((and (characterp chr) (graphic-char-p chr))
+ (insert-character tb chr))))
+ nil)
+
+;;;--------------------------------------
+
+(defun make-textbox (width height &rest other-args
+ &key (info '("")) &allow-other-keys)
+
+ "make-textbox width height &rest other-args &key info &allow-other-keys)
+
+Creates and returns a textbox, with initial text appearing in the textbox
+window."
+
+ (apply #'make-instance 'textbox
+ :width width :height height :info (copy-list info)
+ other-args))
+
+;;;--------------------------------------
+
+(defmethod destroy :before ((tb textbox))
+
+ (clx:free-gcontext (gc-with-font tb)))
+
+;;;--------------------------------------
+;;; End.
diff --git a/slik/src/textlines.cl b/slik/src/textlines.cl
new file mode 100644
index 0000000..6e725ec
--- /dev/null
+++ b/slik/src/textlines.cl
@@ -0,0 +1,319 @@
+;;;
+;;; textlines
+;;;
+;;; A textline is a readout in which text can be edited, like a
+;;; typical command line editor - i.e., you can insert text at the
+;;; cursor position, delete the character before the cursor and move
+;;; the cursor left and right on the line. Only one line is present.
+;;;
+;;; 27-Apr-1992 I. Kalet started
+;;; 12-May-1992 I. Kalet compute cursor x position in refresh, don't
+;;; store it. Also, don't bother keeping track of cursor position -
+;;; it is always at the end of the string, so just use the length of
+;;; the string.
+;;; 24-May-1992 I. Kalet move exports to slik-exports
+;;; 6-Jul-1992 I. Kalet change be: to ev: and behavior to event
+;;; 9-Jul-1992 I. Kalet add set-info :after method to produce
+;;; announcement specified in SLIK Programmer's Guide, but not on
+;;; every new character input.
+;;; 27-Oct-1992 I. Kalet eliminate pixmap, add flush-output to setf
+;;; info
+;;; 12-Feb-1993 I. Kalet accept #\backspace as well as #\rubout,
+;;; discard other control characters, accept only graphic characters.
+;;; 13-May-1994 I. Kalet add facility for input error checking if
+;;; restricted to numbers.
+;;; 28-Jun-1994 I. Kalet check for empty string also.
+;;; 11-Sep-1994 J. Unger add facility for border color change to indicate
+;;; volatile information in textlines. Also add 'ENTER' as synonym for
+;;; 'RETURN' key.
+;;; 18-Oct-1994 J. Unger trap blank string input into numeric textline
+;;; - would cause an error, as would backslash at end of input.
+;;; 27-Dec-1994 J. Unger trap colon typed into numeric textline.
+;;; 3-Jan-1995 I. Kalet make kp-enter-keysym a global in clx-support
+;;; 2-Oct-1995 I. Kalet use ignore-error to trap more input hash in
+;;; numeric textlines.
+;;; 25-Apr-1997 I. Kalet add popup-textline here to avoid circularity
+;;; with dialogboxes (added more documentation 3-May-1997).
+;;; 22-Jun-1997 I. Kalet add button-2 clear function in textline.
+;;; 31-May-1998 I. Kalet take out multiple-value-bind in
+;;; process-key-press. The clx functions do NOT return multiple
+;;; values except in VAXLISP.
+;;; 26-Nov-2000 I. Kalet make default border-style lowered, and fix
+;;; some exit buttons to better match the other defaults.
+;;; 11-Mar-2001 I. Kalet make default border-style adaptive to general
+;;; default, if flat, make textlines flat too, otherwise lowered.
+;;; 15-Feb-2003 I. Kalet make popup-textline correctly handle the case
+;;; where the specified width is too small - just enlarge it.
+;;;
+
+(in-package :slik)
+
+;;;-------------------------------------
+
+(defclass textline (readout)
+
+ ((cursor-y1 :type clx:card16
+ :accessor cursor-y1
+ :documentation "Cursor upper y coordinate - computed
+only initially, when font is chosen.")
+
+ (cursor-y2 :type clx:card16
+ :accessor cursor-y2
+ :documentation "Cursor lower y coordinate.")
+
+ (new-info :type ev:event
+ :accessor new-info
+ :initform (ev:make-event)
+ :documentation "Announced when the user presses the
+RETURN key on the keyboard while the textline has the input focus.")
+
+ (numeric :accessor numeric
+ :initarg :numeric
+ :documentation "True if input is restricted to form a
+valid number")
+
+ (lower-limit :accessor lower-limit
+ :initarg :lower-limit
+ :documentation "The lowest numeric value accepted if
+numeric input is required.")
+
+ (upper-limit :accessor upper-limit
+ :initarg :upper-limit
+ :documentation "The highest numeric value accepted if
+numeric input is required.")
+
+ (volatile-color :type symbol
+ :accessor volatile-color
+ :initarg :volatile-color
+ :documentation "The color to turn the border when
+the textline is volatile.")
+
+ (volatile-width :type fixnum
+ :accessor volatile-width
+ :initarg :volatile-width
+ :documentation "The width to make the border when
+the textline is volatile.")
+
+ (border-color-cache :type symbol
+ :accessor border-color-cache
+ :documentation "The saved border color while the
+textline is volatile.")
+
+ (border-width-cache :type fixnum
+ :accessor border-width-cache
+ :documentation "The saved border width while the
+textline is volatile.")
+
+ )
+
+ (:default-initargs :title "Text input" :cursor 0 :numeric nil
+ :volatile-color 'red :volatile-width 2
+ :border-style (if (eql *default-border-style* :flat)
+ :flat :lowered))
+
+ (:documentation "A textline displays and allows the user to edit a
+line of text in the window. By default the text is vertically
+centered and starts 10 pixels in from the left. If numeric is true,
+when the user presses the RETURN or NEWLINE key the text is checked
+for validity and cleared, with an acknowledge message, if not valid.")
+
+ )
+
+;;;----------------------------------------
+
+(defmethod initialize-instance :after ((tl textline) &rest initargs)
+
+ (declare (ignore initargs))
+
+ (let ((fh (font-height (font tl))))
+ (setf (cursor-y1 tl) (- (info-y tl) fh)
+ (cursor-y2 tl) (+ (cursor-y1 tl) fh 4)))
+ (setf (border-color-cache tl) (border-color tl)
+ (border-width-cache tl) (border-width tl))
+ (unless (volatile-color tl) ;; if nil, no change to bdr when keys pressed
+ (setf (volatile-color tl) (border-color tl)
+ (volatile-width tl) (border-width tl))))
+
+;;;----------------------------------------
+
+(defun make-textline (width height &rest other-initargs)
+
+ "MAKE-TEXTLINE width height &rest other-initargs
+
+Returns a textline with the specified parameters. If the info
+parameter is provided it is centered as well as possible. This
+function relies on the initialization mechanisms of the readout."
+
+ (let ((tl (apply 'make-instance 'textline
+ :width width :height height other-initargs)))
+ (refresh tl)
+ tl))
+
+;;;----------------------------------------
+
+(defun draw-text-cursor (tl)
+
+ "This function draws the cursor. The cursor x position is computed
+here, from the current info value."
+
+ (let ((x1 (+ (info-x tl) (clx:text-width (font tl) (info tl)) 1)))
+ (clx:draw-line (window tl) (gc-with-font tl)
+ x1 (cursor-y1 tl) x1 (cursor-y2 tl))))
+
+;;;----------------------------------------
+
+(defmethod (setf info) :after (new-info (tl textline))
+
+ "This method adds the cursor. The readout method writes the
+text and background so this has to happen afterward."
+
+ (declare (ignore new-info))
+ (draw-text-cursor tl)
+ (flush-output))
+
+;;;----------------------------------------
+
+(defmethod refresh :after ((tl textline))
+
+ "This method adds the cursor. The readout method writes the
+text and background so this has to happen afterward."
+
+ (draw-text-cursor tl))
+
+;;;----------------------------------------
+
+(defmethod process-button-press ((tl textline) code x y)
+
+ "clears the contents of tl if button number 2 pressed"
+
+ (declare (ignore x y))
+ (when (= code 2)
+ (setf (info tl) "")
+ (setf (border-color tl) (volatile-color tl))
+ (setf (border-width tl) (volatile-width tl)))
+ nil) ;; needed to continue processing
+
+;;;----------------------------------------
+
+(defmethod process-key-press ((tl textline) code state)
+
+ "This method finds out which key was pressed and updates the info
+slot. Characters can only be added or deleted at the end of the
+string for now. Only graphic characters are accepted, and control
+characters are discarded, except for Newline, Return, Rubout and
+Backspace."
+
+ (let* ((text (info tl))
+ (count (length text))
+ (chr (clx:keycode->character *display* code state)))
+ ;; The ENTER key is not a standard Common Lisp character but we
+ ;; would like to recognize it as a synonym for #\return. So
+ ;; just set the resulting chr to #\return if the keypad ENTER
+ ;; key was pressed.
+ (when (= *kp-enter-keysym* (clx:keycode->keysym *display* code 0))
+ (setq chr #\return))
+ (case chr
+ ((#\newline #\return) ;; check input if needed, update border
+ (if (numeric tl)
+ (let ((result
+ ;; trap anything unreadable - in that case
+ ;; ignore-errors returns nil
+ (ignore-errors (read-from-string (info tl))))
+ (ll (lower-limit tl))
+ (ul (upper-limit tl)))
+ (if (and (numberp result)
+ (<= result ul)
+ (>= result ll))
+ (progn
+ (erase tl) ;; border width otherwise not reset right
+ (setf (border-width tl) (border-width-cache tl))
+ (setf (border-color tl) (border-color-cache tl))
+ (ev:announce tl (new-info tl) (info tl)))
+ (progn (acknowledge
+ (list "Please enter a number"
+ (format nil "between ~A and ~A" ll ul)))
+ (setf (info tl) ""))))
+ (progn
+ (erase tl) ;; border width otherwise not reset right
+ (setf (border-width tl) (border-width-cache tl))
+ (setf (border-color tl) (border-color-cache tl))
+ (ev:announce tl (new-info tl) (info tl)))))
+ ((#\rubout #\backspace) ;; erase last character
+ (when (> count 0)
+ (setf (border-color tl) (volatile-color tl))
+ (setf (border-width tl) (volatile-width tl))
+ (setq count (1- count))
+ (setf (info tl)
+ (if (> count 0) (subseq text 0 count)
+ ""))))
+ (otherwise
+ (if (and (characterp chr)
+ (graphic-char-p chr))
+ (setf
+ (border-color tl) (volatile-color tl)
+ (border-width tl) (volatile-width tl)
+ (info tl) (concatenate 'string text (string chr)))))))
+ nil)
+
+;;;--------------------------------------
+
+(defun popup-textline (info width &rest initargs
+ &key font &allow-other-keys)
+
+ "popup-textline info width &rest initargs &key font &allow-other-keys
+
+Pops up a textline, of the specified width, at a nested event level.
+The info parameter is a string to initially appear in the textline as
+a default. It can be an empty string. The initargs are the other
+parameters suitable to the textline, and the height is determined from
+the font. The text and the label if supplied always start 10 pixels
+from the left, even if info is supplied. When the Accept button is
+pressed, returns the string representing the edited text. If the
+Cancel button is pressed, returns nil."
+
+ (push-event-level)
+ (let* ((ft (or font *default-font*))
+ (height (+ (font-height ft) 10))
+ (button-width (+ 10 (clx:text-width ft "Accept")))
+ (padded-width (max width (+ (* 2 button-width) 10)))
+ (frm (apply #'make-frame
+ padded-width (+ (* 2 height) 5)
+ initargs))
+ (frm-win (window frm))
+ (tl (apply #'make-textline padded-width height
+ :parent frm-win initargs))
+ (left-x (round (/ (- padded-width (* 2 button-width) 10) 2)))
+ (acc-b (apply #'make-exit-button button-width height
+ :label "Accept" :parent frm-win
+ :ulc-x left-x
+ :ulc-y (+ height 5)
+ :bg-color 'green
+ initargs))
+ (can-b (apply #'make-exit-button button-width height
+ :label "Cancel" :parent frm-win
+ :ulc-x (- padded-width button-width left-x)
+ :ulc-y (+ height 5)
+ initargs))
+ (return-value nil))
+ (setf (info tl) info)
+ (ev:add-notify frm (button-on can-b)
+ #'(lambda (fr btn)
+ (declare (ignore fr btn))
+ (setq return-value nil)))
+ (ev:add-notify tl (button-on acc-b)
+ #'(lambda (tln btn)
+ (declare (ignore btn))
+ (setq return-value (info tln))))
+ (clx:map-window frm-win)
+ (clx:map-subwindows frm-win)
+ (flush-output)
+ (process-events)
+ (destroy tl)
+ (destroy acc-b)
+ (destroy can-b)
+ (destroy frm)
+ (pop-event-level)
+ return-value))
+
+;;;--------------------------------------
+;;; End.
diff --git a/systemdefs/dicom-client.system b/systemdefs/dicom-client.system
new file mode 100644
index 0000000..cea49b5
--- /dev/null
+++ b/systemdefs/dicom-client.system
@@ -0,0 +1,50 @@
+;;;
+;;; dicom-client.system
+;;;
+;;; Prism DICOM Server and RTPlan Client System Declarations.
+;;; Compile this manually - COMPILE-SYSTEM will not compile it.
+;;; Contains declarations used by Client only.
+;;;
+;;; 21-Jun-2001 BobGian remove target configuration parameters for client -
+;;; replaced by lookup from target machine definition files.
+;;; 31-Jul-2001 BobGian reconfigure client subsystem to load and read config
+;;; file from /radonc/prism/dicom-pdr rather than /users/bobgian/dicom-pdr.
+;;; 31-Dec-2001 BobGian begin modularizing PDS to use DEFSYSTEM and to
+;;; incorporate client as normal part of Prism (not loaded separately).
+;;; Client configuration now comes from "/radonc/prism/prism.config".
+;;; Server configuration still comes from "/radonc/prism/pds.config".
+;;; 11-Feb-2002 BobGian move *Implementation-Version-Name* and
+;;; *Implementation-Class-UID* here as non-configurable parameters
+;;; but different values for Client versus Server.
+;;; 18-Feb-2002 BobGian dicom::*PDR-DATA-FILE* -> Prism pkg (may be temporary).
+;;; 18-Feb-2002 BobGian dicom::*DICOM-LOG-DIR* -> Prism pkg.
+;;; 30-Jul-2002 BobGian fix error in Implementation-Class-UID for client:
+;;; "1.2.840.113944.100.10.1.2" -> "1.2.840.113994.100.10.1.2"
+;;; 30-Aug-2002 BobGian add declaration for pr::*DICOM-AE-TITLES*.
+;;; 03-Sep-2002 BobGian remove pr::*DICOM-AE-TITLES* - is in "prism-globals".
+;;; 23-Sep-2002 BobGian move pr::*DICOM-AE-TITLES* to DICOM package and from
+;;; "prism-globals.cl" to "dicom-client.system". Also export here.
+;;; 30-Jul-2003 I. Kalet fixes for new cvs code management system.
+;;; 21-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 15-Jul-2004 BobGian: Remove "DI" nickname from DICOM package declaration.
+;;; 04-Nov-2004 BobGian move pr::*DICOM-LOG-DIR* and pr::*PDR-DATA-FILE*
+;;; from here -> "prism-globals.cl".
+;;; 20-Jun-2009 I. Kalet move defpackage etc. out to make independent
+;;; of defsystem
+;;;
+
+;;;=============================================================
+;;; Dicom CLIENT system definition.
+
+(mk:defsystem :dicom-client
+ :source-pathname "dicom/src/"
+ :binary-pathname "dicom/bin/"
+ :depends-on (:dicom-common)
+ :components
+ (("wrapper-client")
+ ("actions-client")
+ ("object-generator")
+ ))
+
+;;;=============================================================
+;;; End.
diff --git a/systemdefs/dicom-common.system b/systemdefs/dicom-common.system
new file mode 100644
index 0000000..35f2807
--- /dev/null
+++ b/systemdefs/dicom-common.system
@@ -0,0 +1,78 @@
+;;;
+;;; dicom-common.system
+;;;
+;;; Prism DICOM Server and RTPlan Client System Definition.
+;;;
+;;; Contains declarations common to Client and Server.
+;;;
+;;; 21-Dec-2000 BobGian change directories for config file from absolute
+;;; to relative (current) so others can use this more easily in testing.
+;;; 26-Dec-2000 BobGian change directories for config file from absolute
+;;; to relative (current) so others can use this more easily in testing.
+;;; Change global names for consistency.
+;;; 22-Mar-2001 BobGian add Math package.
+;;; 27-Apr-2001 BobGian remove *SERVER-AE-TITLE* - server echoes acceptable
+;;; AE title used by client rather than fixed value from config variable.
+;;; 03-May-2001 BobGian set default *MAX-DUMPLEN* to full PDU size.
+;;; 09-May-2001 BobGian add RTPlan-Storage-Service to Object-Storage-Services.
+;;; For now, this is a debugging-printout stub for testing Dicom-RTD.
+;;; 31-May-2001 BobGian remove Math package.
+;;; 07-Sep-2001 BobGian remove redundant package defns - already present
+;;; in other files loaded with rest of Prism.
+;;; 31-Dec-2001 BobGian begin modularizing PDS to use DEFSYSTEM and to
+;;; incorporate client as normal part of Prism (not loaded separately).
+;;; Client configuration now comes from "/radonc/prism/prism.config".
+;;; Server configuration still comes from "/radonc/prism/pds.config".
+;;; 23-Jan-2002 BobGian add *DICOM-DUMP-FILE* for debugging trace.
+;;; 25-Jan-2002 BobGian both Client and Server must bind *CONNECTION-STRM*,
+;;; so its declaration moved here from "dicom-client.system".
+;;; 18-Feb-2002 BobGian flush *DICOM-DUMP-FILE*; use standard output instead.
+;;; Used for development/testing only, not production.
+;;; 02-Mar-2002 BobGian add dependency of "functions" on "compiler".
+;;; 15-Apr-2002 BobGian:
+;;; Remove RTPlan-Storage-Service from Object-Storage-Services. Never
+;;; used and was erroneous. Intention was to accept for RTPlans for debug
+;;; printout. Instead this would have attempted to write them
+;;; as a Prism Image Set.
+;;; Add Structure-Set SOP class as server-handled object.
+;;; Add *Image-Storage-Services* as list of server-handled C-Store Image
+;;; types and *Object-Storage-Services* as similar list of all object types
+;;; (currently all image types, Structure-Sets, and RT-Plans).
+;;; 30-Apr-2002 BobGian remove Presentation Context ID - constant #x01.
+;;; 04-May-2002 BobGian remove *MAX-DUMPLEN* - use TCP-Bufsize [constant].
+;;; 23-Sep-2002 BobGian export PAT-POS (slot in IMAGE class, written to file).
+;;; 24-Sep-2002 BobGian add declaration for *DICOM-ALIST*.
+;;; 08-May-2003 BobGian - Default log level 2 -> 0.
+;;; 28-Aug-2003 I. Kalet remove obsolete PET-2 and PET-3 SOP class UIDs
+;;; 21-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 15-Jul-2004 BobGian: Remove "DI" nickname from DICOM package declaration.
+;;; 09-Nov-2004 BobGian - began modularization of server output functionality.
+;;; 18-Apr-2005 I. Kalet add in global variables for SSL, per Tung Le.
+;;; 20-Jun-2009 I. Kalet move defpackage and all globals to new dicom
+;;; file to make independent of defsystem
+;;;
+
+;;;=============================================================
+;;; Dicom system definition for portion common to Client and Server.
+
+(mk:defsystem :dicom-common
+ :source-pathname "dicom/src/"
+ :binary-pathname "dicom/bin/"
+ :components
+ (("dicom")
+ ("dictionary")
+ ("utilities")
+ ("compiler")
+ ("parser-rules" :depends-on ("compiler"))
+ ;; "utilities" and "parser-rules" must load before "generator-rules"
+ ("generator-rules" :depends-on ("utilities" "compiler" "parser-rules"))
+ ("state-rules" :depends-on ("compiler"))
+ ("functions" :depends-on ("utilities" "compiler"))
+ ("generator" :depends-on ("functions" "utilities"))
+ ("parser" :depends-on ("functions" "utilities"))
+ ("actions-common" :depends-on ("generator" "utilities"))
+ ("mainloop" :depends-on ("actions-common" "parser" "utilities"))
+ ))
+
+;;;=============================================================
+;;; End.
diff --git a/systemdefs/dicom-server.system b/systemdefs/dicom-server.system
new file mode 100644
index 0000000..65686b3
--- /dev/null
+++ b/systemdefs/dicom-server.system
@@ -0,0 +1,62 @@
+;;;
+;;; dicom-server.system
+;;;
+;;; Prism DICOM Server and RTPlan Client System Declarations.
+;;;
+;;; Contains declarations used by Server only.
+;;;
+;;; 06-Oct-2001 BobGian eliminate temporary directory variables.
+;;; 15-Oct-2001 BobGian remove *FILE-MOVE-LIST*.
+;;; 31-Dec-2001 BobGian begin modularizing PDS to use DEFSYSTEM and to
+;;; incorporate client as normal part of Prism (not loaded separately).
+;;; Client configuration now comes from "/radonc/prism/prism.config".
+;;; Server configuration still comes from "/radonc/prism/pds.config".
+;;; 11-Feb-2002 BobGian move *Implementation-Version-Name* and
+;;; *Implementation-Class-UID* here as non-configurable parameters
+;;; but different values for Client versus Server.
+;;; 30-Jul-2002 BobGian fix error in Implementation-Class-UID for server:
+;;; "1.2.840.113944.100.10.1.1" -> "1.2.840.113994.100.10.1.1"
+;;; Jul/Aug 2002 BobGian:
+;;; DEFSYSTEM: filename change: "prism-images" -> "prism-data".
+;;; More mnemonic names for global vars naming directories:
+;;; *IMAGE-DATABASE* -> *MATCHED-PAT-IMAGE-DATABASE*
+;;; *UNMATCHED-NAME-DATABASE* -> *UNMATCHED-PAT-IMAGE-DATABASE*
+;;; Ditto for special vars used internally (*CACHED-xxxx, etc).
+;;; Special vars bound on main function entry and not at top-level.
+;;; New global var naming Structure-Set directory: *STRUCTURE-DATABASE*.
+;;; Each item (sublist) on *LOCAL-ENTITIES* and *REMOTE-ENTITIES* lists can
+;;; now contain one more optional element: directory for Structure-Sets.
+;;; 08-May-2003 BobGian: Add a few more color names as SLIK exports.
+;;; 30-Jul-2003 I. Kalet fix up for new cvs code management
+;;; 21-Sep-2003 BobGian - remove obsolete version number in change log header.
+;;; 21-Dec-2003 BobGian: Add variable *IGNORABLE-GROUPS-LIST* to specify
+;;; slots that PARSE-OBJECT should log but otherwise ignore.
+;;; 24-Dec-2003 BobGian: Added var *REPORTABLE-VARIABLES* to hold list of
+;;; configurable variables whose values are logged at server startup.
+;;; 27-Apr-2004 BobGian: Variable split in declaration - *STORED-IMAGE-COUNT*
+;;; -> *STORED-IMAGE-COUNT-PER-SET* [per-image-set count]
+;;; -> *STORED-IMAGE-COUNT-CUMULATIVE* [cumulative count over association].
+;;; 15-Jul-2004 BobGian: Remove "DI" nickname from DICOM package declaration.
+;;; 1-Dec-2008 I. Kalet change version number, and temporarily
+;;; redefine pds.config location.
+;;; 20-Jun-2009 I. kalet move package defs and other globals to
+;;; wrapper-server to make independent of defsystem
+;;;
+
+;;;=============================================================
+;;; Dicom SERVER system definition.
+
+(mk:defsystem :dicom-server
+ :depends-on (:dicom-common) ;; and slik too, sort of...
+ :source-pathname "dicom/src/"
+ :binary-pathname "dicom/bin/"
+ :components
+ (("wrapper-server")
+ ("actions-server")
+ ("prism-data")
+ ("prism-output" :depends-on ("prism-data"))
+ ("object-parser" :depends-on ("prism-output"))
+ ))
+
+;;;=============================================================
+;;; End.
diff --git a/systemdefs/polygons.system b/systemdefs/polygons.system
new file mode 100644
index 0000000..1242801
--- /dev/null
+++ b/systemdefs/polygons.system
@@ -0,0 +1,54 @@
+;;;
+;;; polygons.system
+;;;
+;;; Some stuff that does polygon arithmetic.
+;;;
+;;; 1-Apr-1993 I. Kalet taken from ptvt
+;;; 5-May-1994 J. Unger add ortho-expand-contour to exports list.
+;;; 21-Jul-1994 J. Unger add bounding-box to exports list.
+;;; 13-Sep-1994 J. Unger add area-of-triangle and area-of-polygon to
+;;; exports.
+;;; 23-Sep-1994 J. Unger add perimeter-of-polygon to exports.
+;;; 1-Nov-1994 J. Unger add center to exports.
+;;; 8-Jan-1995 I. Kalet make just allegro, not different versions,
+;;; also define a *pi-over-180* constant here for use in
+;;; contour-algebra.
+;;; 1-Feb-1996 I. Kalet drop make-package, assume defpackage
+;;; 2-May-1997 I. Kalet include exports in defpackage, not separate
+;;; 2-Jul-1997 BobGian add CLOCKWISE-TRAVERSAL-P in export list.
+;;; 3-Jul-1997 BobGian added exports for NEARLY-INCREASING and
+;;; NEARLY-DECREASING (moved here from PRISM system) and for
+;;; IN-BOUNDING-BOX and COLLINEAR (used in PRISM system).
+;;; 7-Jul-1997 BobGian added CANONICAL-CONTOUR as replacement for
+;;; REMOVE-ADJACENT-COLLINEAR-VERTICES and
+;;; REMOVE-ADJACENT-REDUNDANT-VERTICES (both present but not exported).
+;;; 23-Sep-1997 BobGian removed export for REMOVE-REDUNDANT-VERTICES;
+;;; used only in contour-algebra [in POLYGONS package].
+;;; 2-Oct-1997 BobGian remove VERTEX-LIST-UNION - nowhere used.
+;;; Remove export for VERTEX-LIST-INTERSECTION - used only in own package.
+;;; Remove CENTER [renamed POLYCENTER] from export - ditto.
+;;; Remove AREA-OF-TRIANGLE, AREA-OF-POLYGON, PERIMETER-OF-POLYGON.
+;;; 7-Oct-1997 BobGian add CONTOUR-ENCLOSES-P (moved PRISM -> POLYGONS).
+;;; 03-Feb-2000 BobGian return AREA-OF-TRIANGLE and AREA-OF-POLYGON to
+;;; active duty (and exported) -- used in electron dose calc.
+;;; 30-Jul-2003 I. Kalet fix up for new cvs code management
+;;; 1-May-2004 I. Kalet new module segments has code from Prism
+;;; contour editor, also export simple-polygon
+;;; 20-Jun-2009 I. Kalet move defpackage and other stuff out to the
+;;; math file to make the files independent of defsystem
+;;;
+
+;;;---------------------------------------------
+
+(mk:defsystem :polygons
+ :source-pathname "polygons/src/"
+ :binary-pathname "polygons/bin/"
+ :components
+ (("math")
+ ("contour-algebra" :depends-on ("math"))
+ ("convex-hull" :depends-on ("math"))
+ ("segments" :depends-on ("math" "contour-algebra"))
+ ))
+
+;;;---------------------------------------------
+;;; End.
diff --git a/systemdefs/prism.system b/systemdefs/prism.system
new file mode 100644
index 0000000..0a04986
--- /dev/null
+++ b/systemdefs/prism.system
@@ -0,0 +1,478 @@
+;;;
+;;; prism-system
+;;;
+;;; System definition file for the PRISM radiotherapy planning system
+;;; Assumes CMU defsystem loaded, and other environmental factors set.
+;;;
+;;; 4-Jun-1992 I. Kalet started
+;;; 25-Jun-1992 I. Kalet modify for CMU defsystem
+;;; 17-Jul-1992 I. Kalet add contour editor, filmstrip and volume
+;;; editor modules
+;;; 31-Jul-1992 I. Kalet add misc and plans modules
+;;; 9-Aug-1992 I. Kalet add geometry to :depends-on systems and put
+;;; exports in defpackage form. Added patients module
+;;; 16-Oct-1992 I. Kalet contour-editor depends on contours now, and
+;;; add new module, object-manager
+;;; 13-Nov-1992 I. Kalet medical-images now depends on views,
+;;; rearrange other dependencies (and some history removed...)
+;;; 24-Nov-1992 I. Kalet add image-manager module
+;;; 5-Mar-1993 I. Kalet add patient-panels, change volume-editor to
+;;; easel, add definitions for global database variables.
+;;; 24-Mar-1993 J. Unger add cmucl read time conditionals, add missing
+;;; dependencies to beam file in defsystem definition, undo cycle in
+;;; defsystem dependency list. Also expanded the ~ on the two database
+;;; definitions.
+;;; 01-Nov-1993 J. Unger add *sum-dose-option* to list of global
+;;; variables (lots of others added previously)
+;;; 16-Nov-1993 I. Kalet add genera read time conditionals
+;;; 11-Feb-1994 I. Kalet add tools-panel for RTPT tools and also
+;;; modules for autoplan. Add everything in Implementation report to
+;;; export list (and some history removed...)
+;;; 11-Feb-1994 J. Unger add plots definition and dependencies
+;;; 21-Feb-1994 D. Nguyen add copy functions, others to export list.
+;;; 02-Mar-1994 J. Unger add charts definition and dependencies.
+;;; 07-Mar-1994 D. Nguyen add get-transverse-beam-transform and
+;;; project-portal to export list.
+;;; 15-Mar-1994 J. Unger add digitizer, fix bug in *dosecomp-command*
+;;; 1-Apr-1994 I. Kalet delete dependency of filmstrip on
+;;; medical-images, delete some history above, add bev-graphics
+;;; 15-Apr-1994 I. Kalet add dependency of view-panels on locators
+;;; 25-Apr-1994 J. Unger add dependencies for point display modules, others
+;;; 6-May-1994 J. Unger require polygons & ruler pkgs, move ptvt
+;;; defpackage here, split valid to valid-grid & valid-points on
+;;; exports list, add misc dependency to linear-expand.
+;;; 16-May-1994 I. Kalet move globals to prism-globals, add prism,
+;;; prism-globals modules and dependencies, add beam-blocks.
+;;; 20-May-1994 J. Unger add dependencies for point editors.
+;;; 26-May-1994 I. Kalet revise editor dependencies, add planar-editor
+;;; 10-Jun-1994 I. Kalet revise easel, 3d editor, add volume editor,
+;;; fix up dependencies, modify beam-blocks and other dependencies.
+;;; 20-Jun-1994 J. Unger modify dependencies for contour-editor.
+;;; 21-Jun-1994 I. Kalet add write-neutron module.
+;;; 23-Jun-1994 J. Jacky charts, write-neutron depend on therapy-machines
+;;; 29-Jun-1994 I. Kalet add wedges, dependencies.
+;;; 11-Jul-1994 J. Unger add prism-top-level, dbmgr-top-level, and
+;;; unpack-top-level to exports list, add tape-measure dependencies.
+;;; 13-Jul-1994 D. Nguyen add autoplan exports.
+;;; 20-Jul-1994 J. Unger add neutron panel stuff.
+;;; 22-Jul-1994 J. Jacky add mlc
+;;; 28-Jul-1994 J. Unger add deps for leaf-panel & leaf-editor.
+;;; 5-Aug-1994 J. Unger add defs for block-editor, exports for cnts-coll.
+;;; 11-Oct-1994 J. Unger modify exports for plots, fix prism-db dependency.
+;;; 26-Jan-1995 I. Kalet clean up all dependencies and eliminate
+;;; allegro pre-v4, vaxlisp and lucid support. Take out dependency on
+;;; events and collections systems - they are merged with slik. Also,
+;;; geometry is now a module in prism, not a system.
+;;; 12-Mar-1995 I. Kalet add patient-plan-manager and fix up patient,
+;;; plan and other dependencies.
+;;; 30-Apr-1995 I. Kalet remove block-editor, not needed anymore.
+;;; 4-Sep-1995 I. Kalet add support for Harlequin Lispworks, fix
+;;; dependencies on misc, update dependencies on contour-graphics.
+;;; 5-Jan-1996 I. Kalet add collim-info, split off from
+;;; therapy-machines, add dose-info, transfer-info and some exports.
+;;; 1-Feb-1996 I. Kalet drop make-package, just assume defpackage.
+;;; 4-Jun-1996 I. Kalet add new modules brachy-mediators,
+;;; brachy-graphics, brachy-panels.
+;;; 8-Oct-1996 I. Kalet change contour-graphics to pixel-graphics,
+;;; update dependencies, as draw code for contours is now merged into
+;;; volume graphics. Add beam-transforms, beam-block-graphics,
+;;; wedge-graphics, separated from beam-graphics. Update other
+;;; dependencies as well for other moved code.
+;;; 2-Jan-1997 I. Kalet add beam-dose and brachy-dose separate files
+;;; in anticipation of rewrite of beam dose module in Lisp.
+;;; 21-Jan-1997 I. Kalet add pathlength module, delete geometry.
+;;; 7-Mar-1997 I. Kalet add brachy-tables analog to therapy-machines
+;;; 18-Apr-1997 I. Kalet drop support for CMU/PCL, assume native CLOS
+;;; 22-May-1997 I. Kalet drop dose panel, now absorbed into plan
+;;; panel, consolidate some history above, add newly discovered
+;;; dependencies discovered by Bob G., resolve circularities between
+;;; bev-graphics, beam-block-graphics, also tape-measure,
+;;; planar-editor, and plans, beam-mediators. Add replace-coll.
+;;; 25-Jun-1997 I. Kalet add dep. of plan-panels on brachy-panels and
+;;; beam-panels, export collimator-type, update filmstrip dep., add
+;;; dose-surface-panels for revised plan panel, delete
+;;; patient-plan-mediators, revise deps.
+;;; 26-Jun-1997 BobGian remove export of OUTCODE (internal macro).
+;;; 28-Jun-1997 I. Kalet add patdb-panels and irreg modules.
+;;; 03-Jul-1997 BobGian removed all NEARLY-xxx functions - now living
+;;; in POLYGONS system.
+;;; 1-Sep-1997 I. Kalet add irreg and irreg-panels, add brachy deps.,
+;;; add new dep. of prism-db on irreg, add spreadsheet, remove TPR and
+;;; OUTPUT-FACTOR from the exports list.
+;;; 16-Sep-1997 I. Kalet refine dependencies.
+;;; 3-Oct-1997 BobGian remove AVERAGE, LO-HI-COMPARE - now expanded
+;;; inline.
+;;; 24-Oct-1997 I. Kalet plans does not depend on collimators or wedges.
+;;; 27-Oct-1997 BobGian brachy-dose depends on misc because of SQR.
+;;; 26-Dec-1997 I. Kalet take out spreadsheets -- moved it to SLIK
+;;; 19-Jan-1998 I. Kalet revise dependencies after filmstrip overhaul,
+;;; don't export get-transverse-beam-transform.
+;;; 22-Jan-1998 BobGian add new file clipper containing polygon clipping
+;;; code formerly in pathlength. beam-dose depends on clipper.
+;;; 13-Mar-1998 BobGian add 2 new files: table-lookups and output-factors.
+;;; Slight reordering of dependencies between therapy-machines, dose-info,
+;;; beam-dose, and the new files.
+;;; 30-Apr-1998 I. Kalet add irreg-point-panels, split off from
+;;; irreg-panels, and irreg-dose, split from irreg. Add postscript
+;;; module. Add irreg chart to charts, adjust dependencies.
+;;; 22-May-1988 BobGian create new file "dosecomp-decls" to hold
+;;; dose-computation-wide DEFCONSTANTs and DEFMACROs.
+;;; 25-May-1998 I. Kalet fix more dependencies, e.g., plots,
+;;; irreg-dose
+;;; 19-Jun-1998 I. Kalet add drr.
+;;; 03-Nov-1998 C. Wilcox add scan, spots, & dvh-panel.
+;;; added dependency of patient-panel on dvh-panel.
+;;; 22-Dec-1998 I. Kalet add electron-dose, stub at first, later
+;;; Paul's code.
+;;; 26-Jan-1999 I. Kalet ruler and dnet are now modules, not a subsystem.
+;;; 25-Mar-1999 I. Kalet add quadtree for electron beam dose calc.
+;;; 24-Jun-1999 J. Zeman move postscript package to slik-system
+;;; 5-Sep-1999 I. Kalet revise dependencies for new mlc-panels and
+;;; related stuff.
+;;; 25-Oct-1999 I. Kalet remove dependencies in tools-panel, remove
+;;; autoplan module and package.
+;;; 16-Jan-2000 I. Kalet added brachy tables and other dependencies.
+;;; 03-Feb-2000 BobGian update dependencies for electron dosecalc files.
+;;; 28-Feb-2000 I. Kalet add another brachy module,
+;;; brachy-specs-panels, add some more brachy dependencies.
+;;; 5-Mar-2000 I. Kalet add dependencies for finally adding the tape
+;;; measure to the views, also split off another brachy module.
+;;; 17-Apr-2000 I. Kalet ...and yet another brachy module, seed-spreadsheet.
+;;; 29-Jun-2000 I. Kalet export add-tool and add dependency for tools-panel
+;;; 30-Jul-2000 I. Kalet split medical-images with draw stuff in
+;;; separate module, image-graphics.
+;;; 13-Aug-2000 I. Kalet add missing digitizer dependency.
+;;; 26-Nov-2000 I. Kalet remove refs to SRS collim. and transfer-info,
+;;; add dependency of beam-block-panels on attribute-editor.
+;;; 11-Mar-2001 I. Kalet add dump-prism-image to exports list.
+;;; 11-Jun-2001 BobGian remove type-specific arithmetic macros - not exported.
+;;; 6-Jan-2002 I. Kalet add new dependency: beam-panels on misc
+;;; 31-Jan-2002 I. Kalet add dicom modules for DICOM-RT support
+;;; 28-Jul-2002 I. Kalet reorganize brachytherapy modules, replace
+;;; ortho-film-entry with brachy-coord-panels
+;;; 5-Aug-2002 J. Sager add room-view
+;;; 23-Sep-2002 BobGian export PAT-POS (slot in IMAGE class, written by PDS).
+;;; 6-Oct-2002 I. Kalet rename seed-spreadsheet to brachy-dose-panels.
+;;; 12-Jun-2003 I. Kalet add import-structure-sets, remove import-anatomy.
+;;; 23-Mar-2004 BobGian add dmp-panel in DICOM module.
+;;; 21-Jun-2004 I. Kalet remove irreg modules, discontinued
+;;; 21-Jun-2004 I. Kalet merge 2d-point-editor, contour-editor into
+;;; planar-editor, merge 3d-point-editor, easel into volume-editor,
+;;; add auto-extend-panels.
+;;; 13-Sep-2005 I. Kalet remove ruler, replace with Graham inference,
+;;; adjust dependencies in PTVT modules, remove PTVT package
+;;; 25-Jun-2008 I. Kalet add INFERENCE defpackage here in order to add
+;;; to PRISM use-package list - it is completed in inference.cl
+;;; 25-May-2009 I. Kalet remove support for room-view.
+;;; 20-Jun-2009 I. Kalet move defpackage to prism-globals to make
+;;; independent of defsystem
+;;;
+
+;;;-------------------------------------
+;;; PRISM defsystem.
+;;;-------------------------------------
+
+(mk:defsystem :prism
+ :source-pathname "prism/src/"
+ :binary-pathname "prism/bin/"
+ :depends-on (:slik :polygons :dicom-client)
+ :components
+ (
+ ;; Basic functions and global variables.
+ ("prism-globals")
+ ("misc")
+ ;; Declaration for constants used in dosecomp functions.
+ ("dosecomp-decls")
+
+ ;; Basic objects of radiotherapy, except plans and patients.
+ ("prism-objects")
+ ("contours")
+ ("volumes" :depends-on ("prism-objects" "contours"))
+ ("points" :depends-on ("prism-objects"))
+ ("medical-images" :depends-on ("prism-globals" "misc"))
+ ("collimators" :depends-on ("prism-objects" "contours"))
+ ("replace-coll" :depends-on ("collimators"))
+ ("collim-info")
+ ("table-lookups")
+ ("dose-info" :depends-on ("table-lookups"))
+ ("file-functions")
+ ("therapy-machines" :depends-on ("file-functions" "dosecomp-decls"
+ "dose-info" "table-lookups"))
+ ("dose-grids" :depends-on ("prism-objects" "prism-globals"))
+ ("dose-results" :depends-on ("prism-objects"))
+ ("wedges" :depends-on ("prism-objects"))
+ ("beam-blocks" :depends-on ("prism-objects" "contours"))
+ ("beams" :depends-on ("prism-globals" "prism-objects"
+ "beam-blocks" "wedges" "collimators"
+ "replace-coll" "therapy-machines" "dose-results"))
+ ("mlc" :depends-on ("collimators" "beams" "beam-blocks"))
+ ("pixel-graphics" :depends-on ("misc"))
+ ("tape-measure" :depends-on ("misc" "pixel-graphics")) ;; for compute-tics
+ ("views" :depends-on ("prism-objects" "tape-measure"))
+ ("beams-eye-views" :depends-on ("prism-globals" "views" "beams"))
+ ("beam-transforms" :depends-on ("prism-globals"
+ "beams" "collimators"
+ "views" "beams-eye-views"))
+ ("drr")
+ ("brachy-tables" :depends-on ("prism-globals" "file-functions"))
+ ("brachy" :depends-on ("prism-objects" "brachy-tables"))
+
+ ;; Graphics - define methods for generic function "draw".
+ ("view-graphics" :depends-on ("views"))
+ ("volume-graphics" :depends-on ("misc"
+ "contours" "volumes" "views"
+ "pixel-graphics" "view-graphics"))
+ ("point-graphics" :depends-on ("points"
+ "misc" "pixel-graphics"
+ "views" "view-graphics"))
+ ("wedge-graphics" :depends-on ("view-graphics" "pixel-graphics" "misc"))
+ ("beam-graphics" :depends-on ("beams"
+ "collimators" "contours"
+ "views" "view-graphics"
+ "pixel-graphics" "beam-transforms"
+ "beams-eye-views" "wedges"
+ "wedge-graphics" "misc"))
+ ("bev-graphics" :depends-on ("prism-globals"
+ "beams" "beam-graphics"
+ "beam-transforms" "collimators"
+ "views" "view-graphics" "beams-eye-views"
+ "wedges" "wedge-graphics"
+ "points" "contours" "volumes"
+ "point-graphics" "pixel-graphics"))
+ ("beam-block-graphics" :depends-on ("prism-globals"
+ "beams" "beam-blocks"
+ "views" "view-graphics"
+ "beams-eye-views" "beam-transforms"
+ "beam-graphics" "bev-graphics"))
+ ("brachy-graphics" :depends-on ("brachy"
+ "pixel-graphics" "views" "view-graphics"))
+ ("dose-grid-graphics" :depends-on ("dose-grids"
+ "pixel-graphics"
+ "views" "view-graphics"))
+ ("isocontour" :depends-on ("misc"))
+ ("dose-surface-graphics" :depends-on ("dose-results"
+ "views" "view-graphics"
+ "dose-grids" "isocontour"
+ "pixel-graphics"))
+ ("image-graphics" :depends-on ("prism-globals"
+ "misc" "views" "beams" "beams-eye-views"
+ "drr" "beam-transforms"))
+
+ ;; Mediators - relate objects and views.
+ ("object-manager" :depends-on ("prism-objects" "views"))
+ ("locators" :depends-on ("views" "view-graphics"))
+ ("point-mediators" :depends-on ("object-manager" "points" "views"))
+ ("volume-mediators" :depends-on ("object-manager" "volumes" "views"))
+ ("beam-mediators" :depends-on ("object-manager"
+ "collimators" "beams" "wedges"
+ "beam-blocks" "beam-block-graphics"
+ "views" "beams-eye-views"))
+ ("brachy-mediators" :depends-on ("object-manager" "brachy" "views"))
+ ("dose-grid-mediators" :depends-on ("object-manager"
+ "dose-grids" "views"
+ "pixel-graphics" "dose-grid-graphics"))
+ ("dose-result-mediators" :depends-on ("dose-results" "beams" "brachy"))
+ ("dose-view-mediators" :depends-on ("object-manager" "dose-results"))
+ ("dose-spec-mediators" :depends-on ("dose-grids"
+ "beams" "volumes" "points"))
+ ("image-manager" :depends-on ("prism-globals" "image-graphics" "views"))
+
+ ;; Plans and patients.
+ ("plans" :depends-on ("prism-objects"
+ "prism-globals" "misc"
+ "views" "locators" "object-manager"
+ "beams" "beam-mediators"
+ "brachy" "brachy-mediators"
+ "dose-grids" "dose-grid-mediators"
+ "dose-results" "dose-result-mediators"
+ "dose-view-mediators"))
+ ("patients" :depends-on ("prism-globals"
+ "misc" "prism-objects" "medical-images"
+ "volumes" "contours" "points"
+ "plans" "image-manager" "object-manager"
+ "dose-spec-mediators" "volume-mediators"
+ "point-mediators"))
+
+ ;; Dose calculation functions.
+ ("pathlength" :depends-on ("dosecomp-decls" "volumes"))
+ ("clipper" :depends-on ("dosecomp-decls"))
+ ("output-factors" :depends-on ("table-lookups" "dose-info"))
+ ("beam-dose" :depends-on ("beams"
+ "clipper" "output-factors"
+ "dosecomp-decls" "table-lookups"
+ "therapy-machines" "dose-info"
+ "volumes" "points" "contours"
+ "pathlength" "beam-transforms"
+ "wedges" "beam-blocks" "collimators"
+ "dose-grids" "dose-results"))
+ ("quadtree" :depends-on ("pathlength"))
+ ("electron-dose" :depends-on ("beams"
+ "therapy-machines" "dose-info"
+ "volumes" "points" "contours"
+ "pathlength" "quadtree" "dosecomp-decls"
+ "beam-transforms" "collimators"
+ "wedges" "beam-blocks"
+ "dose-grids" "dose-results"))
+ ("brachy-dose" :depends-on ("brachy"
+ "misc" "brachy-tables" "dose-grids"
+ "points" "dose-results"))
+ ("dosecomp" :depends-on ("beams"
+ "brachy" "dose-results"
+ "beam-dose" "electron-dose" "brachy-dose"
+ "plans" "patients"))
+ ("spots" :depends-on ("volumes"))
+ ("scan" :depends-on ("volumes" "dose-grids" "patients" "plans" "spots"))
+
+ ;; DICOM-RT client support
+ ("cstore-status")
+ ("imrt-segments" :depends-on ("beams"))
+ ("mlc-collimators" :depends-on ("collim-info" "collimators" "mlc"))
+ ("dicom-rtplan" :depends-on ("patients" "plans" "beams" "cstore-status"))
+ ("dmp-panel" :depends-on ("imrt-segments"))
+
+ ;; Printed output.
+ ("charts" :depends-on ("prism-globals"
+ "beams" "wedges" "collimators" "misc"
+ "plans" "patients" "contours" "dosecomp"
+ "dose-results" "therapy-machines"
+ "collim-info" "mlc" "mlc-collimators"
+ "points"))
+ ("plots" :depends-on ("prism-globals"
+ "prism-objects" "misc" "plans" "dose-grids"
+ "views" "view-graphics" "beams-eye-views"
+ "dose-results" "dose-surface-graphics"
+ "pixel-graphics"))
+
+ ;; Control panels.
+ ("view-panels" :depends-on ("prism-objects"
+ "views" "beams-eye-views" "plots"
+ "tape-measure"))
+ ("dvh-panel" :depends-on ("plans" "scan"))
+ ("digitizer")
+ ("bev-draw-all" :depends-on ("beam-block-graphics"
+ "plans" "patients"
+ "points" "point-graphics"
+ "volumes" "volume-graphics"
+ "beams" "beam-graphics"
+ "views" "beams-eye-views"))
+ ("autocontour")
+ ("planar-editor" :depends-on ("prism-globals"
+ "misc" "autocontour" "points"
+ "prism-objects" "digitizer"
+ "pixel-graphics" "tape-measure"))
+ ("mlc-panels" :depends-on ("prism-objects"
+ "views" "beams" "beam-blocks"
+ "therapy-machines" "collim-info"
+ "beams-eye-views"
+ "plans" "patients" "bev-draw-all"
+ "mlc" "planar-editor" "view-panels"))
+ ("coll-panels" :depends-on ("collimators"
+ "beams" "views" "beams-eye-views"
+ "plans" "patients" "bev-draw-all"
+ "planar-editor" "planar-editor"
+ "mlc-panels" "charts" "volumes"))
+ ("selector-panels" :depends-on ("prism-objects"))
+ ("beam-block-panels" :depends-on ("prism-objects" "selector-panels"
+ "prism-globals" "attribute-editor"
+ "beams" "beam-blocks"
+ "therapy-machines"
+ "views" "beams-eye-views"
+ "planar-editor" "bev-draw-all"
+ "plans" "patients" "view-panels"))
+ ("beam-panels" :depends-on ("prism-globals"
+ "prism-objects" "misc" "selector-panels"
+ "beams" "beam-blocks" "wedges"
+ "therapy-machines" "plans" "patients"
+ "beam-block-panels" "coll-panels"))
+ ("brachy-specs-panels" :depends-on ("misc" "brachy-tables" "brachy"))
+ ("brachy-coord-panels" :depends-on ("digitizer"
+ "brachy" "brachy-specs-panels"))
+ ("brachy-dose-panels" :depends-on ("brachy" "dose-results" "brachy-dose"))
+ ("brachy-panels" :depends-on ("prism-objects"
+ "brachy-tables" "brachy" "brachy-graphics"
+ "brachy-specs-panels" "brachy-dose-panels"
+ "brachy-coord-panels"))
+ ("point-dose-panels" :depends-on ("prism-objects"
+ "plans" "patients" "points" "beams"
+ "dose-results" "dosecomp" "misc"))
+ ("dose-surface-panels" :depends-on ("prism-objects" "dose-results"))
+
+ ;; Patient database functions.
+ ("prism-db" :depends-on ("file-functions"
+ "misc" "patients" "plans" "medical-images"))
+
+ ;; The plan panel.
+ ("plan-panels" :depends-on ("prism-objects"
+ "prism-globals" "selector-panels"
+ "plans" "patients"
+ "prism-db" "views" "charts"
+ "misc" "object-manager"
+ "dose-grids" "dose-results"
+ "dosecomp" "view-panels" "beam-panels"
+ "dose-surface-panels" "brachy-panels"
+ "point-dose-panels"))
+
+ ;; Special functions for patient panel and subpanels.
+ ("attribute-editor" :depends-on ("prism-objects" "volumes" "points"
+ "planar-editor"))
+ ("filmstrip" :depends-on ("misc"
+ "contours" "medical-images"
+ "volume-graphics" "view-graphics"))
+
+ ;; new version of PTV tool
+ ("inference") ;; the Graham mock prolog code
+ ("anatomy-tree" :depends-on ("inference" "file-functions"))
+ ("margin-rules" :depends-on ("inference" "anatomy-tree"))
+ ("target-volume" :depends-on ("inference"
+ "margin-rules" "contours" "volumes"))
+ ("ptvt-expand" :depends-on ("target-volume" "volumes"))
+
+ ("linear-expand" :depends-on ("contours"
+ "volumes" "misc"))
+ ("autovolume" :depends-on ("medical-images"
+ "pixel-graphics" "contours" "volumes"
+ "planar-editor" "filmstrip" "autocontour"))
+ ("auto-extend-panels" :depends-on ("medical-images"
+ "volumes" "contours" "autovolume"))
+ ("volume-editor" :depends-on ("prism-globals"
+ "misc" "prism-objects"
+ "medical-images" "volumes" "contours"
+ "planar-editor" "filmstrip"
+ "selector-panels" "linear-expand"
+ "ptvt-expand" "attribute-editor"
+ "autovolume" "auto-extend-panels"
+ "volume-graphics" "view-graphics"))
+ ("patdb-panels" :depends-on ("prism-globals"
+ "plans" "patients" "prism-db"))
+ ("write-neutron" :depends-on ("prism-globals"
+ "prism-objects" "charts"
+ "misc" "plans" "patients"
+ "beams" "wedges" "collimators"
+ "therapy-machines" "collim-info"
+ "mlc"))
+ ("import-structure-sets" :depends-on ("prism-objects"
+ "file-functions" "volumes"
+ "contours" "patients"))
+ ("dicom-panel" :depends-on ("prism-objects" "mlc-collimators"
+ "collimators" "therapy-machines"
+ "beams" "wedges" "plans" "patients"
+ "collim-info" "charts" "imrt-segments"
+ "cstore-status" "dmp-panel"))
+ ("tools-panel" :depends-on ("prism-globals"))
+
+ ;; The patient panel.
+ ("patient-panels" :depends-on ("prism-objects"
+ "prism-globals" "prism-db"
+ "patients" "selector-panels"
+ "volumes" "volume-editor"
+ "plans" "plan-panels" "patdb-panels"
+ "tools-panel" "dvh-panel"))
+
+ ;; The top level.
+ ("prism" :depends-on ("prism-globals"
+ "misc" "file-functions" "patients" "plans"
+ "patient-panels" "digitizer" "brachy-tables"
+ "dosecomp" "therapy-machines"))))
+
+;;;-------------------------------------
+;;; End.
diff --git a/systemdefs/slik.system b/systemdefs/slik.system
new file mode 100644
index 0000000..d917089
--- /dev/null
+++ b/systemdefs/slik.system
@@ -0,0 +1,120 @@
+;;;
+;;; slik.system
+;;;
+;;; This file contains the definitions and exported symbols of the SLIK
+;;; toolkit. It depends on the CMU defsystem package, and is loaded
+;;; from a system definitions repository. All the slik files
+;;; themselves should be in a subdirectory of your working directory,
+;;; named slik/src/ and there should be a slik/bin/ subdirectory for
+;;; the compiled files.
+;;;
+;;; 13-Apr-1992 I. Kalet created
+;;; 24-May-1992 I. Kalet move exports here from the various modules
+;;; 9-Jun-1992 I. Kalet I gave up. Use defsys.
+;;; 19-Jun-1992 J. Unger modify for use with CMU defsystem.
+;;; 2-Jul-1992 I. Kalet change behaviors to events
+;;; 6-Jul-1992 I. Kalet add make-list-button,
+;;; make-radio-scrolling-list to export list
+;;; 2-Nov-1992 I. Kalet add new stuff to export list, remove refresh,
+;;; alphabetize the list, other cosmetics, also add module dialogboxes
+;;; 27-Nov-1992 I. Kalet add sliderboxes module
+;;; 12-Feb-1993 I. Kalet export width and height
+;;; 27-Feb-1993 I. Kalet make menus depend on buttons
+;;; 02-Mar-1993 J. Unger add some cmu read time conditionals.
+;;; 27-Jul-1993 I. Kalet fix up for lucid also
+;;; 6-Aug-1993 I. Kalet export symbol invisible
+;;; 16-Nov-1993 I. Kalet add some genera read time conditionals.
+;;; 17-Apr-1994 I. Kalet add more exports from picture code
+;;; 21-Apr-1994 J. Unger add adj-sliderboxes dependencies & exports
+;;; 25-Apr-1994 I. Kalet export make-square-pixmap
+;;; 9-May-1994 I. Kalet export make-raw-graymap and map-raw-image
+;;; 16-May-1994 J. Unger add textboxes & dialogboxes dependencies, exports
+;;; 22-May-1994 I. Kalet export update-pickable-object
+;;; 5-Jun-1994 I. Kalet export host
+;;; 20-Jun-1994 J. Unger export point-near-segment
+;;; 11-Jul-1994 J. Unger export x1 y1 x2 y2 thickness tolerance.
+;;; 03-Oct-1994 J. Unger export dashed color names.
+;;; 3-Jan-1995 I. Kalet include events and collections as part of
+;;; SLIK and update other dependencies following the big code review.
+;;; 13-Aug-1995 I. Kalet add support for Harlequin Lispworks
+;;; 1-Feb-1996 I. Kalet remove conditionals for make-package
+;;; vs. defpackage, just assume defpackage and merge exports in
+;;; 8-Oct-1996 I. Kalet export find-dashed-color and find-solid-color
+;;; 18-Apr-1997 I. Kalet drop support for old CMU with PCL, assume
+;;; native CLOS
+;;; 25-Apr-1997 I. Kalet add popup-textline and export it.
+;;; 9-Jun-1997 I. Kalet export make-icon-button and
+;;; make-arrow-button, button-2-on.
+;;; 26-Dec-1997 I. Kalet make spreadsheet function part of SLIK
+;;; 26-Feb-1998 I. Kalet add some exports from spreadsheet.
+;;; 03-Nov-1998 C. Wilcox added 2d-plot
+;;; 16-Dec-1998 I. Kalet add M. Lease's scrollbars, add some new
+;;; exports from scrolling lists.
+;;; 22-Mar-1999 I. Kalet export new scrolling list function, reorder-buttons
+;;; 22-Apr-1999 I. Kalet add new exports for handling multiple colormaps
+;;; 24-Jun-1999 J. Zeman move postscript package here from Prism-system
+;;; 25-Apr-2000 I. Kalet export new cell-object function for spreadsheets
+;;; 27-May-2000 I. Kalet export Helvetica medium font names, now supported
+;;; 31-May-2000 I. Kalet provide new global variable *default-font-name*
+;;; 17-Jul-2000 I. Kalet export new split image functions, delete
+;;; map-image-to-clx, add GL functions and support files, also export
+;;; *NUM-GRAY-PIXELS* for the autovolume code.
+;;; 13-Mar-2001 I. Kalet add default-fg, default-bg as default widget
+;;; foreground and background, add *fg-level* and *bg-level* as
+;;; settable parameters, also *default-border-style*. Export
+;;; allow-button-2 in buttons.
+;;; 16-Aug-2002 J. Sager export label-slider-box
+;;; 22-Sep-2002 I. Kalet export select-gl and new gl-color
+;;; 30-Jul-2003 I. Kalet move package definition to new slik file,
+;;; make compatible with new cvs code management.
+;;; 27-Nov-2003 I. Kalet update documentation at top of file.
+;;; 30-Jul-2004 I. Kalet move initialize into its own file to remove
+;;; circularities.
+;;; 25-May-2009 I. Kalet remove OpenGL support to make code Open Source
+;;;
+
+(mk:defsystem :slik
+ :source-pathname "slik/src/"
+ :binary-pathname "slik/bin/"
+ :components
+ (("slik")
+ ("events")
+ ("postscript")
+ ("collections" :depends-on ("events"))
+
+ ;; elementary machinery
+ ("clx-support") ;; fixed dependency on event-loop
+ ("event-loop" :depends-on ("clx-support"))
+ ("initialize" :depends-on ("clx-support" "event-loop"))
+
+ ;; widgets
+ ("frames" :depends-on ("events" "clx-support"))
+ ("dials" :depends-on ("events" "frames"))
+ ("sliders" :depends-on ("events" "frames"))
+ ("buttons" :depends-on ("events" "clx-support" "frames"))
+ ("scrollbars" :depends-on ("events" "frames" "sliders" "buttons"))
+ ("menus" :depends-on ("events" "clx-support" "frames" "buttons"))
+ ("textboxes" :depends-on ("events" "clx-support" "frames"))
+ ("dialogboxes" :depends-on ("clx-support" "event-loop" "frames"
+ "buttons" "menus" "textboxes"))
+ ("scrolling-lists" :depends-on ("events" "clx-support" "frames"
+ "buttons" "scrollbars"
+ "dialogboxes"))
+ ("readouts" :depends-on ("clx-support" "frames"))
+ ("textlines" :depends-on ("events" "clx-support" "frames" "readouts"
+ "buttons" "dialogboxes"))
+ ("dialboxes" :depends-on ("events" "clx-support" "frames" "dials"
+ "textlines"))
+ ("sliderboxes" :depends-on ("events" "clx-support" "frames"
+ "sliders" "textlines"))
+ ("adj-sliderboxes" :depends-on ("events" "clx-support" "sliders"
+ "textlines" "sliderboxes"))
+ ("spreadsheets" :depends-on ("events" "clx-support" "frames" "readouts"
+ "textlines" "buttons"))
+ ("pictures" :depends-on ("events" "clx-support" "frames"))
+ ("2d-plot" :depends-on ("pictures" "frames" "textlines" "postscript"))
+ ("images" :depends-on ("clx-support"))
+ ))
+
+;;;-------------------------------------
+;;; End.
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/uw-prism.git
More information about the debian-med-commit
mailing list