CCD SPOL Data-Taking Code
Screen # 0
\ CCD Spectropolarimeter Acquisition Code 19:26 02-15-02
( Last change: Screen 189 GDS 14:58 02/15/02 )
Screen # 1
\ Library Building 10:19 10-11-00
NCC \ Loads native code compiler, array, carray
I80387 \ Loads and links floating point support
TASKER \ Loads software multitasker
DOSINT \ Loads OS interface
640X480 VMODE \ Sets Vega contoller to VGA
CLS \ Clear screen
( ARRAY and CARRAY defined in NCC )
\ Filename switching
: >PROGFILE USING C:\URF386\CCDLO.SCR ;
: >HELPFILE USING C:\URF386\CCDLOHLP.SCR ;
: >STATFILE USING C:\URF386\INSTAT.SCR ;
-->
Screen # 2
\ Timing Loops 11:14 05-16-98
: LOOPS 0 ?DO LOOP ; \ each loop ~.25us on 486-66
: MS 0 ?DO 4150 LOOPS LOOP ;
-->
Screen # 3
\ Microsoft Mouse support 15:26 02-20-90
-->
Copyright (C) 1986 Laboratory Microsystems Inc.
All Rights Reserved.
This file is provided for the convenience of licensed
UR/FORTH users only. It is provided as is and without
warranty of any kind.
The code in this file depends on the resident Microsoft mouse
driver which is installed by placing a line such as
DEVICE=MOUSE.SYS
in the CONFIG.SYS file on the system boot disk.
** This code has been modified for the 386 at the ST ScI**
Screen # 4
\ Microsoft Mouse support 19:54 12-01-97
FORTH DEFINITIONS HEX
( M4 M3 M2 M1 ___ )
( dx cx bx ax ___ )
: mouse-io regEAX ! regEBX ! regECX ! regEDX !
33 INT86 ;
DECIMAL
-->
Screen # 5
\ Microsoft Mouse support 14:54 07-27-90
DECIMAL
( ___ flag : -1 installed, 0 not installed )
( cursor position = screen center, flag = -1 not displayed )
( graphics cursor = arrow /-1 -1 , text cursor = invert. box )
( interrupt call mask = all 0 - no interrupts )
( mickeys/pixel /horz = 8/8 , vert = 16 to 8 )
: MOUSE-RESET 0 0 0 0 mouse-io regEAX @ ;
( ___ : increments cursor flag by 1, tracks the motion )
: SHOW-CURSOR 0 0 0 1 mouse-io ;
( ___ : decrements flag but still tracks )
: HIDE-CURSOR 0 0 0 2 mouse-io ;
( ___ button -bit 0 = left, bit 1 = right x y )
: @POSITION 0 0 0 3 mouse-io regEBX @ regECX @ regEDX @ ;
-->
Screen # 6
\ Microsoft Mouse support 16:26 02-28-90
( ___ n : bit 0 = left button, bit 1 = right button )
: @BUTTONS 0 0 0 3 mouse-io regEBX @ ;
( x y ___ : sets new cursor position on screen )
: !POSITION SWAP 0 4 mouse-io ;
( button ___ x y press_count button_status )
( input button: 0=left,=1 right)
( returned button status is independent of input button # )
: @PRESSES 0 0 ROT 5 mouse-io
regECX @ regEDX @ regEBX @ regEAX @ ;
-->
Screen # 7
\ Microsoft Mouse support 15:58 02-15-94
( button ___ x y release_count button_status )
( button=0 left,=1 right)
: @RELEASES 0 0 ROT 6 mouse-io
regECX @ regEDX @ regEBX @ regEAX @ ;
( min max ___ )
: HORIZ-LIMITS SWAP 0 7 mouse-io ;
( min max ___ )
: VERT-LIMITS SWAP 0 8 mouse-io ;
-->
Screen # 8
\ Microsoft Mouse support 04:00 05-16-94
( hardware: start_line stop_line cursor_select =1 ___ )
( software: screen_mask cursor_mask cursor_select = 0 ___ )
: !TCUR ROT ROT SWAP ROT 10 mouse-io ;
( ___ deltax deltay ; displacement in mickeys since last call)
( positive = down, right , negative = up , left )
: @COUNTERS 0 0 0 11 mouse-io regECX @ regEDX @ ;
-->
Screen # 9
\ Microsoft Mouse support 04:00 05-16-94
( ___ )
: ENABLE-PEN 0 0 0 13 mouse-io ;
( ___ )
: DISABLE-PEN 0 0 0 14 mouse-io ;
( horiz_ratio vert_ratio --- mickeys per 8 pixels )
: !MICKEY SWAP 0 15 mouse-io ;
( mickeys/second ___ )
: SPEED_THRESHOLD 0 0 19 mouse-io ;
-->
Screen # 10
\ Read Mouse 12:36 06-30-99
0 EQU XC@ 0 EQU YC@
0 EQU LBUTTON 0 EQU RBUTTON
: READ-MOUSE 20 MS @POSITION 1+ EQU YC@ 1+ EQU XC@
DUP 2 AND EQU RBUTTON
1 AND EQU LBUTTON ;
: XYC@ XC@ YC@ ;
\ button# (1=L; 2=R) ___ wait for button release
: RELEASE BEGIN DUP @BUTTONS AND 0= UNTIL DROP ;
: LRELEASE 1 RELEASE ;
: RRELEASE 2 RELEASE ;
-->
Screen # 11
\ Miscellaneous Definitions G GDS 19:47 10-11-00
0 EQU TEMP1 0 EQU TEMP2 0 EQU TEMP3 0 EQU TEMP4
: 0! 0 SWAP ! ; \ zeros out a location
: BYTE 255 AND ; \ extracts low byte from word
: ? @ . ;
: 3.R 3 .R ;
: 4.R 4 .R ;
: 5.R 5 .R ;
: 6.R 6 .R ;
: 7.R 7 .R ;
: 10.R 10 .R ;
: QUIT ." ok" QUIT ;
-->
Screen # 12
\ Miscellaneous Definitions G GDS 16:30 01-12-99
: CRS 0 DO CR LOOP ;
: HONK 100 15 BEEP ;
: TOOT 600 15 BEEP ;
: CLICK 250 5 BEEP ;
: ANYKEY BEGIN ?TERMINAL UNTIL ;
: ?REALLY TOOT ." Are you sure (Y/N)? " KEY DUP EMIT DUP
[ ASCII Y ] LITERAL = SWAP [ ASCII y ] LITERAL = OR
IF ELSE ABORT THEN ;
: $PAUSE PAUSE ;
\ Useage: >>FILE [filename] initblock endblock PRINTFILE
: PRINTFILE 1+ SWAP DO I LIST LOOP CONSOLE ;
-->
Screen # 13
\ Useful Constants, etc. G E1 12:42 03-31-95
50 EQU LEFT 620 EQU RIGHT \ plotting boundaries
20 EQU TOP 445 EQU BOT
FVARIABLE FTEMP
0 EQU 1TEMP 0 EQU 2TEMP
0.E0 FCONSTANT FZERO
1.E0 FCONSTANT FONE
10.E0 FCONSTANT FTEN
: FSQ FDUP F* ;
: -FROT FROT FROT ;
2147483647 CONSTANT BIGGEST#
\ blk# ___ list information block from ccdinfo.scr
: HELPLIST >HELPFILE LIST >PROGFILE ;
-->
Screen # 14
\ Real-time clock readback 13:23 12-07-94
\ MC146818 clock chip is at 70-7F and uses IRQ8
HEX
70 CONSTANT RTCSEL 71 CONSTANT RTCIO
DECIMAL
\ addr ___ value Read clock register
: RTC@ RTCSEL PC! RTCIO PC@ ;
\ : BIN>BCD 10 /MOD 15 AND 16 * SWAP 15 AND + ;
: BCD>BIN DUP 15 AND SWAP 16 / 15 AND 10 * + ;
\ Decode clock to URFORTH packed format
: @RTC 4 RTC@ 2 RTC@ 0 RTC@ \ fetch clock quickly
ROT BCD>BIN >< ROT BCD>BIN +
SWAP BCD>BIN >< ;
-->
Screen # 15
\ Date and Time Conversion and Output 11:18 12-21-00
: .HMS ( Time stored in UR/FORTH packed format )
>< BYTE 0 <# # # [ ASCII : ] LITERAL HOLD
2DROP DUP BYTE 0 # # [ ASCII : ] LITERAL HOLD
2DROP >< BYTE 0 # # #> TYPE ;
: .MDY ( Date stored in UR/FORTH packed format )
SWAP 0 <# # # # # [ ASCII / ] LITERAL HOLD
2DROP DUP BYTE 0 # # [ ASCII / ] LITERAL HOLD
2DROP >< BYTE 0 # # #> TYPE ;
: .DMY ( Date stored in UR/FORTH packed format )
SWAP 0 <# # # [ ASCII / ] LITERAL HOLD
2DROP DUP >< BYTE 0 # # [ ASCII / ] LITERAL HOLD
2DROP BYTE 0 # # #> TYPE ;
-->
Screen # 16
\ Year/Month/Day for Y2k IRAF 11:18 12-21-00
: .YMD ( Date stored in UR/FORTH packed format yyyy-mm-dd )
DUP BYTE 0 <# # # [ ASCII - ] LITERAL HOLD
2DROP >< BYTE 0 # # [ ASCII - ] LITERAL HOLD
2DROP 0 # # # # #> TYPE ;
: ?UT @RTC .HMS ;
: ?DATE @DATE .YMD ;
-->
Screen # 17
\ Miscellaneous Definitions GDS 1 08:14 04-02-98
: ZERO-CURSOR 0 0 GOTOXY ;
: ESCAPE! HIDE-CURSOR CONSOLE CR ." ok"
>PROGFILE ABORT ;
: ESC? ?TERMINAL IF KEY 27 = ELSE 0 THEN ;
: ESCAPE? ESC? IF ESCAPE! THEN ;
\ order 2 nos: lower, upper
: ORDER 2 ?DEPTH 2DUP MAX >R MIN R> ;
\ value lower upper ___ limit to within boundaries
: BOUND ORDER 3 ?DEPTH ROT MIN MAX ;
\ value lower upper ___ abort if outside limits
: CHECK 3 ?DEPTH 2 PICK < >R OVER > R> +
IF HONK REVERSE 3.R ." ***Out of range!***" REVERSE
>PROGFILE ABORT THEN ;
-->
Screen # 18
( #IN GDS 18:51 03/01/90 )
\ fixes bug in URFORTH when floating-point support is loaded
: #IN ( ___ n ) 0
BEGIN KEY DUP 13 = IF DROP EXIT THEN DUP 8 =
IF EMIT 32 EMIT 8 EMIT 10 /
ELSE DUP ASCII 0 < OVER ASCII 9 > OR
IF DROP 7 EMIT
ELSE DUP EMIT ASCII 0 - SWAP 10 * + THEN
THEN
AGAIN ;
-->
Screen # 19
\ Standard Color Schemes 08:38 04-02-98
\ yellow on black in RTB color scheme
: SCREENCOLORS 6 FOREGROUND 0 BACKGROUND ;
\ brown on yellow in RTB scheme
: GRAPHCOLORS 2 FOREGROUND 6 BACKGROUND ;
\ yellow on brown in RTB scheme
: MENUCOLORS 6 FOREGROUND 2 BACKGROUND ;
-->
Screen # 20
\ Status checking 13:19 09-14-91
VARIABLE OBSERVING
VARIABLE PAUSED
: ?OBSERVING OBSERVING @ 0= IF HONK
REVERSE ." ***Obsn. not in progress!***" REVERSE
ABORT THEN ;
: ?STOPPED OBSERVING @ IF HONK
REVERSE ." ***Obsn. in progress!***" REVERSE
ABORT THEN ;
: ?PAUSED PAUSED @ 0= IF HONK
REVERSE ." ***You must first PAUSE obsn!***" REVERSE
ABORT THEN ;
-->
Screen # 21
\ Picture Buffer Dimensions GDS 2 13:29 04-23-97
\ Chip format for LORAL 1200x800
800 EQU CHIPROWS 1200 EQU CHIPCOLS
16 EQU PRESCAN 20 EQU OVERSCAN
10 EQU SKIPOVER \ pad after last column before overscan
1024 EQU HBF-LENGTH
\ Picture format
CHIPROWS EQU ROWS CHIPCOLS OVERSCAN + DUP EQU COLS
PRESCAN + SKIPOVER + EQU MAX-DMA-LENGTH
2 EQU #PBFS \ defaults
: PIC-BYTES COLS ROWS * 4* WSIZE 2* + HBF-LENGTH + ;
PIC-BYTES #PBFS * EQU PBF-TOT
CREATE PBF-START PBF-TOT ALLOT \ master pic. buf. array
8 ARRAY PBF \ picture buffer addresses
8 ARRAY PBF>P# \ corresponding picture numbers
8 ARRAY PBF>UPDATE --> \ corresponding update flags
Screen # 22
\ Picture and Header Sizes 19:21 11-17-94
\ pbf# ___ 1st addr. of data buffer
: PBF@ PBF @ ;
\ pbf# ___ xdim ydim
: PBF>DIMS PBF@ WSIZE 2* - DUP @ SWAP WSIZE + @ ;
\ pbf# ___ data bytes/pic
: PBF-LENGTH PBF>DIMS * 4* ;
\ pbf# ___ 1st addr. of header buffer
: HBF@ DUP PBF@ SWAP PBF-LENGTH + ;
\ pbf# ___ init. pic# and update arrays
: PBF-INIT -1 OVER PBF>P# ! -8 SWAP PBF>UPDATE ! ;
\ ___ init. pic# and update arrays
: ZERO-BUFFERS 8 0 DO I PBF-INIT LOOP ;
-->
Screen # 23
\ Print Chip-Format 15:01 02-14-93
0 EQU P#NOW 0 EQU P#OBS
0 EQU ROW-SKIP 0 EQU COL-SKIP
1 EQU RBIN 1 EQU CBIN
: ?FORMAT CR
." õııııııııııı CHIP FORMAT ıııııııııııÀ" CR
5 SPACES ." Start End Binning"
CR ." (x)" COL-SKIP DUP 6.R COLS OVERSCAN - CBIN * + 1- 7.R
CBIN 6.R COLS 7.R ." cols"
CR ." (y)" ROW-SKIP DUP 6.R ROWS RBIN * + 1- 7.R
RBIN 6.R ROWS 7.R ." rows"
CR ." Overscan" OVERSCAN 8 .R
CR ." Picture size" 0 PBF-LENGTH 10.R ." bytes"
CR ." Picture buffers" #PBFS 7.R CR
." Áıııııııııııııııııııııııııııııııııııã" CR ;
-->
Screen # 24
\ Dynamic Picture Buffer Allocation GDS 2 16:11 02-15-94
\ allocates max no. of picture buffers, storing xdim, ydim
: ALLOC-PBFS 8 0 DO -1 I PBF ! LOOP
ZERO-BUFFERS \ clear
PIC-BYTES PBF-TOT OVER /
8 MIN DUP EQU #PBFS \ #bufs
0 DO DUP I * PBF-START +
COLS OVER ! \ cols
WSIZE + ROWS OVER ! \ rows
WSIZE + I PBF ! \ data
LOOP DROP ?FORMAT ;
ALLOC-PBFS
: CHECK-COLS 0 COLS 1- CHECK ;
: CHECK-ROWS 0 ROWS 1- CHECK ;
-->
Screen # 25
\ On-Chip Binning GDS 12:32 07-11-94
0 EQU BINMODE
CREATE BIN-PARMS ( compiled in [col,row] order )
1 C, 1 C, 1 C, 2 C, 2 C, 1 C, 2 C, 2 C, \ modes 0-3
1 C, 1 C, 1 C, 1 C, 1 C, 1 C, 2 C, 2 C, \ modes 4-7
\ query for readout mode [0-7] [=EPROM mode]
: !MODE CR ." Choose binning mode: " #IN
0 3 CHECK DUP EQU BINMODE
2* BIN-PARMS + DUP C@ 1 2 CHECK EQU CBIN
1+ C@ 1 2 CHECK EQU RBIN ;
: .BIN CBIN . ." x " RBIN . ;
: FORMATS 6 HELPLIST ;
-->
Screen # 26
\ Status Line GDS 2 08:29 04-02-98
\ xcoor ___ positions cursor on status line
: >STAT-LINE ?XY DUP 29 = IF 1- CR THEN DUP
0 = IF 1+ THEN ROT 0 GOTOXY ;
: >SCREEN REVERSE GOTOXY ;
: STRIPE 0 >STAT-LINE REVERSE 80 SPACES >SCREEN ;
: >MSG 34 >STAT-LINE REVERSE ;
: .P# ." Pic" P#OBS 3.R ;
-->
Screen # 27
\ Status line messages 17:50 11-30-95
: .ERASING >MSG ." Erasing " >SCREEN ;
: .READING >MSG ." Reading " .BIN >SCREEN ;
: .INTEG >MSG ." Integrating " >SCREEN ;
: .PAUSED >MSG ." Paused " >SCREEN ;
: .WRITTEN >MSG TOOT .P# ." on disk " >SCREEN ;
: .KILLED >MSG TOOT .P# ." killed " >SCREEN ;
: .DONE >MSG TOOT ." Done " >SCREEN ;
: .READY >MSG ." Ready " >SCREEN ;
-->
Screen # 28
\ Picture-to-disk GDS 2 14:29 11-30-95
-->
Two files are written per picture:
Header file (ex: ha.001)
Pixel file (ex: pa.001)
Both files are written in the same subdirectory
The filename extension is automatically incremented with
the increasing value of P#NOW, the current picture number.
Screen # 29
\ String manipulation 08:47 03-12-97
\ ^str ^str ___ Move counted string. NO LENGTH CHECKING!
: CSTRMOV OVER COUNT SWAP DROP 1+ CMOVE ;
\ ^str1 ^str2 ___ ^dest Concatenate 2 counted strings
: CSTRCAT SWAP COUNT ROT COUNT STRCAT STRPCK ;
\ str len ___ Zero string
: ZSTR OVER -ROT BLANK 0 SWAP C! ;
\ addr #chars ___ Read from console into counted string
: ?STRING OVER 1+ SWAP EXPECT SPAN @ SWAP C! ;
-->
Screen # 30
\ Picture-to-disk GDS 1 00:19 12-05-97
CREATE STRPAD 81 ALLOT STRPAD 81 ZSTR
CREATE PFNAME 33 ALLOT PFNAME 33 ZSTR
CREATE HFNAME 33 ALLOT HFNAME 33 ZSTR 81 +STRBUF
\ ___ select ROOTname for header (h) and pixel (p) files
: ?ROOT CR ." Select ROOTname of output datafile:"
STRPAD 81 ZSTR STRPAD 32 ?STRING
STRPAD COUNT -PATH OVER DUP 1+ ROT CMOVE>
[ ASCII p ] LITERAL SWAP C!
STRPAD COUNT 1+ STRPCK DUP PFNAME CSTRMOV
[ ASCII h ] LITERAL SWAP COUNT
[ ASCII p ] LITERAL SCAN DROP C!
STRBUF HFNAME CSTRMOV ;
-->
Screen # 31
\ Picture-to-disk GDS 2 09:09 03-12-97
HCB HFILE HCB PFILE
\ pic# ^str ___ add filename extension based on picture num
: +EXTENSION DUP >R -EXT SWAP ABS 1000 MOD 0 <# # # #
[ ASCII . ] LITERAL HOLD #> STRPCK +EXT R> CSTRMOV ;
\ pic# ___ creates filenames with pic# as extension
: NEW-NAMES DUP HFNAME +EXTENSION PFNAME +EXTENSION
HFNAME HFILE NAME>HCB PFNAME PFILE NAME>HCB ;
\ increment P#
: P#NEXT P#OBS DUP IF 1+ DUP EQU P#NOW EQU P#OBS
ELSE DROP THEN ;
-->
Screen # 32
\ Set picture number 14:37 07-12-91
VARIABLE DATAFILE
\ check for entered datafile
: ?DATAFILE DATAFILE @ 0= IF HONK
REVERSE ." ***You must first OPEN-DATAFILE***" REVERSE
ABORT THEN ;
\ select initial picture number
: !P# ?DATAFILE
CR ." Enter 1st pic. number [0 for testing]:"
#IN SPACE DUP EQU P#NOW 0= IF TOOT CR
REVERSE ." ***Disk-writing inhibited***" REVERSE THEN ;
-->
Screen # 33
\ Picture-to-disk GDS 2 14:23 03-11-97
\ hcb ___ filestat
: FILECHK DUP 0 FOPEN SWAP FCLOSE DROP ;
\ hcb ___ continue if file absent
: ?FILE-ABSENT DUP FILECHK 0= IF HONK
REVERSE ." ***File " .FNAME ." exists!***"
REVERSE ABORT THEN DROP ;
\ hcb ___ continue if file present
: ?FILE-PRESENT DUP FILECHK IF HONK
REVERSE ." ***File " .FNAME ." not on disk***" REVERSE
ABORT THEN DROP ;
: NEXT-DATAFILES P#NOW NEW-NAMES
P#NOW 0> IF HFILE ?FILE-ABSENT PFILE ?FILE-ABSENT THEN ;
-->
Screen # 34
\ Picture-to-disk 15:38 11-30-95
\ ___ deletes current picture
: DELETE-PIC HFILE DUP ?FILE-PRESENT FDEL DROP
PFILE DUP ?FILE-PRESENT FDEL DROP ;
\ hcb addr bytes ___ bytes written write file to disk
: WRITE-FILE 2 PICK DUP >R 0 FMAKE DROP
DUP >R FWRITE R> = 0=
R> FCLOSE DROP ;
\ pbf# ___ stat write header & picture to disk
: WRITE-H&P DUP HFILE OVER HBF@ HBF-LENGTH WRITE-FILE >R
PFILE OVER PBF@ ROT PBF-LENGTH WRITE-FILE R>
+ SWAP PBF>UPDATE 0! ;
-->
Screen # 35
\ Picture-to-disk GDS 2 17:59 11-30-95
\ pbf# ___ write entire picture to disk; checking for space
: WRITE-PIC DUP WRITE-H&P
IF HONK CR REVERSE ." !!!DISK FULL!!!" REVERSE
DELETE-PIC
1000 998 DO I NEW-NAMES DELETE-PIC LOOP
NEXT-DATAFILES WRITE-H&P HONK
THEN DROP ;
\ select datafiles and writes 2 blank pictures with reserved
\ numbers
: OPEN-DATAFILE ZERO-BUFFERS ?ROOT DATAFILE ON !P#
1000 998 DO I NEW-NAMES 0 WRITE-PIC LOOP
NEXT-DATAFILES ;
-->
Screen # 36
\ Search Picture Buffers GDS 2 15:25 11-30-95
\ pic# ___ returns pbf# if resident
: PIC_IN_CORE? 0 997 CHECK -1 SWAP
8 0 DO I PBF>P# @ OVER = IF NIP I SWAP THEN LOOP DROP ;
\ pbf# ___ decr. all updates except selected pbuf => 0
: RANK-PBFS DUP PBF>UPDATE @ 0< IF 8 0 OBSERVING @ IF 2+ THEN
DO I PBF>UPDATE DUP @ 0> IF DROP ELSE -1 SWAP +! THEN LOOP
PBF>UPDATE 0! ELSE DROP THEN ;
\ ___ least-recently used pbf#
: FREE-PBF -1 1 ( init pbf addr. and update value )
8 0 OBSERVING @ IF 2+ THEN
DO I PBF@ 0< IF ELSE DUP I PBF>UPDATE @ >
IF 2DROP I DUP PBF>UPDATE @
THEN THEN LOOP DROP DUP 0<
IF HONK REVERSE ." ***No free picture buffers***" REVERSE
ABORT THEN DUP RANK-PBFS ; -->
Screen # 37
\ Header Manipulation GDS 19:28 10-27-00
CREATE NAME 32 ALLOT NAME 32 BLANK
CREATE COMMNT 32 ALLOT COMMNT 32 BLANK
\ address ___ reads 32 chars into array
: 32-IN CR ." >" DUP 32 BLANK 32 EXPECT ;
: label NAME 32-IN ;
: LABEL label QUIT ;
: COMMENT COMMNT 32-IN QUIT ;
\ index pbf# ___ header addr. Header entries are 4 bytes
: H# HBF@ SWAP 4* + ;
\ index pbf# ___ header contents
: H@ H# @ ;
: H2@ H# 2@ ;
\ value index pbf# ___
: H! H# ! ;
: H2! H# 2! ; -->
Screen # 38
\ Type out header 20:57 11-24-94
: 5.HR ?XY SWAP 20 + SWAP GOTOXY 5.R CR ; \ header listing
\ pbf# ___ types out image title
: .TITLE 11 OVER H@ ." Pic#" 3.R 2 SPACES
64 SWAP H# 32 TYPE ;
\ pbf# ___ types out image comments
: .COMMENTS 72 SWAP H# 20 TYPE ;
\ pbf# ___ types out header
: .HEADER 1 HELPLIST ZERO-CURSOR
DUP .TITLE DUP 2 SPACES .COMMENTS CR
5 1 DO I OVER H@ 5.HR LOOP
5 OVER H2@ ?XY SWAP 15 + SWAP GOTOXY .MDY CR
17 7 DO I OVER H@ 5.HR LOOP
17 SWAP H@ S>F 1.E3 F/ ?XY SWAP 20 + SWAP GOTOXY
3 PLACES 5 F.R CR ; -->
Screen # 39
\ Low-Level Picture code 15:19 07-17-91
\ pbf# ___ check rows and cols of header vs. buffer
: ?ROWS&COLS 3 OVER H@ COLS <> >R 4 OVER H@ ROWS <> R> +
IF DUP .HEADER ?FORMAT CR HONK REVERSE
." ***Picture & buffer dimensions do not match!***"
REVERSE PBF-INIT ABORT
THEN DROP ;
\ pbf# ___ tags updates, sets row and column variables
: ROWS&COLS DUP RANK-PBFS PBF>DIMS EQU ROWS EQU COLS ;
-->
Screen # 40
\ Read picture from disk 16:10 06-19-91
\ hcb addr bytes ___ read file from disk
: READ-FILE 2 PICK DUP >R 0 FOPEN DROP
FREAD DROP R> FCLOSE DROP ;
\ pic# ___ pbf#
: PIC>CORE DUP PIC_IN_CORE? DUP 0<
IF DROP ?DATAFILE DUP NEW-NAMES
HFILE ?FILE-PRESENT PFILE ?FILE-PRESENT
FREE-PBF DUP DUP ROWS&COLS
HFILE OVER HBF@ HBF-LENGTH READ-FILE
PFILE OVER PBF@ ROT PBF-LENGTH READ-FILE
DUP ?ROWS&COLS TUCK PBF>P# !
ELSE NIP DUP ROWS&COLS THEN ;
-->
Screen # 41
\ Higher level picture access GDS 2 17:29 11-30-95
\ pic# ___ pbf# with update flag set
: WPIC>CORE PIC>CORE 1 OVER PBF>UPDATE ! ;
\ ___ write all pictures with update=1
: PFLUSH 8 0 OBSERVING @ IF 2+ THEN
DO I PBF>UPDATE @ 0>
IF I PBF>P# @ NEW-NAMES I WRITE-PIC THEN LOOP ;
\ diagnostic
: BUFFERS CR ." Buffer Pic# Rank Cols Rows"
8 0 DO I PBF@ 0> IF CR I 5.R I PBF>P# @ 6.R
I PBF>UPDATE @ 6.R I PBF>DIMS
SWAP 6.R 6.R THEN LOOP CR ;
-->
Screen # 42
\ Waveplate and add sequences 09:35 12-06-95
CREATE WAVE-SEQUENCE
0 C, -1 C, -1 C, -1 C, -1 C, -1 C, -1 C, -1 C, \ Snapshot
3 C, 7 C, 11 C, 15 C, 1 C, 5 C, 9 C, 13 C, \ Q sequence
2 C, 6 C, 10 C, 14 C, 0 C, 4 C, 8 C, 12 C, \ U sequence
4 C, 12 C, 0 C, 8 C, -1 C, -1 C, -1 C, -1 C, \ V sequence
\ modified 10/04/91 by GDS to correct sign discrepancies
\ modified 11/27/93 by GDS to correct sign discrepancy in V
\ modified 11/24/94 by GDS to test different coadd method
\ modified 12/05/95 by GDS for new half waveplate
CREATE ADD-SEQUENCE \ Terminate with -1
0 , -1 , -1 , -1 , -1 , -1 , -1 , -1 , -1 , \ Snapshot
0 , 0 , 0 , 0 , 1 , 1 , 1 , 1 , -1 , \ Q sequence
0 , 0 , 0 , 0 , 1 , 1 , 1 , 1 , -1 , \ U sequence
0 , 0 , 1 , 1 , -1 , -1 , -1 , -1 , -1 , \ V sequence
-->
Screen # 43
\ Waveplate/Coadd scheme GDS 1 19:07 05-14-98
0 EQU #SEQUENCE 0 EQU #EXP \ exp no in chopping sequence
\ sequence index ___ waveplate psn
: ?WAVE #SEQUENCE 8 * + WAVE-SEQUENCE + C@ ;
\ sequence index ___ buffer for addition
: ?PBF #SEQUENCE 9 * + WSIZE * ADD-SEQUENCE + @ ;
\ ___ flag for 1st or last exposure in coadding series
: NEW-EXP? #EXP ?PBF #EXP 1- ?PBF = 0= ;
: LAST-EXP? #EXP ?PBF #EXP 1+ ?PBF = 0= ;
: !SEQUENCE ?STOPPED 0 3 CHECK EQU #SEQUENCE ;
: SNAPSHOT 0 !SEQUENCE ;
: Q-SEQUENCE 1 !SEQUENCE ;
: U-SEQUENCE 2 !SEQUENCE ;
: V-SEQUENCE 3 !SEQUENCE ;
-->
Screen # 44
\ Row and pixel operators GDS 1 09:01 05-17-91
\ j pic# ___ returns row address
: ROW PIC>CORE PBF@ SWAP COLS * 4* + ;
\ i j pic# ____ returns pixel address
: IJP ROW SWAP 4* + ;
\ value i j pic# ___ stores a value
: IJP! IJP ! ;
: IJP@ IJP @ ;
-->
Screen # 45
\ Picture arithmetic area: unary operators GDS 2 08:20 05-15-98
VARIABLE P_OPERATOR
\ i j pic# ___ writes out 25 word block
: IJP. DUP CR 5.R -ROT \ pic#
SWAP DUP 3 + OVER 2- DO I 6.R LOOP \ print cols
SWAP DUP 3 + SWAP 2- DO CR I 5.R \ print row
DUP DUP 3 + SWAP 2- DO OVER I J ROT IJP@ 6.R
LOOP LOOP 2DROP CR ; \ clean up
\ row addr. ___
COMPILE: comUROW 0 DO DUP @
P_OPERATOR PERFORM OVER ! 4+ LOOP ;
\ destpic# ' operator _____ creates a picture
: PUNARY P_OPERATOR ! WPIC>CORE PBF@
ROWS 0 DO COLS comUROW \ call compiled loop
ESCAPE? PAUSE LOOP DROP PFLUSH ;
-->
Screen # 46
\ Picture arithmetic, binary operators GDS 2 08:20 05-15-98
\ source row. addr., source dest. addr on stack
COMPILE: comBROW \ compiled inner loop
0 DO OVER @ OVER @
P_OPERATOR PERFORM OVER !
4+ SWAP 4+ SWAP LOOP ;
\ source pic# dest pic# ' operator ______
: PBINARY P_OPERATOR !
WPIC>CORE PBF@ SWAP PIC>CORE PBF@ SWAP
ROWS 0 DO COLS comBROW \ execute compiled code
ESCAPE? PAUSE LOOP 2DROP PFLUSH ;
-->
Screen # 47
\ Actual Binary Operators for users GDS 2 09:01 05-17-91
0 EQU 1PC 0 EQU 2PC
: P+ ['] + PBINARY ;
: P- ['] - PBINARY ;
: P* ['] * PBINARY ;
: P/ ['] / PBINARY ;
: .PB*/ 1PC SWAP */ ;
\ s pic, scalar, des. pic ____ mult by scalar div by pic
: P*/ SWAP EQU 1PC ['] .PB*/ PBINARY ;
: P> ['] MAX PBINARY ;
: P< ['] MIN PBINARY ;
-->
Screen # 48
\ User Unitary Picture Operators GDS 2 09:01 05-17-91
\ pic# scalar ____ is the standard
: PNEGATE ['] NEGATE PUNARY ;
: .SQ DUP * ;
: PSQ ['] .SQ PUNARY ;
: .PMIN 1PC MIN ;
: PMIN EQU 1PC ['] .PMIN PUNARY ;
: .PMAX 1PC MAX ;
: PMAX EQU 1PC ['] .PMAX PUNARY ;
-->
Screen # 49
\ More user unitary operators GDS 2 09:16 09-05-91
\ pic# scalar _____
: .P- 1PC - ;
: .P+ 1PC + ;
: .P* 1PC * ;
: .P/ 1PC / ;
: .P*/ 1PC 2PC */ ;
: PS+ EQU 1PC ['] .P+ PUNARY ;
: PS- EQU 1PC ['] .P- PUNARY ;
: PS* EQU 1PC ['] .P* PUNARY ;
: PS/ EQU 1PC ['] .P/ PUNARY ;
: PS*/ EQU 2PC EQU 1PC ['] .P*/ PUNARY ;
-->
Screen # 50
\ Test Pictures ( PFLAT, PSHADE, etc. ) 17:33 02-27-02
-->
( pic#, value ___ creates a constant picture )
: .PF 2DROP 1PC ;
: PFLAT EQU 1PC ['] .PF PWRITE ;
( pic# ___ creates picture with pixel = pix# )
: .PS COLS * + ;
: PSHADE ['] .PS PWRITE ;
( pic# value ___ creates picture with 2 bars )
: .PB DROP 16 AND IF 1PC ELSE 0 THEN ;
: PBAR EQU 1PC ['] .PB PWRITE ;
( pic# #ramp ___ creates picture with user# ramp)
: .PBS DROP 1PC AND ;
: PBARS EQU 1PC ['] .PBS PWRITE ;
: .HBARS DROP 1PC / ;
: HBARS EQU 1PC ['] .HBARS PWRITE ;
Screen # 51
\ Function Keys G GDS 19:48 10-11-00
CREATE FUNKEY 48 ALLOT
' NOOP FUNKEY ! FUNKEY DUP WSIZE + 46 CMOVE ( Zero table )
: !FUNKEY 1- WSIZE * FUNKEY + ! ;
vKEY @ CONSTANT OLD-vKEY \ save old KEY vector
HEX
: GETKEY 800 regEAX ! 21 INT86 regEAX @ FF AND ;
DECIMAL
: NEWKEY OLD-vKEY EXECUTE DUP 0= IF 2DROP GETKEY 59 -
0 9 CHECK WSIZE * FUNKEY + PERFORM QUIT THEN ;
' NEWKEY CONSTANT NEW-vKEY \ make new KEY vector
: FUNKEY-ON NEW-vKEY vKEY ! ;
: FUNKEY-OFF OLD-vKEY vKEY ! ;
: COLD FUNKEY-OFF COLD ;
: BYE FUNKEY-OFF BYE ;
: EDIT FUNKEY-OFF EDIT ; -->
Screen # 52
\ Keylabels G GDS 09:52 05-18-98
8 EQU HBLOCK \ in ccdlohlp.scr
: KEYLABELS ?XY 0 27 GOTOXY REVERSE 1 4.R 4 SPACES
11 2 DO ." ¦" I 4.R 3 SPACES LOOP
." Help ¦ Status¦ Go ¦ TV ¦ Menus ¦"
." Explain¦ Mouse ¦ Format¦OpenDat¦ Test "
REVERSE GOTOXY ;
: HELP >HELPFILE HBLOCK LIST KEYLABELS
5 3 GOTOXY REVERSE ." choose one:" REVERSE SPACE
KEY 48 - DUP 0 < OVER 9 > +
IF DROP
ELSE HBLOCK + 1+ LIST
THEN >PROGFILE 0 17 GOTOXY ;
-->
Screen # 53
\ Set up the Video Mode GDS 1 08:02 04-02-98
CREATE CURRENT_PALETTE 17 ALLOT
4 EQU FRGRND_COLOR
0 EQU BKGRND_COLOR
: CP@ CURRENT_PALETTE + C@ ;
: GRAPHICS 640X480 VMODE CURRENT_PALETTE !PALETTE ;
: TEXT 80X25 VMODE CLS ;
( palbyte address ___ changes the color tablet, )
: CHANGE_PALETTE GRAPHICS
CURRENT_PALETTE 17 CMOVE \ copies palette
CURRENT_PALETTE !PALETTE 16 CP@ DUP FOREGROUND
EQU FRGRND_COLOR 0 CP@ DUP BACKGROUND
EQU BKGRND_COLOR ;
: PAL_ARRAY CREATE DOES> CHANGE_PALETTE ;
-->
Screen # 54
\ Create colors in 16 color GDS 2 07:47 04-02-98
: EGA_COLOR CREATE , DOES> @ OR ; \ creates the color msk
0 EQU egaBLK \ All colors start
63 EQU egaWHT \ white
1 EGA_COLOR egaBB \ bright blue
2 EGA_COLOR egaBG \ bright green
4 EGA_COLOR egaBR \ bright red
8 EGA_COLOR egaFB \ faint blue
16 EGA_COLOR egaFG \ faint green
32 EGA_COLOR egaFR \ faint red
9 EGA_COLOR egaBFB \ faint+bright blue
18 EGA_COLOR egaBFG \ faint+bright green
36 EGA_COLOR egaBFR \ faint+bright red
-->
Screen # 55
\ Pallete support - 16 colors GDS 2 07:08 04-02-98
PAL_ARRAY RTB ( red-to-blue )
egaBLK C, egaBLK egaBFR C,
egaBLK egaBR C, egaBLK egaBFR egaFG C,
egaBLK egaBFR egaFB egaFG C, egaBLK egaBFR egaBG egaFB C,
egaBLK egaBFR egaBFG egaBB C, egaBLK egaBFR egaBFG egaBFB C,
egaBLK egaBR egaBFG egaBFB C, egaBLK egaFR egaBFG egaBFB C,
egaBLK egaFR egaBG egaBFB C, egaBLK egaFR egaFG egaBFB C,
egaBLK egaBFB egaFG C, egaBLK egaBFB C,
egaBLK egaBB C, egaBLK egaFB C,
11 C,
-->
Screen # 56
\ Pallete support - 16 colors GDS 2 20:04 03-24-90
PAL_ARRAY RGB ( red-green-blue )
egaBLK C, egaBLK egaBFR C,
egaBLK egaBR C, egaBLK egaBFR egaFG C,
egaBLK egaBR egaFG C, egaBLK egaBR egaBG C,
egaBLK egaFR egaBG C, egaBLK egaBG C,
egaBLK egaBFG C, egaBLK egaBFG egaFB C,
egaBLK egaBFG egaBB C, egaBLK egaBFG egaBFB C,
egaBLK egaBG egaBFB C, egaBLK egaFG egaBFB C,
egaBLK egaBFB C, egaBLK egaBB C,
11 C,
-->
Screen # 57
( Pallete support - 16 colors GDS 20:04 02/12/90 )
PAL_ARRAY RGBP ( red-green-blue-purple )
egaBLK C, egaBLK egaBFR C,
egaBLK egaBFR egaFG C, egaBLK egaBFR egaBG C,
egaBLK egaBFR egaBFG C, egaBLK egaBR egaBFG C,
egaBLK egaFR egaBFG C, egaBLK egaBFG C,
egaBLK egaBFG egaFB C, egaBLK egaBFG egaBB C,
egaBLK egaBFG egaBFB C, egaBLK egaBG egaBFB C,
egaBLK egaBFB C, egaBLK egaFR egaBFB C,
egaBLK egaBR egaBFB C, egaBLK egaBFR egaBFB C,
12 C,
-->
Screen # 58
( Pallete support - 16 colors GDS 20:04 02/12/90 )
PAL_ARRAY RNDM ( random )
egaBLK C, egaBLK egaBFR C,
egaBLK egaFG egaBB C, egaBLK egaBFR egaFB C,
egaBLK egaBR egaBFG C, egaBLK egaFR egaFG egaFB C,
egaBLK egaFR egaBFG egaFB C, egaBLK egaBFB C,
egaBLK egaBFR egaFG egaFB C, egaBLK egaBFR egaBFG C,
egaBLK egaFG C, egaBLK egaBR egaBB C,
egaBLK egaBFB C, egaBLK egaBFR egaBFG egaBFB C,
egaBLK egaBFG egaBFB C, egaBLK egaBFR egaBFB C,
9 C,
-->
Screen # 59
\ 4&8 color, show palette GDS 2 16:24 02-11-93
( assumes 0 contains background color )
: 8_COLOR 16 1 DO I 1- 2 MOD IF I 1- CP@
I CURRENT_PALETTE + C! THEN LOOP
CURRENT_PALETTE CHANGE_PALETTE ;
: 4_COLOR 16 1 DO I 1- 4 MOD IF I 1- 4 / 4 * 1+ CP@
I CURRENT_PALETTE + C! THEN LOOP
CURRENT_PALETTE CHANGE_PALETTE ;
: SHOW_PALETTE
16 0 DO CR I FOREGROUND I DUP . CP@ .
FRGRND_COLOR FOREGROUND LOOP ;
( palpos , number ___ shows changed pallete )
: QP CURRENT_PALETTE + C!
CURRENT_PALETTE CHANGE_PALETTE
CLS SHOW_PALETTE ;
-->
Screen # 60
\ Creation of Video Window Tables GDS 1 11:20 07-11-91
( ____ pwt makes an array to hold graphics info for )
( each picture/graphics window)
VARIABLE CURRENT_WINDOW_TABLE
: VWINDOW CREATE WSIZE 20 * ALLOT
DOES> CURRENT_WINDOW_TABLE ! ; \ sets current window
( n ___ VW@ creates fetch out of current table )
: VW@ CREATE , DOES> @ WSIZE *
CURRENT_WINDOW_TABLE @ + @ ;
( n ___ VW! pushes into current window table )
: VW! CREATE , DOES> @ WSIZE *
CURRENT_WINDOW_TABLE @ + ! ;
-->
Screen # 61
\ Creation of Video Window Tables GDS 2 12:55 06-19-91
0 VW@ VX0@ 0 VW! VX0! \ zero point on ulc
1 VW@ VY0@ 1 VW! VY0! \ zero point on ulc
2 VW@ VXDIM@ 2 VW! VXDIM! \ xlength
3 VW@ VYDIM@ 3 VW! VYDIM! \ ylength
4 VW@ VPIC@ 4 VW! VPIC! \ current video picture buffer
5 VW@ VPX0@ 5 VW! VPX0! \ picture zero point ulc
6 VW@ VPY0@ 6 VW! VPY0! \ picture zero point ulc
7 VW@ DECIMATE@ 7 VW! DECIMATE! \ pixel skip number
8 VW@ ZOOM@ 8 VW! ZOOM! \ pixel dupl. number
9 VW@ BIAS@ 9 VW! BIAS! \ bias subtract value
10 VW@ SHIFT@ 10 VW! SHIFT! \ pixel right shift value
11 VW@ VXCOOR@ 11 VW! VXCOOR! \ pixel readout location
12 VW@ VYCOOR@ 12 VW! VYCOOR! \ pixel readout location
\ 13-15 = unused
-->
Screen # 62
\ Video and Pixel Coordinate Translation 12:55 08-09-91
: PIC>PIX_SCALE ZOOM@ DECIMATE@ */ ;
: PIX>PIC_SCALE DECIMATE@ ZOOM@ */ ;
\ current video picture #
: VP# VPIC@ PBF>P# @ ;
\ video coordinates to picture coordinates
: PICXY>PIXXY SWAP VX0@ - PIX>PIC_SCALE VPX0@ +
SWAP VY0@ - PIX>PIC_SCALE VPY0@ + ;
\ picture coordinates to video coordinates
: PIXXY>PICXY SWAP VPX0@ - PIC>PIX_SCALE VX0@ +
SWAP VPY0@ - PIC>PIX_SCALE VY0@ + ;
\ ___ picture coordinates of window center
: ?CENTER VX0@ VXDIM@ 2/ + VY0@ VYDIM@ 2/ + PICXY>PIXXY ;
: CENTER-ICURSOR ?CENTER PIXXY>PICXY !POSITION ;
-->
Screen # 63
\ Picture window support, continued GDS 2 14:14 07-01-94
( draw border around current window )
: VBORDER VX0@ VY0@ OVER COLS PIC>PIX_SCALE VXDIM@ MIN + VY0@
2SWAP 2OVER LINE \ top
2DUP ROWS PIC>PIX_SCALE VYDIM@ MIN +
2SWAP 2OVER LINE \ right
VX0@ OVER 2SWAP 2OVER LINE \ bot
VX0@ VY0@ LINE ; \ left
( fill with color pallete# _____ )
: VFILL GRAPHICS FOREGROUND VYDIM@ 0 DO \ loop
VX0@ DUP VXDIM@ + VY0@ I + SWAP OVER LINE LOOP
FRGRND_COLOR FOREGROUND ; \ restore
( erase vwindow )
: VERASE BKGRND_COLOR VFILL FRGRND_COLOR FOREGROUND ;
-->
Screen # 64
\ Dummy Windows for Testing GDS 2 18:26 07-01-94
\ vx0 vy0 vxdim vydim ______ sets up vwindow borders
: VWPLACE VYDIM! VXDIM! VY0! VX0! ;
: SET-VWINDOW 150 48
447 COLS PIC>PIX_SCALE MIN
430 ROWS PIC>PIX_SCALE MIN VWPLACE
VX0@ 8 / VXDIM@ 8 / 15 - 8 MAX + VXCOOR!
VY0@ 16 / 1- VYCOOR! ;
: TVRESET COLS 447 / 1+ ROWS 430 / 1+ MAX DECIMATE!
1 ZOOM! 0 SHIFT! 0 BIAS! 0 VPIC! ;
VWINDOW VW0 TVRESET SET-VWINDOW
-->
Screen # 65
\ LUT Software 13:47 06-25-91
HEX 400 CARRAY VLUT \ 10 bit video look up table
400 EQU VLUT_SIZE
3FF EQU VLUT_MASK
0 EQU VLUT_START
0 EQU VLUT_STOP
0 EQU VLUT_DELTA
VARIABLE VLUT_OPERATOR
DECIMAL
: VLUT_SETUP
1 VLUT_SIZE BOUND EQU VLUT_STOP \ set limits
0 VLUT_STOP 1- BOUND EQU VLUT_START \ set limits
VLUT_STOP VLUT_START - EQU VLUT_DELTA ;
-->
Screen # 66
\ LUT Software GDS 2 20:06 03-24-90
( #min #max ____ fills VLUT )
: VLUT_FILL VLUT_SETUP
VLUT_START IF 0 VLUT VLUT_START ERASE THEN \ bottom
VLUT_STOP VLUT_START DO I VLUT \ leave byte address
I VLUT_START -
VLUT_OPERATOR PERFORM
SWAP C!
LOOP
VLUT_SIZE VLUT_STOP ?DO 15 I VLUT C! LOOP ; \ top
-->
Screen # 67
\ VLUT Operators 15:37 04-07-90
: .LINEAR 1+ 15 * VLUT_DELTA / ;
: LINEAR ['] .LINEAR VLUT_OPERATOR ! ;
: .LOG 1+ S>F FLN VLUT_DELTA S>F FLN F/
15.E F* F>S ;
: LOGAR ['] .LOG VLUT_OPERATOR ! ;
: VLUT_INIT LINEAR 0 VLUT_SIZE VLUT_FILL ;
VLUT_INIT
-->
Screen # 68
( Video to bit plane matrix GDS 20:06 02/12/90 )
16 ARRAY 16_MAP \ 16 to 4 byte transfer
HEX
0 0 16_MAP ! 01000000 1 16_MAP !
00010000 2 16_MAP ! 01010000 3 16_MAP !
00000100 4 16_MAP ! 01000100 5 16_MAP !
00010100 6 16_MAP ! 01010100 7 16_MAP !
00000001 8 16_MAP ! 01000001 9 16_MAP !
00010001 A 16_MAP ! 01010001 B 16_MAP !
00000101 C 16_MAP ! 01000101 D 16_MAP !
00010101 D 1+ 16_MAP ! 01010101 D 2+ 16_MAP !
DECIMAL
-->
Screen # 69
\ Bit block buffer GDS 2 11:50 07-08-94
MAX-DMA-LENGTH CARRAY VLINE_BUF \ line buffer
( value start# ___ puts byte in line )
: VBUF! VLINE_BUF C! ;
: VBUF@ VLINE_BUF C@ ;
( value start# #bytes _____ fills line buffer )
: VBUF_FILL ROT 2 PICK VBUF! \ put in first byte
1- SWAP VLINE_BUF DUP 1+ ROT CMOVE ; \ copy bytes
( start# ____ prints 16 bytes in line )
: VBUF. CLS DUP 16 + SWAP DO CR I . \ print posn.
I VLINE_BUF C@ . LOOP ;
( x-pix y-pix ___ sends out the line )
: BB>SCREEN 0 VLINE_BUF -ROT !BLOCK ;
-->
Screen # 70
\ Bit Block header GDS 2 10:26 11-25-91
( #pixels _____ sets up bit block )
: BIT_BLOCK_LINE_SETUP DUP 8 / 1+ 0 VBUF! \ number of words
1 1 VBUF! 0 2 VBUF! \ 1 line worth
8 MOD NEGATE ( number of nibbles left )
127 NOT SWAP SHIFT BYTE
3 VBUF! ; \ remainder mask
-->
Screen # 71
\ Bit Block pointers GDS 2 15:37 04-07-90
0 EQU BB_WORD \ word start
0 EQU BB_SHIFT \ 0-7 placement
( rel address _____ sets BB_WORD and BB_SHIFT)
: BB_ADDRESS 8 /MOD 1 + 4* VLINE_BUF EQU BB_WORD
7 SWAP - EQU BB_SHIFT ;
( value rel address ____ puts a 4 bit value into the bit block)
: BB! BB_ADDRESS BB_WORD @ \ get 32 bit word
15 16_MAP @ BB_SHIFT SHIFT NOT AND \ mask other bits
SWAP 16_MAP @ BB_SHIFT SHIFT OR \ add new bits
BB_WORD ! ; \ put back
-->
Screen # 72
\ Setup TV variables for compile: GDS 2 18:24 07-01-94
1 EQU #DECIMATE 0 EQU CSTART
1 EQU #SHIFT 100 EQU CSTOP
0 EQU #BIAS
1 EQU #ZOOM
1 EQU BB_SHIFT_START
0 EQU BB_START \ first word in bit block
0 EQU VYNOW \ current y position on screen
0 EQU VPYNOW \ current row position
0 EQU VPYNOW@ \ current address position of row start
-->
Screen # 73
\ Setup Variables GDS 2 13:52 06-28-99
\ sets defs to EQU statements, sets CSTART, CSTOP, etc.
: TV-INIT BIAS@ EQU #BIAS ZOOM@ EQU #ZOOM
DECIMATE@ EQU #DECIMATE SHIFT@ EQU #SHIFT
VPX0@ NEGATE 0 MAX PIC>PIX_SCALE BB_ADDRESS
BB_WORD EQU BB_START \ set up pointers
BB_SHIFT EQU BB_SHIFT_START
VXDIM@ BIT_BLOCK_LINE_SETUP \ setup header
VPX0@ 0 MAX EQU CSTART
VPX0@ COLS + COLS MIN VXDIM@ PIX>PIC_SCALE VPX0@ +
MIN 1+ EQU CSTOP
HIDE-CURSOR ;
\ default = most recent pbf
: !TV ?DATAFILE DEPTH 0> IF PIC>CORE VPIC! THEN ;
-->
Screen # 74
\ Row->Line buffer, start row add. on boun GDS 1 17:06 08-06-91
COMPILE: vrow_OUT BB_START EQU BB_WORD \ initialize
BB_SHIFT_START EQU BB_SHIFT \ initialize
CSTOP CSTART DO DUP @ #BIAS - \ subtract bias
#SHIFT SHIFT \ shift into LVUT
VLUT_MASK AND VLUT C@ \ get byte
16_MAP @ \ get 4 graphic bytes
#ZOOM 0 DO DUP BB_SHIFT SHIFT \ shift
BB_WORD @ OR BB_WORD ! \ to buffer
BB_SHIFT IF BB_SHIFT 1- EQU BB_SHIFT
ELSE 7 EQU BB_SHIFT
BB_WORD 4+ EQU BB_WORD THEN
LOOP DROP \ drop output byte
#DECIMATE 4* + \ increment pic address
#DECIMATE +LOOP DROP ; \ drop address
-->
Screen # 75
\ TV Line buffer GDS 1 13:25 08-09-91
( zeros line buffer )
: 0>TVLINE 4 VLINE_BUF VXDIM@ 2/ 4+ ERASE ;
( ___ sends out a complete line )
: TVLINE>SCREEN VX0@ VYNOW BB>SCREEN ;
( yline ___ flag )
: NEW-LINE DUP VY0@ + EQU VYNOW \ set y screen line
PIX>PIC_SCALE \ convert to pixels
VPY0@ + DUP DUP EQU VPYNOW \ find row address start
0< SWAP ROWS < NOT OR NOT \ check if in picture
IF VYNOW VY0@ - ZOOM@ MOD 0= IF 1 ELSE 2 THEN
VPYNOW COLS * CSTART + 4* VPIC@ PBF@ + EQU VPYNOW@
ELSE 0 \ leave not-in-pic flag
THEN ;
-->
Screen # 76
\ TV Display Key 08:09 04-02-98
\ Display display parameters
: TV-KEY SCREENCOLORS VBORDER
VX0@ 8 / 1+ VYCOOR@ 2DUP GOTOXY VP# ." Pic#" 3.R
\ 4 SPACES COLS . ." x " ROWS .
1- GOTOXY 64 VPIC@ H# 16 TYPE 3 SPACES
." Bias " BIAS@ . 2 SPACES
." Slide " SHIFT@ . 2 SPACES
." Zoom " ZOOM@ . 2 SPACES
." Decim " DECIMATE@ . ZERO-CURSOR ;
-->
Screen # 77
\ Kernal Picture out GDS 1 08:20 05-15-98
\ $TV paints picture in current video window
: $TV TV-INIT CLS GRAPHICS \ picture initialize
VYDIM@ 0 DO \ loop over vrows,
I NEW-LINE \ leave 1 if from pic, 2 if zoom line
?DUP IF 1 = IF \ branch if new row
0>TVLINE VPYNOW@ vrow_OUT \ fill buffer
THEN
ELSE 0>TVLINE \ zero buffer
THEN TVLINE>SCREEN \ output buffer
ESCAPE? PAUSE
LOOP TV-KEY ;
-->
Screen # 78
\ High-Level Picture Defn's 15:38 06-30-94
\ xpic ypic ___ recenters window
: RECENTER SET-VWINDOW 2DUP
VYDIM@ 2/ PIX>PIC_SCALE - VPY0!
VXDIM@ 2/ PIX>PIC_SCALE - VPX0!
PIXXY>PICXY !POSITION ;
\ ___ center picture in window
: CENTER COLS 2/ ROWS 2/ RECENTER ;
: BIAS BIAS! ;
: DECIMATE 1 3 BOUND DECIMATE! CENTER ;
: SLIDE -7 8 BOUND SHIFT! ;
: ZOOM ?CENTER ROT 1 8 BOUND ZOOM! RECENTER ;
-->
Screen # 79
\ Mouse 08:09 04-02-98
VARIABLE mouse
: ?mouse mouse @ 0= IF SCREENCOLORS ESCAPE! THEN ;
: ILIM-MOUSE VX0@ DUP VXDIM@ + HORIZ-LIMITS
VY0@ DUP VYDIM@ + VERT-LIMITS ;
-->
Screen # 80
\ Image Mouse Pixel Reader GDS 2 22:49 02-16-02
\ program for showing values with mouse
: IMAGE-MOUSE mouse ON MOUSE-RESET DROP
CENTER-ICURSOR SHOW-CURSOR
BEGIN ?mouse ILIM-MOUSE READ-MOUSE XYC@ PICXY>PIXXY
SWAP 0 COLS 1- BOUND SWAP 0 ROWS 1- BOUND 2DUP 2DUP
VXCOOR@ VYCOOR@ GOTOXY SWAP 4.R 4.R \ position
COLS * + 4* VPIC@ PBF@ + @ 7.R \ data
LBUTTON IF LRELEASE RECENTER $TV ELSE 2DROP
RBUTTON IF RRELEASE CENTER $TV ELSE
?TERMINAL IF KEY DUP 43 = IF DROP ZOOM@ 1+ ZOOM $TV
ELSE DUP 45 = IF DROP ZOOM@ 1- ZOOM $TV
ELSE 27 = IF ESCAPE!
THEN THEN THEN THEN THEN THEN
SHOW-CURSOR AGAIN ;
-->
Screen # 81
\ High-level TV Display 11:18 11-30-91
: MTV ['] IMAGE-MOUSE 7 !FUNKEY $TV ;
: TV !TV MTV ;
-->
Screen # 82
( Parallel I/O Port Definitions GDS 11:19 11/14/89 )
-->
Bit Input Byte Outbut Byte
---------------------------------------------------------------
0 Aperture Increment Aperture Lights
1 Aperture Index Aperture Motor
2 Waveplate Increment Waveplate Lights
3 Waveplate Index Waveplate Motor
4 Shutter Status Shutter
5
6
7
Screen # 83
\ Parallel I/O Port Definitions G GDS 12:24 04-23-97
HEX 304 CONSTANT INSTPORT
DECIMAL
0 EQU #WAVE 0 EQU #APT 0 EQU #INST
\ Set or clear specified bit [0-7] of INSTPORT
: BIT-SET 1 SWAP SHIFT #INST OR
DUP INSTPORT PC! EQU #INST 1 MS ;
: BIT-CLEAR 1 SWAP SHIFT -1 XOR #INST AND
DUP INSTPORT PC! EQU #INST 1 MS ;
\ Inspect bit [0-7] of INSTPORT
: ?BIT 1 SWAP SHIFT INSTPORT PC@ AND ;
\ bit# nsamp ___ non-0 if consecutive trues; else 0
: TRUES 1 SWAP 0 DO OVER ?BIT * 1 MS LOOP NIP ;
\ bit# nsamp ___ non-0 if consecutive falses; else 0
: FALSES 1 SWAP 0 DO OVER ?BIT 0= * 1 MS LOOP NIP ;
-->
Screen # 84
\ Motor Checking 14:08 01-09-00
VARIABLE MOTORTICKS
: MTICKS-ON 100 MOTORTICKS ! MOTORTICKS TICKER DROP ;
\ ___ flag, ticks [true if failure; false if ok]
: MOTORCHECK MOTORTICKS -TICKER
100 MOTORTICKS @ - DUP DUP 11 < SWAP 17 > + ;
: MOTORMSG HONK CR REVERSE ." ***Motor Failure***"
3.R ." ticks...Resetting" REVERSE ;
-->
Screen # 85
\ Waveplate Primitives 05:12 03-12-00
: WLITES-ON 2 BIT-SET 5 MS ;
: WLITES-OFF 2 BIT-CLEAR ;
: WAVE-ON WLITES-ON 3 BIT-SET 5 MS ;
: WAVE-OFF 3 BIT-CLEAR WLITES-OFF ;
: .WAVE 29 >STAT-LINE #WAVE REVERSE ." wav" . >SCREEN ;
\ Audible testing of waveplate zero-point
: WAVE0TEST BEGIN WLITES-ON 3 ?BIT WLITES-OFF
IF 1000 10 BEEP THEN ESCAPE? 0 UNTIL ;
-->
Screen # 86
\ Waveplate Definitions GDS 1 05:12 03-12-00
\ Increment waveplate position
: MWAVE WAVE-ON 350 MS REVERSE .WAVE
BEGIN ESC? IF WAVE-OFF ESCAPE! THEN 2 5 FALSES UNTIL
BEGIN ESC? IF WAVE-OFF ESCAPE! THEN 2 3 TRUES UNTIL
WAVE-OFF #WAVE 1+ 16 MOD EQU #WAVE REVERSE .WAVE ;
\ Zero waveplate
: ZWAVE WLITES-ON 3 ?BIT 0=
IF BEGIN MWAVE WLITES-ON 3 5 TRUES UNTIL
THEN WLITES-OFF 0 EQU #WAVE .WAVE ;
\ Increment waveplate with time checking
: WINC MTICKS-ON MWAVE MOTORCHECK DUP -ROT
IF MOTORMSG ELSE DROP THEN ;
-->
Screen # 87
\ Waveplate Definitions G GDS 22:07 11-24-94
VARIABLE ZEROED
: ?ZEROED ZEROED @ 0= IF HONK REVERSE
." Warning: Instrument not initialized!" REVERSE CR THEN ;
: WAVE 0 15 CHECK ?ZEROED #WAVE 2DUP <
BEGIN IF ZWAVE DROP 0 THEN 2DUP 0 -ROT
?DO WINC + LOOP DUP 0= UNTIL DROP 2DROP ;
\ kill mouse for motorcheck
: !WAVE mouse OFF PAUSE #EXP ?WAVE WAVE .WAVE ;
: WAVEPLATES 2 HELPLIST ;
: FOCUS WAVEPLATES ;
-->
Screen # 88
\ Aperture Definitions GDS 1 14:04 07-14-99
: ALITES-ON 0 BIT-SET 5 MS ;
: ALITES-OFF 0 BIT-CLEAR ;
: APT-ON ALITES-ON 1 BIT-SET 5 MS ;
: APT-OFF 1 BIT-CLEAR ALITES-OFF ;
: .APT 24 >STAT-LINE #APT REVERSE ." apt" . >SCREEN ;
: MAPT APT-ON 350 MS REVERSE .APT
BEGIN ESC? IF WAVE-OFF ESCAPE! THEN 0 5 FALSES UNTIL
BEGIN ESC? IF WAVE-OFF ESCAPE! THEN 0 3 TRUES UNTIL
APT-OFF #APT 1+ 8 MOD EQU #APT REVERSE .APT ;
: ZAPT ALITES-ON 1 ?BIT 0=
IF BEGIN MAPT ALITES-ON 1 5 TRUES UNTIL
THEN ALITES-OFF 0 EQU #APT .APT ;
-->
Screen # 89
\ Aperture Definitions G GDS 05:42 03-12-00
\ Increment aperture with time checking
: AINC MTICKS-ON MAPT MOTORCHECK DUP -ROT
IF MOTORMSG ELSE DROP THEN ;
\ apt# ___ move to designated aperture
: APT 0 7 CHECK ?ZEROED #APT 2DUP <
BEGIN IF ZAPT DROP 0 THEN 2DUP 0 -ROT
?DO AINC + LOOP DUP 0= UNTIL DROP 2DROP ;
: APERTURES 3 HELPLIST ;
\ Audible testing of aperture zero-point
: APT0TEST BEGIN ALITES-ON 1 ?BIT ALITES-OFF
IF 1000 10 BEEP THEN ESCAPE? 0 UNTIL ;
-->
Screen # 90
\ Shutter definitions G GDS 15:48 12-02-92
VARIABLE SHUTTER \ ON = normal; OFF = dark
: OPEN-SHUTTER 4 BIT-SET 15 MS 4 ?BIT
IF CR HONK REVERSE
." ***Shutter did not open!***" REVERSE THEN ;
: CLOSE-SHUTTER 4 BIT-CLEAR 15 MS 4 ?BIT 0=
IF CR HONK REVERSE
." ***Shutter did not shut!***" REVERSE THEN ;
: LITE SHUTTER ON ;
: DARK SHUTTER OFF ;
: .SHUTTER 64 >STAT-LINE REVERSE SHUTTER @ IF ." Lite"
ELSE ." Dark" THEN >SCREEN ;
: ?SHUTTER 4 ?BIT IF ." Shut!" ELSE ." Open!" THEN CR ;
-->
Screen # 91
\ ZERO, CCD Clock Voltages GDS 10:05 11-18-94 09:30 03-11-97
\ Initialize Instrument
: ZERO CR ." Initializing Aperture wheel..." ZAPT TOOT
." Waveplate wheel..." ZWAVE TOOT
OPEN-SHUTTER CLOSE-SHUTTER ZEROED ON ;
: GRATINGS 4 HELPLIST ;
: CHIP 5 HELPLIST ;
-->
Screen # 92
\ Basic CCD I/O Control GDS 1 16:16 09-04-94
HEX
: CCD_STROBE CREATE , DOES> @ 0 SWAP PC! ;
: CCD_DSTROBE CREATE , DOES> @ 0 SWAP 2DUP PC! PC! ;
: CCD_INPUT CREATE , DOES> @ PC@ ;
: CCD_OUTPUT CREATE , DOES> @ PC! ;
300 CCD_DSTROBE LINE_START 301 CCD_STROBE DMA-CLR
302 CCD_STROBE clean 303 CCD_OUTPUT mode-set
\ 304 CCD_STROBE SHUTTER_OPEN 306 CCD_STROBE SHUTTER_CLOSE
305 CCD_INPUT temp_in 307 CCD_STROBE CCD_UNUSED
DECIMAL
: MODE-SET 8 + 15 AND 3 0 DO DUP mode-set 1 MS LOOP DROP ;
: TEMP_IN temp_in DROP 0 10 0 DO temp_in + 2 MS LOOP
DUP DUP 2550 = SWAP 0= OR IF DROP 999
ELSE S>F FTEN F/ FDUP FSQ -1.044E-3 F*
FSWAP -1.033E0 F* F+ 40.44E0 F+ FROUND F>S THEN ; -->
Screen # 93
( Forth to physical addressing GDS 20:07 02/12/90 )
HEX
( addr ___ returns linear address )
: ADD>LINEAR ADDR>PTR SWAP \ now segment on top
regEBX ! 2508 regEAX ! 21 INT86 regECX @ + ; \ add offset
( linear address ___ returns physical address )
: LINEAR>PHYS
regEBX ! 2509 regEAX ! 21 INT86 regECX @ ;
: ADD>PHYS ADD>LINEAR LINEAR>PHYS ;
DECIMAL
-->
Screen # 94
\ DMA Control GDS 1 15:31 08-06-91
( The CCD I/O Board uses 16 bit word transfers )
( Channel 5, second port in controller 2 )
HEX VARIABLE DMA-SET 45 DMA-SET !
: DMA_STATUS@ 0D0 PC@ ;
: DMA_RESET_POINTER 0 0D8 PC! ;
: DMA_MASTER_RESET 0 0DA PC! ;
: CCD-MODE-SET DMA-SET @ 0D6 PC! ;
: SINGLE_MASK_BIT_SET CREATE , DOES> @ 0D4 PC! ;
: ALL_MASK_BIT_SET CREATE , DOES> 0DE PC! ;
1 SINGLE_MASK_BIT_SET CCD_DMA_ENABLE
DECIMAL
-->
Screen # 95
( DMA Defining Words cont. GDS 20:07 02/12/90 )
: TWO_BYTES_OUT ( 16 bit wd ch 5 port ____ )
DMA_RESET_POINTER \ reset byte pointer
SWAP \ put port on bottom
SPLIT SWAP 2 PICK PC! SWAP PC! ;
: TWO_BYTES_IN ( ch 5 read port ____ 16 bit word )
DMA_RESET_POINTER \ reset byte pointer
DUP PC@ \ dup port and input
SWAP PC@ COMBINE ;
-->
Screen # 96
( DMA defining words GDS 20:07 02/12/90 )
HEX
: DMA_START_ADDRESS
2/ \ shift down, assumes even start addr>
WSPLIT 2* 08B PC! \ note explicit page port for ch. 5
0C4 TWO_BYTES_OUT ; \ 2 bytes out
: DMA_WORD_COUNT 1- \ DMA counts in 1+ number in
0C6 TWO_BYTES_OUT ; \ send out words
: DMA_WORDS_LEFT 0C6 TWO_BYTES_IN ;
: DMA_ADDRESS_NOW 0C4 TWO_BYTES_IN 2* ;
DECIMAL
-->
Screen # 97
\ DMA Input Buffers GDS 1 15:36 07-08-94
MAX-DMA-LENGTH 200 + CONSTANT ROW_BUFFER_SIZE
2 ARRAY DMA_BUFFER 2 ARRAY PHYS_DMA_BUFFER
HEX
( addr ___ returns number needed to pad )
: SET_PAD ADD>PHYS FFF AND 1000 SWAP -
\ check how close to 4k paging edge
DUP ROW_BUFFER_SIZE 2* 20 + > IF DROP 0 THEN ;
HERE SET_PAD ALLOT
VARIABLE TB0 ROW_BUFFER_SIZE 2* ALLOT TB0 ALIGN DUP
0 DMA_BUFFER ! ADD>PHYS 0 PHYS_DMA_BUFFER !
HERE SET_PAD ALLOT
VARIABLE TB1 ROW_BUFFER_SIZE 2* ALLOT TB1 ALIGN DUP
1 DMA_BUFFER ! ADD>PHYS 1 PHYS_DMA_BUFFER !
DECIMAL
-->
Screen # 98
\ Middle-level DMAs 17:42 10-17-90
0 EQU DMA_TOGGLE
0 DMA_BUFFER @ EQU NEXT_DMA_BUFFER
1 DMA_BUFFER @ EQU LAST_DMA_BUFFER
0 PHYS_DMA_BUFFER @ EQU NEXT_PHYS_DMA_BUFFER
1 PHYS_DMA_BUFFER @ EQU LAST_PHYS_DMA_BUFFER
: TOGGLE_DMA_BUFFER NEXT_DMA_BUFFER EQU LAST_DMA_BUFFER
NEXT_PHYS_DMA_BUFFER EQU LAST_PHYS_DMA_BUFFER
1 DMA_TOGGLE - DUP EQU DMA_TOGGLE
DUP DMA_BUFFER @ EQU NEXT_DMA_BUFFER
PHYS_DMA_BUFFER @ EQU NEXT_PHYS_DMA_BUFFER ;
-->
Screen # 99
\ Middle-level DMAs GDS 1 19:29 12-01-97
( #words buffer_address ___ starts read in )
: START_LINE DMA-CLR \ clears dma on I/O card
LINE_START \ send out line start
150 LOOPS \ delay to avoid extra pixel at
\ beginning of row
CCD_DMA_ENABLE \ enables channel 5 DMA
TOGGLE_DMA_BUFFER \ toggles buffer
NEXT_PHYS_DMA_BUFFER DMA_START_ADDRESS
DMA_WORD_COUNT ; \ sends out word count
( sets up DMA_CHANNEL )
: START_PIC DMA-CLR \ clears dma on i/o card
1 EQU DMA_TOGGLE \ sets up buffer
CCD-MODE-SET ; \ sets channel 5 into DMA
-->
Screen # 100
\ DMA Timeout GDS 1 GDS 1 15:51 09-04-94
0 EQU #PBF
\ VARIABLE DMA-CLOCK \ rate = 18.2 Hz; 1 tick = 55 ms
: TOSLEEP -1 DELAY ;
\ : !DMA-CLOCK 10 DMA-CLOCK ! DMA-CLOCK TICKER DROP ;
\ : ?DMA-TIMEOUT DMA-CLOCK @ 0= IF
\ DMA-CLOCK -TICKER OBSERVING OFF
\ CR HONK REVERSE ." ***DMA timeout! Exposure aborted***"
\ REVERSE TOSLEEP THEN ;
\ read DMA status channel
: WAIT_FOR_DMA_END ( !DMA-CLOCK )
BEGIN DMA_STATUS@ 2 AND ( ?DMA-TIMEOUT ) UNTIL ;
-->
Screen # 101
\ More Mid-Level DMA GDS 1 22:50 02-16-02
\ dest. end.source beg.source ___ dest' : adds linear strip
COMPILE: comADD-LINE DO I UW@ OVER +! 4+ 2 +LOOP ;
\ row# ___ adds last 16b DMA buffer into 32b pic. buffer
: CCD_LINE>PBF
COLS * 4* #PBF PBF@ + \ dest
LAST_DMA_BUFFER PRESCAN COL-SKIP + CBIN / 2* + \ beg src
DUP COLS OVERSCAN - 2* + SWAP \ end src
comADD-LINE
LAST_DMA_BUFFER PRESCAN CHIPCOLS + SKIPOVER +
CBIN / 2* + \ beg src
DUP OVERSCAN 2* + SWAP \ end src
comADD-LINE
DROP ;
-->
Screen # 102
\ Multitasker GDS 1 09:07 10-18-90
TASKER
' NOOP v-TASKER ! \ this removes -TASKER from ABORT seq.,
\ preventing trivial errors from
\ disrupting obsn.
512 512 TCB EXPOSURE
512 512 TCB SWEEP
\ background task to vert. shift during idle
: SWEEP-LOOP BEGIN LINE_START 1 DELAY AGAIN ;
SWEEP START SWEEP-LOOP
-->
Screen # 103
\ Read in Horizontal strip GD GDS 10:37 12-02-97
VARIABLE TRANSFER \ transfer flag
COLS EQU COLS-IN \ COLS-IN = cols actually transferred
\ #rows ___ cond. reads horiz. segment into pic. buffer
: READ-SEG 0 ?DO COLS-IN START_LINE
TRANSFER @ IF I ?DUP
IF 1- CCD_LINE>PBF THEN
THEN WAIT_FOR_DMA_END LOOP ;
\ erase chip
: CLEAN SWEEP SLEEP \ no vert. shift during exp.
clean .ERASING 1250 MS
7 MODE-SET ( fast 2 x 2 flush mode )
TRANSFER OFF CHIPCOLS PRESCAN + 2/ EQU COLS-IN
CHIPROWS READ-SEG ( flush twice )
BINMODE MODE-SET TOOT ; -->
Screen # 104
\ Read in picture GDS 2 21:46 11-24-94
\ windows and reads CCD
: READ-PIC .READING
#PBF ROWS&COLS
START_PIC
TRANSFER OFF
5 EQU COLS-IN ROW-SKIP RBIN / 2- 0 MAX
DUP READ-SEG \ skip rows
CHIPCOLS PRESCAN + SKIPOVER + CBIN / OVERSCAN +
1 MAX-DMA-LENGTH CHECK EQU COLS-IN
ROW-SKIP RBIN / SWAP - READ-SEG \ read 2 lines normally
TRANSFER ON
ROWS READ-SEG \ read window
ROWS 1- CCD_LINE>PBF \ last line
DMA-CLR SWEEP WAKE ; \ vert. shift on
-->
Screen # 105
\ Timing GDS 1 16:47 02-11-93
FVARIABLE FDWELL
60.E0 FDWELL F!
VARIABLE EXP_TICKS 0 EQU END_TICKS
: !EXP_TICKS FDWELL F@ 18.2E0 F* FROUND F>S
EXP_TICKS ! 0 EQU END_TICKS ;
\ secs --- xx:yy
: .MINSEC 0 <# # 6 BASE ! # DECIMAL [ ASCII : ] LITERAL HOLD
# # #> TYPE ;
-->
Screen # 106
\ Bin Mode Checking 08:14 04-02-98
: CHKMODE SWEEP SLEEP 500 EQU COLS-IN 100 EXP_TICKS !
TRANSFER OFF EXP_TICKS TICKER DROP
START_PIC 100 READ-SEG EXP_TICKS -TICKER
100 EXP_TICKS @ - DUP . SWEEP WAKE ;
: MODE-TEST ?STOPPED ." ...Test requires ~1 minute..."
26 1 DO CR ." Mode Test " I .
0 MODE-SET CHKMODE 30 < 4 MODE-SET CHKMODE 30 > OR
IF HONK REVERSE ." Bin-Mode Error!" REVERSE
ELSE ." ok " THEN ESCAPE? LOOP TOOT ;
: INFO 0 HELPLIST ;
-->
Screen # 107
\ Multitasker GDS 1 18:56 10-23-92
: .TEMP 68 >STAT-LINE TEMP_IN REVERSE 4.R ." °C" >SCREEN ;
: .DWELL 75 >STAT-LINE EXP_TICKS @ 9 + ( round ) 10 182 */
REVERSE .MINSEC >SCREEN ;
: .EXP 19 >STAT-LINE #EXP 1+ REVERSE ." exp" . >SCREEN ;
: .SEQ 19 >STAT-LINE REVERSE #SEQUENCE DUP
0= IF ." SNAP" THEN DUP 1 = IF ." Qseq" THEN DUP
2 = IF ." Useq" THEN 3 = IF ." Vseq" THEN >SCREEN ;
: KEEP-TIME .TEMP .DWELL 9 DELAY ;
: WAIT_FOR_END BEGIN EXP_TICKS @ 0= UNTIL
CLOSE-SHUTTER EXP_TICKS -TICKER ;
-->
Screen # 108
\ Multitasker GDS 1 20:41 10-11-00
0.0 2EQU START_TIME \ "0" --> "7" for RTC in MST
: !START_TIME @RTC SWAP SPLIT 0 + 24 MOD COMBINE
SWAP 2EQU START_TIME ;
: TICK-TOCK EXP_TICKS TICKER DROP PAUSED OFF .INTEG ;
: EXP_CLOCK BEGIN EXP_TICKS @ 145 > \ freeze fore 8 sec early
IF KEEP-TIME 0 \ twiddle thumbs
ELSE 1 THEN UNTIL ;
: START-EXPOSURE !START_TIME !EXP_TICKS EXP_TICKS @ IF
SHUTTER @ IF OPEN-SHUTTER
ELSE #SEQUENCE IF HONK
REVERSE ." Warning: Shutter closed!" REVERSE CR
THEN THEN TICK-TOCK THEN ; -->
Screen # 109
\ Read Telescope Parameters GDS 08:59 03-12-97
\ Assume telescope is mounted as drive e:!
CREATE GETNAME 17 ALLOT GETNAME 17 ZSTR
" E:\GETSTAT.LOC" COUNT STRPCK GETNAME CSTRMOV
CREATE STATNAME 17 ALLOT STATNAME 17 ZSTR
" E:\STATUS.TEL" COUNT STRPCK STATNAME CSTRMOV
HCB GETFILE HCB TELFILE
GETNAME GETFILE NAME>HCB STATNAME TELFILE NAME>HCB
: TOUCH DUP ?FILE-ABSENT DUP 0 WRITE-FILE DROP ;
-->
Screen # 110
\ Read Telescope Parameters GDS 17:13 04-02-97
CREATE TELLN 81 ALLOT TELLN 81 ZSTR
CREATE FPEXT 3 ALLOT FPEXT 3 ZSTR
" E0" COUNT STRPCK FPEXT CSTRMOV
CREATE AIR-MASK 16 ALLOT AIR-MASK 16 ZSTR
" airmass " COUNT STRPCK AIR-MASK CSTRMOV
-->
Screen # 111
\ Read Airmass GDS 08:21 05-15-98
\ ___ airmass (f.p.) Read airmass from VXWORKS box
: GET-AIRMASS CR ." Airmass = "
STRPAD 81 ZSTR GETFILE TOUCH
BEGIN GETFILE FILECHK ESCAPE? UNTIL
TELFILE ?FILE-PRESENT TELFILE 0 FOPEN DROP
TELFILE FREADLN TELLN CSTRMOV TELFILE FCLOSE DROP
AIR-MASK COUNT TELLN 1+ OVER STRCMP 0=
IF TELLN COUNT + 4 - 4 FPEXT COUNT STRCAT STRPCK
STRPAD CSTRMOV STRPAD FNUMBER FDUP 3 PLACES 5 F.R
TELFILE FDEL DROP
ELSE REVERSE ." Invalid airmass entry!" REVERSE
THEN ;
-->
Screen # 112
\ Set DISPAXIS and AIRMASS 00:20 12-05-97
0 EQU DISPAXIS 0 EQU AIRMASS VARIABLE AMASS
VARIABLE AIRMASSPROMPT
: SET-DISPAXIS ." Enter dispersion axis (x = 1; y = 2): "
#IN EQU DISPAXIS CR ;
: ?AIRMASS AMASS @ IF P#OBS IF SHUTTER @ IF AIRMASSPROMPT @
IF ." Starting airmass (e.g. 1.254; or CR for 0.000)"
STRPAD 81 ZSTR STRPAD 15 ?STRING STRPAD C@
IF STRPAD FPEXT CSTRCAT STRPAD CSTRMOV STRPAD FNUMBER
ELSE FZERO THEN
ELSE GET-AIRMASS
THEN 1.E3 F* F>S DUP IF 1000 4000 CHECK THEN EQU AIRMASS
THEN THEN THEN ;
: AIRMASSES 7 HELPLIST ;
-->
Screen # 113
\ Make Header - 1 GDS 2 12:06 09-05-91
: HEADER-VALS1 0 0 #PBF H! \ 1 = FITS format
32 1 #PBF H! \ bits/pixel
2 2 #PBF H! \ data axes
COLS 3 #PBF H! \ xsize
ROWS 4 #PBF H! \ ysize
@DATE 5 #PBF H2! \ date in 2 packed words
COL-SKIP 7 #PBF H! \ starting chip column #
CBIN 8 #PBF H! \ column increment
ROW-SKIP 9 #PBF H! \ starting chip row #
RBIN 10 #PBF H! \ row increment
#APT 12 #PBF H! ; \ aperture number
-->
Screen # 114
\ Make Header - 2 GDS 2 02:19 02-19-02
: HEADER-VALS2
SHUTTER @ 13 #PBF H! \ shutter mode (0=closed)
TEMP_IN 14 #PBF H! \ CCD temp. in cent.
0 15 #PBF H! \ data offset for 32b ints
DISPAXIS 16 #PBF H! \ Dispersion axis (x=1;y=2)
AIRMASS 17 #PBF H! ; \ Starting airmass (x 1000)
-->
Screen # 115
\ Make Header GDS 2 21:51 11-24-94
: HEADER-TEXT NAME 64 #PBF H# 32 CMOVE \ name
COMMNT 72 #PBF H# 32 CMOVE ; \ comment
: UPDATE-HEADER HEADER-TEXT \ name &/or comment
#PBF PBF>P# @ 11 #PBF H! \ picture #
#WAVE #EXP 20 + #PBF H! \ waveplate psn
START_TIME 2DUP #EXP 2* 28 + #PBF H2! \ starting UT
DROP >< BYTE 7 < IF @DATE 1+ 5 #PBF H2!
THEN \ incr. date if
\ next UT day
FDWELL F@ F>S END_TICKS 10 182 */ - \ sub ending value
#EXP 44 + #PBF H! ; \ dwell in sec
-->
Screen # 116
\ Saving Instrument Status 16:07 03-11-97
\ num ___ ^str
: DIGITS 0 <# # # # # # #> STRPCK ;
: -DIGITS DUP >R ABS 0
<# # # # # R> SIGN #> STRPCK ;
: 5DIGITS DUP 0< IF -DIGITS ELSE DIGITS THEN COUNT ;
: FLUSH-INSTAT UPDATE FLUSH >PROGFILE ;
\ block line char ___ indexes into block
: >BLOCK ROT BLOCK ROT 64 * + + ;
\ addr count block line char ___ store into block
: BSTORE >BLOCK SWAP CMOVE ;
\ block line char #blanks ___
: BBLANK >R >BLOCK R> BLANK ;
-->
Screen # 117
\ Saving Instrument Status 09:56 03-11-97
: SAVESTAT1 >STATFILE
HFNAME COUNT DUP 5DIGITS 1 3 0 BSTORE
1 3 9 32 BBLANK 1 3 9 BSTORE
PFNAME COUNT DUP 5DIGITS 1 4 0 BSTORE
1 4 9 32 BBLANK 1 4 9 BSTORE
P#NOW 5DIGITS 1 5 0 BSTORE
#APT 5DIGITS 1 6 0 BSTORE
#WAVE 5DIGITS 1 7 0 BSTORE
#SEQUENCE 5DIGITS 1 8 0 BSTORE
SHUTTER @ 5DIGITS 1 9 0 BSTORE
FDWELL F@ F>S 5DIGITS 1 10 0 BSTORE
1 11 9 32 BBLANK NAME 32 1 11 9 BSTORE
DISPAXIS 5DIGITS 1 12 0 BSTORE
AIRMASSPROMPT @ 5DIGITS 1 13 0 BSTORE
FLUSH-INSTAT ; -->
Screen # 118
\ Saving Instrument Status 12:37 03-31-95
: SAVESTAT2 >STATFILE
BINMODE 5DIGITS 2 2 0 BSTORE
COL-SKIP 5DIGITS 2 5 0 BSTORE
COLS 5DIGITS 2 6 0 BSTORE
ROW-SKIP 5DIGITS 2 7 0 BSTORE
ROWS 5DIGITS 2 8 0 BSTORE
LEFT 5DIGITS 2 11 0 BSTORE
RIGHT 5DIGITS 2 12 0 BSTORE
FLUSH-INSTAT ;
-->
Screen # 119
\ Saving Instrument Status 17:52 11-25-94
: SAVESTAT3 >STATFILE
BIAS@ 5DIGITS 3 2 0 BSTORE
SHIFT@ 5DIGITS 3 3 0 BSTORE
ZOOM@ 5DIGITS 3 4 0 BSTORE
DECIMATE@ 5DIGITS 3 5 0 BSTORE
FLUSH-INSTAT ;
: SAVECONFIG SAVESTAT1 SAVESTAT2 SAVESTAT3 ;
: NSTORE DUP 1+ 32 BLANK ROT CMOVE ;
: RECONFIGURE CR ." Reconfigure instrument: " CR ?REALLY
>STATFILE 1 LOAD >PROGFILE ;
-->
Screen # 120
\ Ending Observation GDS 1 17:30 11-30-95
: WRAP-UP 2 0 DO I PBF>UPDATE @ 0>
IF NEXT-DATAFILES I WRITE-PIC
.WRITTEN P#NEXT SAVECONFIG
ELSE .DONE THEN LOOP !EXP_TICKS ;
\ post-processing defn
VARIABLE PPROC ' NOOP PPROC !
: POSTPROCESS ' PPROC ! ;
\ write to disk if done
: ?AGAIN #EXP ?PBF 0<
IF WRAP-UP 0 VPIC!
PPROC PERFORM OBSERVING OFF TOSLEEP THEN ;
-->
Screen # 121
\ Start/Stop Misc. GDS 1 23:08 11-24-94
\ ___ type pixel filename
: .PFILE 0 >STAT-LINE NEXT-DATAFILES REVERSE
PFILE .FNAME >SCREEN ;
\ ___ type object name
: .LABEL 49 >STAT-LINE REVERSE NAME 14 TYPE >SCREEN ;
\ ___ set pbf#, pic#, and update flags for buffer in use
: !PBF #EXP ?PBF DUP EQU #PBF P#OBS + #PBF PBF>P# !
P#OBS IF 1 #PBF PBF>UPDATE !
THEN STRIPE .PFILE .EXP .APT .WAVE
.LABEL .SHUTTER .TEMP .DWELL ;
-->
Screen # 122
\ Background Waveplate Loop GDS 1 21:48 11-24-94
\ loop over waveplate positions, write out picture
: WAVE-LOOP 0 EQU #EXP
OBSERVING ON
BEGIN ?AGAIN
mouse OFF
!PBF
!WAVE
NEW-EXP? IF CLOSE-SHUTTER CLEAN THEN
START-EXPOSURE
EXP_CLOCK
WAIT_FOR_END
LAST-EXP? IF READ-PIC THEN
UPDATE-HEADER
#EXP 1+ EQU #EXP AGAIN ;
-->
Screen # 123
\ Picture Startup GDS 2 06:55 04-02-98
: STATUS STRIPE PAUSED @ IF .PAUSED .EXP ELSE OBSERVING @
IF .INTEG .EXP ELSE .READY .SEQ THEN
THEN .PFILE .TEMP .APT .WAVE
.LABEL .SHUTTER .DWELL ;
: CLEAR-PBF DUP PBF@ OVER PBF-LENGTH HBF-LENGTH +
ERASE PBF-INIT ;
: CLEAR-PBFS ?STOPPED #PBFS 2 MIN 0 DO I CLEAR-PBF LOOP ;
: MAKE-HEADER EQU #PBF HEADER-VALS1 HEADER-VALS2
COMMNT 32 BLANK ;
: MAKE-HEADERS ?STOPPED 0 MAKE-HEADER 1 MAKE-HEADER ;
-->
Screen # 124
\ Start Exposure GDS 1 17:57 02-27-02
\ Set dwell time
: !DWELL FDWELL F! !EXP_TICKS
EXP_TICKS @ S>F 18.2E0 F/ ." ‹t = " 2 PLACES F. ." sec " ;
: SEC ?STOPPED 0 3600 CHECK S>F !DWELL ;
: MILLISEC ?STOPPED 0 30000 CHECK S>F 1000.E0 F/ !DWELL ;
\ Foreground command to start exposure
: $GO EQU P#OBS
?STOPPED ?DATAFILE ?AIRMASS
ZWAVE CLEAR-PBFS
CLS SCREENCOLORS
MAKE-HEADERS
EXPOSURE STOP
EXPOSURE START WAVE-LOOP
EXPOSURE WAKE ;
-->
Screen # 125
\ PAUSE, GO, and TEST exposures 10:25 10-18-99
\ GO uses next picture number - make sure airmasses are on
: GO P#NOW $GO AMASS ON ;
\ TEST uses picture number 0
: TEST #SEQUENCE 0= IF 0 $GO ELSE HONK
REVERSE ." TEST in SNAPSHOT mode only!" REVERSE THEN ;
\ n GOS takes n identical observations
: GOS 1 20 CHECK ." Cntrl-Break to interrupt" 2000 MS
0 ?DO BEGIN $PAUSE OBSERVING @ 0= UNTIL AMASS OFF GO
BEGIN $PAUSE OBSERVING @ UNTIL LOOP
BEGIN $PAUSE OBSERVING @ 0= UNTIL ;
\ PGO takes sequential Q and U sequences
: PGO Q-SEQUENCE GO
BEGIN $PAUSE OBSERVING @ 0= UNTIL
U-SEQUENCE GO ;
-->
Screen # 126
\ PAUSE 20:00 11-21-95
\ PAUSE current exposure
: PAUSE ?OBSERVING CLOSE-SHUTTER EXP_TICKS -TICKER
PAUSED ON REVERSE CR
." Please RESUME, RESTART, or STOP exposure,"
." or KILL entire observation"
REVERSE CR STATUS TOOT ;
\ RESTART current exposure
: RESTART ?OBSERVING ?PAUSED ?REALLY ." Restarting exposure..."
CLEAN START-EXPOSURE CR STATUS ;
-->
Screen # 127
\ RESTART, RESUME, KILL, STOP 19:59 11-21-95
\ RESUME current exposure
: RESUME ?OBSERVING ?PAUSED SHUTTER @ IF OPEN-SHUTTER THEN
STATUS TICK-TOCK ;
\ KILL entire observation (do not write to disk)
: KILL ?OBSERVING ?PAUSED ?REALLY
EXPOSURE SLEEP SWEEP WAKE
0 PBF-INIT 1 PBF-INIT
OBSERVING OFF PAUSED OFF STATUS .KILLED ;
\ STOP current exposure
: STOP ?OBSERVING ?PAUSED ?REALLY ." Stopping exposure..."
CR EXP_TICKS @ 1+ EQU END_TICKS
1 EXP_TICKS ! TICK-TOCK ;
-->
Screen # 128
\ Select Chip Format GDS 15:40 11-30-95
: FORMAT ?STOPPED 6 HELPLIST !MODE
CR ." Set column (x) boundaries: [ 0 to " CHIPCOLS 1- . ." ]"
CR ." First Chip Column? "
#IN 0 CHIPCOLS 1- CHECK EQU COL-SKIP
CR ." Last Chip Column? " #IN COL-SKIP CHIPCOLS 1- CHECK
CBIN + COL-SKIP - CBIN / OVERSCAN + EQU COLS
CR ." Set row (y) boundaries: [ 0 to " CHIPROWS 1- . ." ]"
CR ." First Chip Row? "
#IN 0 CHIPROWS 1- CHECK EQU ROW-SKIP
CR ." Last Chip Row? " #IN ROW-SKIP CHIPROWS 1- CHECK
RBIN + ROW-SKIP - RBIN / EQU ROWS
TVRESET CENTER ALLOC-PBFS
SWEEP SLEEP BINMODE MODE-SET SWEEP WAKE ;
-->
Screen # 129
\ File Display 08:21 05-15-98
: PICS ?DATAFILE CLS ." Pictures on disk"
1000 1 DO CR I NEW-NAMES
HFILE DUP ?FILE-PRESENT .FNAME SPACE
FREE-PBF HFILE OVER HBF@ HBF-LENGTH READ-FILE
DUP SPACE .TITLE -100 SWAP PBF>UPDATE !
ESCAPE? LOOP ;
: $ERASE-PIC ?DATAFILE 0 997 CHECK NEW-NAMES CR
DELETE-PIC HFILE .FNAME 3 SPACES
PFILE .FNAME ." erased " ;
: ERASE-PIC ?REALLY ORDER 1+ SWAP DO I $ERASE-PIC LOOP
ZERO-BUFFERS ;
-->
Screen # 130
\ Header display 17:56 11-17-94
: ?HEADER PIC>CORE DUP .HEADER
CR ." Expos. Wave. Psn. Start-Time Dwell(sec)"
8 0 DO CR I 1+ 3.R
I 20 + OVER H@ 10.R 9 SPACES
I 2* 28 + OVER H2@ .HMS
I 44 + OVER H@ 10.R
LOOP DROP CR ;
\ ___ Like ?HEADER but prompts for function key use
: HEADER ." Pic#: " #IN ?HEADER ;
-->
Screen # 131
\ Graphics Utility GDS 1 08:09 04-02-98
( Define screen size in graphics and alpha coordinates )
640 EQU GXPIX 480 EQU GYPIX
80 EQU AXPIX 30 EQU AYPIX
: ESCAPE-PLT? ESC? IF SCREENCOLORS ESCAPE! THEN ;
( Graphics coordinates to alpha coordinates )
: GXY>AXY 2+ AYPIX GYPIX */ 0 AYPIX BOUND SWAP
2- AXPIX GXPIX */ 0 AXPIX BOUND SWAP
GOTOXY ;
-->
Screen # 132
\ Graphics Parameters GDS 1 22:49 02-16-02
0 EQU DLEFT CHIPCOLS EQU DRIGHT
1000 EQU DTOP 0 EQU DBOT
0 EQU CLEFT CHIPCOLS EQU CRIGHT
CHIPCOLS OVERSCAN + CHIPROWS MAX
DUP 2DUP ARRAY PLOTBUF ARRAY SUMBUF
EQU PLOTSIZE EQU PLOTMAX
\ reverse x limits of plot
: FLIP LEFT RIGHT EQU LEFT EQU RIGHT ;
: XSIZE RIGHT LEFT - ;
: YSIZE TOP BOT - ;
: DXSIZE DRIGHT DLEFT - ;
: DYSIZE DTOP DBOT - ;
: CLEARBUF 0 PLOTMAX CHECK EQU PLOTSIZE PLOTMAX 4* ERASE ;
-->
Screen # 133
\ Data <--> Screen Conversions GDS 1 13:35 03-09-92
\ dx dy ___ gx gy : data to graphics window conversion
: DXY>GXY DTOP - YSIZE DYSIZE */ TOP + TOP BOT BOUND SWAP
DLEFT - XSIZE DXSIZE */ LEFT + LEFT RIGHT BOUND SWAP ;
\ gx gy ___ dx dy : graphics to int. data coord. conversion
: GXY>DXY TOP - YSIZE DYSIZE / 2/ + ( round to nearest )
DYSIZE YSIZE */ DTOP + SWAP
LEFT - XSIZE DXSIZE / 2/ + ( round to nearest )
DXSIZE XSIZE */ DLEFT + SWAP ;
\ gx gy ___ fx fy : graphics to f.p. data coord. conversion
: GXY>FXY >R LEFT - S>F DXSIZE S>F F*
XSIZE S>F F/ DLEFT S>F F+
R> TOP - S>F DYSIZE S>F F*
YSIZE S>F F/ DTOP S>F F+ ; -->
Screen # 134
\ Data <--> Screen Conversions GDS 1 14:05 06-28-99
FVARIABLE FXO FVARIABLE FYO
\ dx ___ dz : Extract data value from plot buffer
: VALUE 0 COLS 1- BOUND PLOTBUF @ ;
\ ___ write dx, dy, z(x) in upper right corner
: .XYZ 59 1 GOTOXY XYC@ GXY>FXY
FOVER FDUP FXO F! 0.05E0 F+ 6 F.R
FDUP FYO F! FROUND F>S 6.R
FROUND F>S VALUE 6.R ;
\ ___ write deltax, deltay in upper right
: .DXY 59 2 GOTOXY XYC@ GXY>FXY
FYO F@ F- FROUND FSWAP FXO F@ F- 0.05E0 F+
6 F.R F>S 6.R ;
-->
Screen # 135
\ Row Plotting 13:12 06-29-99
: AVGBUF 2TEMP 1TEMP - 1+ 0 SUMBUF PLOTSIZE 0
?DO OVER OVER @ SWAP / OVER ! 4+ LOOP 2DROP ;
\ m n ___ sum rows m thru n into SUMBUF
: SUM-ROWS DEPTH DUP 0= IF DROP CLEFT CRIGHT ELSE
1 = IF DUP THEN THEN
CHECK-ROWS SWAP CHECK-ROWS ORDER
EQU 2TEMP EQU 1TEMP 0 SUMBUF COLS CLEARBUF
2TEMP 1+ 1TEMP ?DO I VP# ROW 0 SUMBUF
COLS 4* 0 ?DO OVER I + @ OVER I + +! 4 +LOOP
2DROP LOOP AVGBUF ;
-->
Screen # 136
\ Column Plotting 13:12 06-29-99
\ m n ___ sum cols m thru n into SUMBUF
: SUM-COLS DEPTH DUP 0= IF DROP CLEFT CRIGHT ELSE
1 = IF DUP THEN THEN
CHECK-COLS SWAP CHECK-COLS ORDER
EQU 2TEMP EQU 1TEMP 0 SUMBUF ROWS CLEARBUF
2TEMP 1+ 1TEMP ?DO VPIC@ PBF@ I 4* + 0 SUMBUF
ROWS 4* 0 ?DO OVER I COLS * + @ OVER I + +! 4 +LOOP
2DROP LOOP AVGBUF ;
-->
Screen # 137
\ Column and Row Plotting Continued 13:31 03-31-95
: !PLOTBUF 0 SUMBUF 0 PLOTBUF ROT 4* CMOVE ;
: -PLOTBUF 0 SUMBUF 0 PLOTBUF ROT 4* 0
?DO OVER I + @ NEGATE OVER I + +! 4 +LOOP ;
-->
Screen # 138
\ Box GDS 1 18:35 05-17-98
\ gxul gyul gxlr gylr --- (with limit checking)
: RECTANGLE 4 ?DEPTH
0 GYPIX BOUND SWAP 0 GXPIX BOUND SWAP 2SWAP
0 GYPIX BOUND SWAP 0 GXPIX BOUND SWAP 2SWAP
1 PICK 3 PICK 5 PICK 5 PICK LINE ( top )
3 PICK 1 PICK 5 PICK 5 PICK LINE ( left)
1 PICK 3 PICK 3 PICK 3 PICK LINE ( right )
3 PICK 1 PICK 3 PICK 3 PICK LINE ( bottom ) 4DROP ;
: DRAW-BOX LEFT TOP RIGHT BOT RECTANGLE ;
\ center mouse
: CENTER-PCURSOR RIGHT LEFT + 2/ BOT TOP + 2/ !POSITION ;
-->
Screen # 139
\ Frame an Axis GDS 1 09:56 06-29-99
\ dmin dmax ___ min max interval:set limits & tick intervals
: !AXIS 2DUP SWAP - ABS S>F 5.E0 F/ FDUP FLOG FDUP
F0< IF FONE F- THEN FTRUNCATE FALOG FDUP FTEMP F!
F/ F>S 1 OVER 1 > IF DROP 2 THEN
OVER 2 > IF DROP 5 THEN NIP
S>F FTEMP F@ F* F>S DUP >R
/MOD SWAP IF 1+ THEN R@ * SWAP \ max
R@ / R@ * SWAP \ min
2DUP SWAP - R> / ; \ # tick intervals
\ x, y ___ : blink cursor and mark position with a cross
: XCURSOR CLICK HIDE-CURSOR
XC@ 5 - YC@ OVER 10 + OVER LINE
XYC@ 4- OVER OVER 8 + LINE SHOW-CURSOR ;
-->
Screen # 140
\ Tick Marks GDS 1 16:38 06-24-95
8 EQU XTSIZE 7 EQU YTSIZE
0 EQU XTICKS 0 EQU YTICKS
: TICKS XTICKS 1 DO XSIZE I XTICKS */
LEFT + DUP TOP OVER OVER XTSIZE + LINE
BOT OVER OVER XTSIZE - LINE LOOP
YTICKS 1 DO YSIZE I YTICKS */
BOT + DUP LEFT RIGHT MIN SWAP OVER YTSIZE + OVER LINE
LEFT RIGHT MAX SWAP OVER YTSIZE - OVER LINE
LOOP ;
: !AXES DLEFT DRIGHT !AXIS EQU XTICKS
PLOTSIZE MIN EQU DRIGHT EQU DLEFT
DBOT DTOP !AXIS EQU YTICKS EQU DTOP EQU DBOT ;
-->
Screen # 141
\ Tick Labels GDS 2 13:25 06-29-99
0 EQU TITLE-ALIAS
: TICK-LABELS BOT YTICKS 1+ 0
DO LEFT RIGHT MIN 43 - OVER
YSIZE I YTICKS */ + GXY>AXY
DYSIZE I YTICKS */ DBOT + 6.R LOOP DROP
LEFT 12 - XTICKS 1+ 0
DO DUP XSIZE I XTICKS */ + BOT 16 + GXY>AXY
DXSIZE I XTICKS */ DLEFT + 4.R LOOP DROP ;
\ lo hi ___ set axes manually
: XLIM ORDER 2DUP DUP EQU CRIGHT EQU DRIGHT
EQU CLEFT 10 - MIN EQU DLEFT ;
: YLIM ORDER DUP EQU DTOP 10 - MIN EQU DBOT ;
-->
Screen # 142
\ Scale and Plot 13:18 06-29-99
: PL-TITLE 9 0 GOTOXY VPIC@ .TITLE
." Avg of " TITLE-ALIAS EXECUTE ;
: LINES DLEFT DUP 0 PLOTSIZE 1- BOUND PLOTBUF @ DXY>GXY
DRIGHT 1+ 0 PLOTSIZE 1- BOUND
DLEFT 0 COLS 1- BOUND 1+
DO I DUP PLOTBUF @ DXY>GXY 2DUP >R >R LINE
R> R> LOOP 2DROP ;
-->
Screen # 143
\ Scale and Plot GDS 1 13:17 06-29-99
: RESET-LR DUP LEFT + EQU LEFT RIGHT + EQU RIGHT ;
: STEPS XSIZE DXSIZE / 2/ DUP NEGATE RESET-LR
DLEFT 1+ DUP 0 PLOTSIZE 1- BOUND PLOTBUF @ DXY>GXY
DRIGHT 1+ 0 PLOTSIZE 1- BOUND DLEFT 0 COLS 1- BOUND 1+
DO I DUP PLOTBUF @ DXY>GXY
>R OVER 2DUP >R >R LINE
R> R> OVER R@ OVER >R LINE
R> R> LOOP 2DROP RESET-LR ;
-->
Screen # 144
\ Scale and Plot GDS 1 13:16 06-29-99
\ choose LINES or STEPS for plotting
VARIABLE HISTO
: POINTS HISTO @ IF STEPS ELSE LINES THEN ;
\ set data max and min
: AUTOSCALE 0 BIGGEST#
PLOTSIZE DUP EQU DRIGHT 0 DUP EQU DLEFT
DO I PLOTBUF @ DUP >R MIN SWAP R> MAX SWAP LOOP
DUP EQU DBOT 10 + MAX EQU DTOP ;
\ Replot with current parameters
: REPLOT HIDE-CURSOR CLS !AXES TICK-LABELS DRAW-BOX TICKS
POINTS PL-TITLE ZERO-CURSOR ;
-->
Screen # 145
\ Resize and Full-Size Plot 12:33 06-30-99
\ ___ resize plot
: RESIZE XCURSOR BEGIN READ-MOUSE .DXY
LBUTTON IF LRELEASE XYC@ GXY>DXY 1
ELSE 0
THEN ESCAPE-PLT? UNTIL
FYO F@ F>S YLIM FXO F@ F>S XLIM REPLOT ;
\ ___ full-size plot
: FULLSIZE CLICK AUTOSCALE REPLOT ;
-->
Screen # 146
\ Mouse GDS 0 12:33 06-30-99
: PLOT-MOUSE mouse ON MOUSE-RESET DROP CENTER-PCURSOR
LEFT RIGHT HORIZ-LIMITS TOP BOT VERT-LIMITS
SHOW-CURSOR 1 PLACES
BEGIN ?mouse
READ-MOUSE .XYZ
LBUTTON IF LRELEASE RESIZE THEN
RBUTTON IF RRELEASE FULLSIZE THEN
ESCAPE-PLT? SHOW-CURSOR AGAIN ;
-->
Screen # 147
\ Plot GDS 0 08:07 04-02-98
: RPTITLE ." rows" 1TEMP 4.R ." thru" 2TEMP 4.R ;
: CPTITLE ." cols" 1TEMP 5.R ." thru" 2TEMP 5.R ;
: MPLOT BEGIN PLOT-MOUSE REPLOT AGAIN ;
: INITIAL-PLOT AUTOSCALE ['] MPLOT 7 !FUNKEY
GRAPHCOLORS REPLOT ;
-->
Screen # 148
\ Rowplot and Colplot 13:39 03-31-95
( m n ___ sum and plot )
: RP SUM-ROWS COLS !PLOTBUF
['] RPTITLE EQU TITLE-ALIAS INITIAL-PLOT ;
: CP SUM-COLS ROWS !PLOTBUF
['] CPTITLE EQU TITLE-ALIAS INITIAL-PLOT ;
: ROP SUM-ROWS COLS !PLOTBUF POINTS ;
: COP SUM-COLS ROWS !PLOTBUF POINTS ;
: RP- SUM-ROWS COLS -PLOTBUF INITIAL-PLOT ;
: CP- SUM-ROWS ROWS -PLOTBUF INITIAL-PLOT ;
-->
Screen # 149
\ FITS filename creation GDS 0 16:38 03-11-97
CREATE FITSNAME 33 ALLOT FITSNAME 33 ZSTR
HCB FITSFILE
CREATE FITSPATH 33 ALLOT FITSPATH 33 ZSTR
0 EQU FITSBUF
: FILL-LINE ." /" 48 SPACES ;
: H?LINE FITSBUF H@ 20 .R FILL-LINE ;
: HF?LINE FITSBUF H@ S>F 20 F.R FILL-LINE ;
-->
Screen # 150
\ FITS filename creation GDS 0 00:20 12-05-97
\ query for path of FITS files
: ?FITSPATH CR ." drive:\dir for FITS images: "
STRPAD 81 ZSTR STRPAD 32 ?STRING
STRPAD COUNT 1- + C@ [ ASCII \ ] LITERAL =
IF 0 ELSE [ ASCII \ ] LITERAL STRPAD COUNT + C! 1
THEN STRPAD C@ + STRPAD C! STRPAD FITSPATH CSTRMOV ;
\ make FITS filename from header filename [ preceded by "f" ]
: MAKE-NAME HFNAME FITSNAME CSTRMOV
FITSNAME COUNT -PATH OVER [ ASCII f ] LITERAL
SWAP C! STRPCK FITSPATH SWAP CSTRCAT
FITSNAME CSTRMOV FITSNAME FITSFILE NAME>HCB ;
-->
Screen # 151
\ Required FITS keywords G gds 11:25 11-30-91
( pbf# ___ make FITS header )
: REQ-KEYWORDS
." SIMPLE = " 29 SPACES ." T /" 38 SPACES
." BITPIX = " 1 H?LINE
." NAXIS = " 2 H?LINE
." NAXIS1 = " 3 H?LINE
." NAXIS2 = " 4 H?LINE ;
-->
Screen # 152
\ Optional FITS keywords - 1 11:19 12-21-00
27 EQU #BLANK
: OPT-KEYWORDS1 27 EQU #BLANK 2 PLACES
." OBJECT = '" 64 FITSBUF H# 32 TYPE ." ' /" 34 SPACES
." DATE-OBS= '" 5 FITSBUF H2@ .YMD ." ' /" 56 SPACES
8 0 DO 28 I 2* + FITSBUF H2@ 2DUP D0= NOT
IF ." UT = '" .HMS ." ' /" 58 SPACES
LEAVE ELSE 2DROP THEN LOOP
." INSTRUME= 'UA/STSCI SPECTROPOLARIMETER' /" 39 SPACES
." CRPIX1 = " 7 HF?LINE
." CDELT1 = " 8 HF?LINE
." CRPIX2 = " 9 HF?LINE
." CDELT2 = " 10 HF?LINE
." CCDPICNO= " 11 H?LINE
." APERTURE= " 12 H?LINE ;
-->
Screen # 153
\ Optional FITS keywords - 2 02:20 02-19-02
: OPT-KEYWORDS2 2 PLACES
." SHUTTER = " 13 H?LINE
." DEWTEMP = " 14 H?LINE
." BZERO = " 15 H?LINE
16 FITSBUF H@
IF ." DISPAXIS= " 16 H?LINE #BLANK 1- EQU #BLANK THEN
17 FITSBUF H@ IF ." AIRMASS = " 17 FITSBUF H@
S>F 1.E3 F/ 3 PLACES 20 F.R FILL-LINE
#BLANK 1- EQU #BLANK THEN
." MESSAGE = '" 72 FITSBUF H# 32 TYPE ." ' /" 33 SPACES ;
-->
Screen # 154
\ Exposure Keywords G gds 21:23 02-27-02
: EXP-KEYWORDS 0 8 0 DO I 44 + FITSBUF H@ + LOOP
." EXPTIME = " 20 .R FILL-LINE
8 0 DO ." WAVE" I 1+ 1 .R ." = " I 20 + H?LINE
." TIME" I 1+ 1 .R ." = '"
I 2* 28 + FITSBUF H2@ .HMS ." ' /" 58 SPACES
." EXPTIME" I 1+ 1 .R ." = " I 44 + H?LINE LOOP ;
: END-KEYWORD ." END" 77 SPACES ;
: BLANK-LINES 0 ?DO 80 SPACES LOOP ;
\ ___ compiled byte-swap and word-swap of entire data area
COMPILE: comBYTE-SWAP FITSBUF PBF@ DUP FITSBUF PBF-LENGTH +
SWAP DO I DUP @ >< W>< >< SWAP ! 4 +LOOP ;
-->
Screen # 155
\ Write FITS header and data gds 13:24 09-14-91
\ ___ write FITS header
: FITSHDR> FITSNAME ~>>FILE
REQ-KEYWORDS \ 5 lines
OPT-KEYWORDS1 \ 9 lines
OPT-KEYWORDS2 \ 6 lines
EXP-KEYWORDS \ 25 lines
END-KEYWORD \ 1 line
#BLANK BLANK-LINES \ pad with blank lines
CONSOLE FITSFILE FCLOSE DROP ; \ 72 lines total
\ ___ write FITS datafile to disk
: FITSDATA> FITSFILE 2 FOPEN DROP
FITSFILE 0 0 2 FSEEK 2DROP
FITSFILE FITSBUF PBF@ FITSBUF PBF-LENGTH FWRITE DROP
FITSFILE FCLOSE DROP ;
-->
Screen # 156
\ MAKEFITS 01:57 04-02-98
\ pic# ___ writes FITS files to disk
: TOFITS DUP NEW-NAMES
PIC>CORE EQU FITSBUF
MAKE-NAME FITSFILE ?FILE-ABSENT
FITSHDR>
comBYTE-SWAP
FITSFILE ?FILE-PRESENT
FITSDATA>
CR FITSFILE .FNAME ." created "
FITSBUF PBF-INIT ;
\ beg pic# end pic# ___ writes multiple FITS files to disk
: MAKEFITS ORDER ?FITSPATH 1+ SWAP DO I TOFITS ESCAPE? LOOP ;
-->
Screen # 157
\ Shells to utilities 20:43 10-11-00
\ Set PC clock
: SETCLOCK ." Set PC clock to UT!!" CR
SHELL" C:\DOS\SETCLOCK " ;
\ Query memory useage
: MEMUSE CLS SHELL" MEM /C | MORE " ;
\ Grating micrometer setting
: MICROMETER ?STOPPED
SHELL" central.exe " ?XY 1- GOTOXY 26 SPACES CR ;
-->
Screen # 158
\ Read in a strip picture GDS 2 02:26 04-02-98
VARIABLE STRIP_OPERATOR
\ ['] ccd_operator ___ reads in continuous strip
: READ_STRIP STRIP_OPERATOR !
START_PIC
MAX-DMA-LENGTH START_LINE \ first line
BEGIN
WAIT_FOR_DMA_END
MAX-DMA-LENGTH START_LINE
STRIP_OPERATOR PERFORM ?TERMINAL
UNTIL ;
-->
Screen # 159
\ Tests GDS 0 19:22 10-08-93
0 EQU VB# \ offset in print routine
: .STRIP_PRINT CR LAST_DMA_BUFFER
VB# 2* + DUP 10.R 10 0 DO DUP I 2* + UW@ 6.R LOOP DROP ;
: DMA-CHECK ['] .STRIP_PRINT SWEEP SLEEP READ_STRIP ;
-->
Screen # 160
\ Noise Calculations 19:34 11-17-94
FVARIABLE FMEAN FVARIABLE FSIG
\ x y sizex sizey ___ mean, rms of box centered at x,y
: NOISE 2/ EQU TEMP4 2/ EQU TEMP3 ( half ) EQU TEMP2 EQU TEMP1
FZERO FZERO
TEMP2 DUP TEMP4 1+ + CHECK-ROWS SWAP TEMP4 - CHECK-ROWS
DO TEMP1 DUP TEMP3 1+ + CHECK-COLS SWAP TEMP3 - CHECK-COLS
DO I J VP# IJP@ S>F FROT FOVER FSQ F+ -FROT F+ LOOP LOOP
1 PLACES CR ." Pic#" VP# 3.R SPACE
TEMP4 2* 1+ TEMP3 2* 1+
2DUP . ." x " . * S>F FDUP FTEMP F!
F/ FDUP FDUP FMEAN F! CR ." =" 8 F.R
FSQ FSWAP FTEMP F@ F/ FSWAP F- FSQRT
FTEMP F@ FDUP FONE F- F/ F* FDUP FSIG F!
CR ." …(f) =" 8 F.R CR ;
-->
Screen # 161
\ Biasnoise Calculations 15:13 07-11-94
: BIASNOISE COLS OVERSCAN 2/ - ROWS 2/ OVERSCAN 4-
ROWS 4- NOISE ;
: AUTOTV MTV BIASNOISE ; \ default postprocess
-->
Screen # 162
\ Gunn Test 11:24 07-08-94
0 EQU #G \ where we are
50 EQU #GUNN \ average over this many lines
0 EQU GLEAK \ average over this many averages
CHIPCOLS 1- EQU #GEDGE \ last phys column
0 EQU #GCOL \ selected column
0 EQU NEXT_ \ new average
0 EQU NEXT_2 \ new square
0 EQU 0 EQU 2 \ old averages
0.0 2EQU /LEAK \ double leaky average
0 EQU 0 EQU 0 EQU
0.0 2EQU DELTA-EFF
: @GUNN PRESCAN CBIN / CBIN + 1- +
2* LAST_DMA_BUFFER + UW@ ; \ get pix value
: 0>GUNN 0 EQU NEXT_ 0 EQU NEXT_2 0 EQU #G
0 EQU 0 EQU 0 EQU ; -->
Screen # 163
\ More Gunn testing 15:05 10-14-93
( this works every dma in )
: EVERY>GUNN
#GCOL @GUNN DUP NEXT_ + EQU NEXT_
- DUP * NEXT_2 + EQU NEXT_2
#GEDGE @GUNN + EQU
#GEDGE 1+ @GUNN + EQU
#GEDGE 2+ @GUNN + EQU ;
: GUNN_HEADER
." Col Average rms Leaky Edge Edge+1 Edge+2 ‹-eff"
3 SPACES .BIN ;
: PRINT_GUNN #GCOL 4.R 10.R 2 7.R
2 PLACES /LEAK 8 F.R 7.R
7.R 7.R 5 PLACES DELTA-EFF 9 F.R
CR 1000 MS ; -->
Screen # 164
\ More Gunn testing 11:32 05-20-91
( this handles the average every major cycle )
: CYCLE>GUNN
NEXT_ S>F #GUNN S>F F/ F>S EQU
NEXT_2 S>F #GUNN S>F F/ FSQRT F>S EQU 2
S>F #GUNN S>F F/ F>S EQU
S>F #GUNN S>F F/ F>S EQU
S>F #GUNN S>F F/ F>S EQU
- S>F - 1 MAX S>F
F/ ( slop/edge ) 2EQU DELTA-EFF ;
-->
Screen # 165
\ More Gunn Testing 01:57 04-02-98
: .GUNN EVERY>GUNN #G 1+ EQU #G \ read in a line
#G #GUNN = \ check if we are done
IF CYCLE>GUNN GLEAK 1+ 10 MIN EQU GLEAK \ start up
/LEAK GLEAK 1 MAX 1- S>F F*
2 S>F F+ GLEAK 1 MAX S>F F/ 2EQU /LEAK
PRINT_GUNN 0>GUNN
THEN ;
\ col ___ execute GUNN cycle
: GUNN ?STOPPED SWEEP SLEEP
0 MAX-DMA-LENGTH 1- CHECK EQU #GCOL \ select col
CLS GUNN_HEADER CR -10 EQU GLEAK
FTEN 2EQU /LEAK ['] .GUNN READ_STRIP ;
-->
Screen # 166
\ Temperature testing 08:21 05-15-98
CREATE TFNAME 33 ALLOT TFNAME 33 ZSTR
1 EQU TSAMP
: TEMPOUT .TIME TEMP_IN 5.R ; -->
: COOLING CR ." File for temperature record: "
TFNAME 32 ?STRING
CR ." Run time (minutes): " #IN 1 1440 BOUND
CR ." Sample interval (minutes): " #IN
1 60 BOUND DUP EQU TSAMP /
CR ." CCD Cooling: " .DATE CR
0 DO TEMPOUT CR TFNAME ~>>FILE TEMPOUT CR CONSOLE
TSAMP 60 * 0 DO 1000 MS ESCAPE? LOOP LOOP ;
-->
Screen # 167
\ Menu Items GDS 23:08 04-01-98
-1 EQU #ITEM 8 EQU #ITEMS
-1 EQU #CHOICE -1 EQU LASTCHOICE
20 EQU MAXCHOICES 16 EQU MAXWIDTH
#ITEMS CARRAY #CHOICES #ITEMS CARRAY ITEMWIDTH
#ITEMS MAXCHOICES * ARRAY ITEMTASK
#ITEMS MAXCHOICES * MAXWIDTH * CARRAY ITEMLABEL
#ITEMS ARRAY XLO #ITEMS ARRAY XHI
\ zero-out itemlabels and itemtasks
' NOOP 0 ITEMTASK !
0 ITEMTASK DUP WSIZE + #ITEMS MAXCHOICES * 4 * 4- CMOVE
0 ITEMLABEL #ITEMS MAXCHOICES * MAXWIDTH * BLANK
-->
Screen # 168
\ Menu Primitives GDS 23:10 04-01-98
\ xlo xhi width item ___ sets up itemlists
: ITEMINIT DUP >R ITEMWIDTH C! R@ XHI ! R@ XLO !
0 R> #CHOICES C! ;
\ initialize itemlists
0 106 13 0 ITEMINIT
154 186 4 1 ITEMINIT
194 226 4 2 ITEMINIT
234 274 5 3 ITEMINIT
274 394 15 4 ITEMINIT
394 506 14 5 ITEMINIT
514 546 4 6 ITEMINIT
594 640 6 7 ITEMINIT
-->
Screen # 169
\ Menu Primitives GDS 23:02 04-01-98
\ x xlo xhi ___ false (0) if between; true (non-0) if outside
: OUTSIDE? 2 PICK < -ROT < + ;
\ item choice ___ false (0) if invalid, true (non-0) if valid
: ICVALID? OVER #CHOICES C@ 0 SWAP OUTSIDE?
SWAP 0 #ITEMS OUTSIDE? + 0= ;
\ item choice ___ 2D element number
: IC SWAP MAXCHOICES * + ;
\ item choice task label ___ load choice
: LOADCHOICE 2 PICK 0 MAXCHOICES CHECK DROP
COUNT STRPCK 3 PICK 3 PICK IC MAXWIDTH *
ITEMLABEL CSTRMOV
-ROT 2DUP 1+ SWAP #CHOICES C! IC ITEMTASK ! ; -->
Screen # 170
\ Menu Procedure Commands GDS 14:06 07-14-99
VARIABLE MENUPROC 0 EQU EXITFLAG
\ ___ set flags to exit menu
: EXITMENU 1 EQU EXITFLAG -1 EQU #ITEM CLS ;
\ ___ initialize menu post-processor command
: MENUPROC-INIT [ ' NOOP ] LITERAL MENUPROC ! ;
\ ___ repositions at beginning of line #20
: L20 0 20 GOTOXY ;
-->
Screen # 171
\ Datafile Menu Commands 14:07 07-14-99
: MENU-MF L20
REVERSE ." First Pic# for FITS conversion:"
REVERSE SPACE #IN 2 SPACES
REVERSE ." Last Pic#: " REVERSE SPACE #IN
[ ' MAKEFITS ] LITERAL MENUPROC ! EXITMENU ;
: MENU-FT L20 ?FORMAT ANYKEY ;
: MENU-OD L20 OPEN-DATAFILE ;
: MENU-RC L20 RECONFIGURE MENUCOLORS ;
: MENU-SC L20 SAVECONFIG ;
: MENU-GR L20 GRATINGS ANYKEY ;
: MENU-FO L20 FOCUS ANYKEY ;
: MENU-CH L20 CHIP ANYKEY ;
: MENU-MI L20 MICROMETER ANYKEY ;
: MENU-HP L20 HELP ANYKEY ;
-->
Screen # 172
\ Menu Commands GDS 19:28 10-27-00
\ Aperture menu commands
: MENU-APT #CHOICE APT ;
: MENU-AP? APERTURES ANYKEY ;
\ Waveplate menu commands
: MENU-WAVE #CHOICE WAVE ;
: MENU-WV? WAVEPLATES ANYKEY ;
\ Label menu command
: MENU-LABEL L20 REVERSE ." Enter label:" REVERSE
SPACE label ;
\ Dwell menu commands
: MENU-ZDWELL L20 0 SEC ;
: MENU-DWELL L20
REVERSE ." Dwell in sec/exp:" REVERSE SPACE #IN SEC ;
-->
Screen # 173
\ Go/Test Menu Commands 14:07 07-14-99
: MENU-TEST [ ' TEST ] LITERAL MENUPROC ! EXITMENU ;
: MENU-GO [ ' GO ] LITERAL MENUPROC ! EXITMENU ;
: MENU-GOS L20
REVERSE ." No. of exposures:" REVERSE SPACE #IN
[ ' GOS ] LITERAL MENUPROC ! EXITMENU ;
: MENU-GUNN CHIPCOLS OVERSCAN 2/ + GUNN SWEEP WAKE ;
-->
Screen # 174
\ Datafile Menu Choices 16:46 07-01-99
0 0 ' MENU-OD " Open-Datafile" LOADCHOICE
0 1 ' MENU-FT " ?Format " LOADCHOICE
0 2 ' FORMAT " Format " LOADCHOICE
0 3 ' MENU-MF " Make-FITS " LOADCHOICE
0 4 ' MENU-RC " Reconfigure " LOADCHOICE
0 5 ' MENU-SC " SaveConfig " LOADCHOICE
0 6 ' MENU-GR " Gratings? " LOADCHOICE
0 7 ' MENU-FO " Focus? " LOADCHOICE
0 8 ' MENU-CH " Chip? " LOADCHOICE
0 9 ' MENU-MI " Micrometer " LOADCHOICE
0 10 ' MENU-HP " Help " LOADCHOICE
0 11 ' EXITMENU " Exit " LOADCHOICE
-->
Screen # 175
\ Sequence Menu Choices 15:50 01-12-99
1 0 ' SNAPSHOT " Snap" LOADCHOICE
1 1 ' Q-SEQUENCE " Q " LOADCHOICE
1 2 ' U-SEQUENCE " U " LOADCHOICE
1 3 ' V-SEQUENCE " V " LOADCHOICE
-->
Screen # 176
\ Aperture Menu Choices GDS 02:51 04-02-98
2 0 ' MENU-APT " 0 " LOADCHOICE
2 1 ' MENU-APT " 1 " LOADCHOICE
2 2 ' MENU-APT " 2 " LOADCHOICE
2 3 ' MENU-APT " 3 " LOADCHOICE
2 4 ' MENU-APT " 4 " LOADCHOICE
2 5 ' MENU-APT " 5 " LOADCHOICE
2 6 ' MENU-APT " 6 " LOADCHOICE
2 7 ' MENU-APT " 7 " LOADCHOICE
2 8 ' ZAPT " Zapt" LOADCHOICE
2 9 ' ZERO " Zero" LOADCHOICE
2 10 ' MENU-AP? " Apt?" LOADCHOICE
-->
Screen # 177
\ Waveplate menu choices GDS 17:15 05-17-98
3 0 ' MENU-WAVE " 0 " LOADCHOICE
3 1 ' MENU-WAVE " 1 " LOADCHOICE
3 2 ' MENU-WAVE " 2 " LOADCHOICE
3 3 ' MENU-WAVE " 3 " LOADCHOICE
3 4 ' MENU-WAVE " 4 " LOADCHOICE
3 5 ' MENU-WAVE " 5 " LOADCHOICE
3 6 ' MENU-WAVE " 6 " LOADCHOICE
3 7 ' MENU-WAVE " 7 " LOADCHOICE
3 8 ' MENU-WAVE " 8 " LOADCHOICE
3 9 ' MENU-WAVE " 9 " LOADCHOICE
3 10 ' MENU-WAVE " 10 " LOADCHOICE
3 11 ' MENU-WAVE " 11 " LOADCHOICE
3 12 ' MENU-WAVE " 12 " LOADCHOICE
3 13 ' MENU-WAVE " 13 " LOADCHOICE
-->
Screen # 178
\ Waveplate menu choices GDS 02:53 04-02-98
3 14 ' MENU-WAVE " 14 " LOADCHOICE
3 15 ' MENU-WAVE " 15 " LOADCHOICE
3 16 ' ZWAVE " Zwave" LOADCHOICE
3 17 ' ZERO " Zero" LOADCHOICE
3 18 ' MENU-WV? " Wave?" LOADCHOICE
-->
Screen # 179
\ Wave, start, shutter, and dwell choices GDS 07:36 03-12-00
4 0 ' MENU-GO " Go " LOADCHOICE
4 1 ' MENU-GOS " Gos " LOADCHOICE
4 2 ' MENU-GUNN " Gunn Noise Test" LOADCHOICE
4 3 ' MENU-TEST " Test " LOADCHOICE
5 0 ' MENU-LABEL " Label " LOADCHOICE
6 0 ' LITE " Lite" LOADCHOICE
6 1 ' DARK " Dark" LOADCHOICE
7 0 ' MENU-DWELL " select" LOADCHOICE
7 1 ' MENU-ZDWELL " 0 sec" LOADCHOICE
-->
Screen # 180
\ Menu Label Definitions GDS 17:38 05-17-98
\ item choice ___ compute appropriate row/column
: IC>XY >R XLO @ R> 1+ 16 * ;
\ item choice ___ type item label
: IC>ILABEL 2DUP ICVALID?
IF 2DUP IC>XY GXY>AXY IC 16 * ITEMLABEL COUNT TYPE
ELSE 2DROP THEN ;
-->
Screen # 181
\ Menu Pulldowns GDS 18:20 05-17-98
\ item ___ draw box around pulldown menu
: MENUBOX DUP >R XLO @ 4 - 0 R@ XHI @ 1-
R> #CHOICES C@ 1+ 16 * 1+ RECTANGLE ;
\ item ___ paint pulldown menu
: PULLDOWN HIDE-CURSOR DUP MENUBOX DUP #CHOICES C@ 0
?DO DUP I IC>ILABEL LOOP DROP SHOW-CURSOR ;
\ item ___ erase itemlabels
: ERASE-PULLDOWN HIDE-CURSOR DUP #CHOICES C@ 1+ 0
?DO DUP I IC>XY SWAP 1- SWAP GXY>AXY
DUP ITEMWIDTH C@ 2+ SPACES LOOP
DROP SHOW-CURSOR ;
-->
Screen # 182
\ Highlighting and Button Checking GDS 12:39 06-30-99
\ ___ highlight choice
: HIGHLIGHT HIDE-CURSOR #ITEM PULLDOWN
REVERSE #ITEM #CHOICE IC>ILABEL REVERSE
SHOW-CURSOR ;
\ ___ Left Button: execute task; Right Button: escape
: BUTTONCHECK
LBUTTON IF LRELEASE #ITEM #CHOICE 2DUP ICVALID?
IF HIDE-CURSOR IC ITEMTASK PERFORM
#ITEM ERASE-PULLDOWN -1 EQU #ITEM
CLS STATUS SHOW-CURSOR
ELSE 2DROP THEN
THEN
RBUTTON IF RRELEASE #ITEM ERASE-PULLDOWN CLS SCREENCOLORS
STATUS ESCAPE! THEN ;
-->
Screen # 183
\ Cursor Selection GDS 09:22 05-15-98
\ ___ check if cursor is outside column
: XOUT? XC@ #ITEM XLO @ #ITEM XHI @ OUTSIDE? ;
\ item ___ check for a particular choice
: CHOICE? DUP YC@ SWAP 1+ 16 * DUP 16 + OUTSIDE? 0=
IF #CHOICE EQU LASTCHOICE EQU #CHOICE
ELSE DROP THEN ;
\ ___ check for any choice
: CHOICECHECK XOUT?
IF #ITEM ERASE-PULLDOWN -1 EQU #ITEM
ELSE #ITEM #CHOICES C@ 0 ?DO I CHOICE? LOOP
LASTCHOICE #CHOICE - IF HIGHLIGHT THEN
THEN ;
-->
Screen # 184
\ Cursor Selection GDS 12:33 06-30-99
\ item ___ set #ITEM if cursor inside status-line box
: ITEM? DUP >R XC@ R@ XLO @ R> XHI @ OUTSIDE?
YC@ 0 16 OUTSIDE? + 0=
IF EQU #ITEM ELSE DROP THEN ;
\ ___ check for selected column
: TRACK READ-MOUSE
-1 EQU #ITEM #ITEMS 0 ?DO I ITEM? LOOP
-1 #ITEM <
IF #ITEM PULLDOWN 0 EQU #CHOICE 0 EQU LASTCHOICE
HIGHLIGHT BEGIN READ-MOUSE CHOICECHECK
BUTTONCHECK
#ITEM 0 < UNTIL
THEN ;
-->
Screen # 185
\ Menu Mouse GDS 12:41 06-30-99
\ ___ main menu driver
: MENU-MOUSE mouse ON MOUSE-RESET DROP CENTER-PCURSOR
0 GXPIX HORIZ-LIMITS 0 GYPIX VERT-LIMITS
SHOW-CURSOR -1 EQU #ITEM 0 EQU EXITFLAG
BEGIN TRACK BUTTONCHECK
ESCAPE-PLT? EXITFLAG UNTIL
HIDE-CURSOR mouse OFF ;
\ ___ start up menu
: MENU ?STOPPED CLS MENUCOLORS STATUS
MENUPROC-INIT MENU-MOUSE SCREENCOLORS
MENUPROC PERFORM ;
\ Redefine CLS for ease of use
: CLS CLS SCREENCOLORS ;
-->
Screen # 186
\ EXPLAIN help listing GDS 20:35 10-11-00
CREATE GREPWD 32 ALLOT GREPWD 32 BLANK
: WRITEBAT ." @echo off" CR
." c:\utils\grep\grep.exe -i" SPACE
GREPWD COUNT TYPE SPACE
." CCDLOHLP.PRN" ;
: EXPLAIN CR ." word to explain: " GREPWD 32 ?STRING
GREPWD COUNT SWAP DROP
IF >>FILE CCDGREP.BAT WRITEBAT CONSOLE
SHELL" CCDGREP.BAT"
SHELL" DEL CCDGREP.BAT"
THEN QUIT ;
-->
Screen # 187
\ Function Key Assignments GDS 19:48 10-11-00
' HELP 1 !FUNKEY
' STATUS 2 !FUNKEY
' GO 3 !FUNKEY
' TV 4 !FUNKEY
' MENU 5 !FUNKEY
' EXPLAIN 6 !FUNKEY
( MOUSE 7 mode-dependent )
' FORMAT 8 !FUNKEY
' OPEN-DATAFILE 9 !FUNKEY
' TEST 10 !FUNKEY
-->
Screen # 188
\ Hardware Initialization GDS 09:17 05-15-98
WAVE-OFF \ stop waveplate motor
APT-OFF \ stop aperture motor
ZEROED OFF \ instrument not initialized
LITE \ normal shutter
0 EQU BINMODE 0 MODE-SET \ default readout mode
SWEEP WAKE \ start vertical shifting
-->
Screen # 189
\ Software Initialization GDS 01:59 04-02-98
OBSERVING OFF \ not observing
PAUSED OFF \ not paused
DATAFILE OFF \ datafile not selected
AIRMASSPROMPT OFF \ don't prompt for airmass
AMASS ON \ record airmass
HISTO OFF \ plot dot-to-dot
FUNKEY-ON \ function keys on
1 SEC SNAPSHOT \ 1 sec single-exposure default
RTB CLS VW0 \ red-to-blue VLU, video window 0
POSTPROCESS AUTOTV \ automatic TV after exposure
INFO \ display information block
?FORMAT \ display default chip-format
KEYLABELS \ display function key help
STATUS TOOT \ display status banner
\ End of debugged, integrated code