[apple/bootx.git] / bootx.tproj / ci.subproj / Control2.c

/*
 * Copyright (c) 2000 Apple Computer, Inc. All rights reserved.
 *
 * @APPLE_LICENSE_HEADER_START@
 * 
 * Copyright (c) 1999-2003 Apple Computer, Inc.  All Rights Reserved.
 * 
 * This file contains Original Code and/or Modifications of Original Code
 * as defined in and that are subject to the Apple Public Source License
 * Version 2.0 (the 'License'). You may not use this file except in
 * compliance with the License. Please obtain a copy of the License at
 * http://www.opensource.apple.com/apsl/ and read it before using this
 * file.
 * 
 * The Original Code and all software distributed under the License are
 * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER
 * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,
 * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.
 * Please see the License for the specific language governing rights and
 * limitations under the License.
 * 
 * @APPLE_LICENSE_HEADER_END@
 */
/*
 *  Control2.c - OF replacement driver for Control.
 *
 *  Copyright (c) 1998-2000 Apple Computer, Inc.
 *
 *  DRI: Josh de Cesare
 */

const char *gControl2Source[] = {
	"\" /chaos/control\" find-device "
	"-1 value bankB? "
	"-1 value REGS "
	"-1 value FB-ADDRESS "
	"-1 value phys-regs "
	"-1 value phys-fb-address "
	"0 value mono-mode? "
	"0 value width "
	"0 value height "
	"0 value sense-code "
	"0 value ext-sense "
	"h# F301B000 constant RADACAL "
	"h# F301B000 constant RADACAL-base "
	"variable RGB-temp "
	"struct "
	"( 000 )	d# 16	field	>C.CUR-LINE "
	"( 010 )	d# 16	field	>C.VFPEQ "
	"( 020 )	d# 16	field	>C.VFP "
	"( 030 )	d# 16	field	>C.VAL "
	"( 040 )	d# 16	field	>C.VBP "
	"( 050 )	d# 16	field	>C.VBPEQ "
	"( 060 )	d# 16	field	>C.VSYNC "
	"( 070 )	d# 16	field	>C.VHLINE "
	"( 080 )	d# 16	field	>C.PIPED "
	"( 090 )	d# 16	field	>C.HPIX "
	"( 0A0 )	d# 16	field	>C.HFP "
	"( 0B0 )	d# 16	field	>C.HAL "
	"( 0C0 )	d# 16	field	>C.HBWAY "
	"( 0D0 )	d# 16	field	>C.HSP "
	"( 0E0 )	d# 16	field	>C.HEQ "
	"( 0F0 )	d# 16	field	>C.HLFLN "
	"( 100 )	d# 16	field	>C.HSERR "
	"( 110 )	d# 16	field	>C.CNTTST "
	"( 120 )	d# 16	field	>C.TEST "
	"( 130 )	d# 16	field	>C.GBASE "
	"( 140 )	d# 16	field	>C.ROW-WORDS "
	"( 150 )	d# 16	field	>C.MON-SENSE "
	"( 160 )	d# 16	field	>C.ENABLE "
	"( 170 )	d# 16	field	>C.GSC-DIVIDE "
	"( 180 )	d# 16	field	>C.REFRESH-COUNT "
	"( 190 )	d# 16	field	>C.INT-ENABLE "
	"( 1A0 )	d# 16	field	>C.INT-STATUS "
	"drop "
	"struct "
	"d# 16	field	>R.REG-ADDR "
	"d# 16	field	>R.CRSR-PALETTE "
	"d# 16	field	>R.REG-DATA "
	"d# 16	field	>R.COLOR-PALETTE "
	"drop "
	"create k512x384@60 "
	"h# 0E1B6210 L, "
	"d# 811 w, d# 810 w, d# 42 w, d# 23 w, d# 4 w, d# 812 w, d# 814 w, d# 48 w, "
	"d# 318 w, d# 305 w, d# 49 w, d# 15 w, d# 319 w, d# 8 w, d# 160 w, d# 304 w, "
	"d# 2 w, d# 512 w, d# 384 w, "
	"create k640x480@67 "
	"h# 0E1B0210 L, "
	"d# 1045 w, d# 1042 w, d# 82 w, d# 43 w, d# 4 w, d# 1048 w, d# 1050 w, d# 72 w, "
	"d# 430 w, d# 393 w, d# 73 w, d# 31 w, d# 431 w, d# 16 w, d# 216 w, d# 400 w, "
	"d# 2 w, d# 640 w, d# 480 w, "
	"create k640x870@75 "
	"h# 172A0310 L, "
	"d# 1831 w, d# 1828 w, d# 88 w, d# 46 w, d# 4 w, d# 1834 w, d# 1836 w, d# 72 w, "
	"d# 414 w, d# 393 w, d# 73 w, d# 39 w, d# 415 w, d# 20 w, d# 208 w, d# 376 w, "
	"d# 2 w, d# 640 w, d# 870 w, "
	"create k640x480@60VGA "
	"h# 17250210 L, "
	"d# 1037 w, d# 1026 w, d# 66 w, d# 34 w, d# 2 w, d# 1048 w, d# 1050 w, d# 64 w, "
	"d# 398 w, d# 385 w, d# 65 w, d# 47 w, d# 399 w, d# 24 w, d# 200 w, d# 352 w, "
	"d# 2 w, d# 640 w, d# 480 w, "
	"create k832x624@75 "
	"h# 172A0310 L, "
	"d# 1331 w, d# 1330 w, d# 82 w, d# 43 w, d# 4 w, d# 1332 w, d# 1334 w, d# 136 w, "
	"d# 574 w, d# 553 w, d# 137 w, d# 31 w, d# 575 w, d# 16 w, d# 288 w, d# 544 w, "
	"d# 2 w, d# 832 w, d# 624 w, "
	"create k1024x768@75 "
	"h# 0B1C0310 L, "
	"d# 1603 w, d# 1600 w, d# 64 w, d# 34 w, d# 4 w, d# 1606 w, d# 1608 w, d# 128 w, "
	"d# 662 w, d# 641 w, d# 129 w, d# 47 w, d# 663 w, d# 24 w, d# 332 w, d# 616 w, "
	"d# 2 w, d# 1024 w, d# 768 w, "
	"create k1152x870@75 "
	"h# 133D0310 L, "
	"d# 1825 w, d# 1822 w, d# 82 w, d# 43 w, d# 4 w, d# 1828 w, d# 1830 w, d# 128 w, "
	"d# 726 w, d# 705 w, d# 129 w, d# 63 w, d# 727 w, d# 32 w, d# 364 w, d# 664 w, "
	"d# 2 w, d# 1152 w, d# 870 w, "
	": SENSE! 5 ms regs >C.MON-SENSE rl! 5 ms ; "
	": SENSE@ 5 ms regs >C.MON-SENSE rl@ 5 ms ; "
	": MON-SENSE	( -- ) "
	"o# 70 sense! "
	"sense@ 6 >> 7 and dup to sense-code "
	"dup 6 < if "
	"b# 1000000 or "
	"else drop "
	"o# 30 sense! "
	"sense@ 2 >> b# 110000 and "
	"o# 50 sense! "
	"sense@ dup 4 >> b# 000100 and swap 5 >> b# 001000 and or or "
	"o# 60 sense! sense@ 7 >> b# 000011 and or "
	"to ext-sense "
	"then "
	"o# 70 sense! "
	"; "
	": get-mode ( -- mode-table mono-mode? ) "
	"sense-code case "
	"0 of "
	"false "
	"k1152x870@75 "
	"endof "
	"1 of "
	"true "
	"k640x870@75 "
	"endof "
	"2 of "
	"false "
	"k512x384@60 "
	"endof "
	"3 of "
	"true "
	"k1152x870@75 "
	"endof "
	"5 of "
	"false "
	"k640x870@75 "
	"endof "
	"6 of "
	"ext-sense case "
	"3 of "
	"false "
	"k832x624@75 "
	"endof "
	"h# 0b of "
	"false "
	"k1024x768@75 "
	"endof "
	"h# 23 of "
	"false "
	"k1152x870@75 "
	"endof "
	"drop "
	"false "
	"k640x480@67 "
	"0 endcase "
	"endof "
	"7 of "
	"ext-sense case "
	"h# 2d of "
	"false "
	"k832x624@75 "
	"endof "
	"h# 3a of "
	"false "
	"k1024x768@75 "
	"endof "
	"h# 17 of "
	"false "
	"k640x480@60VGA "
	"endof "
	"h# 3f of "
	"false "
	"0 "
	"endof "
	"drop "
	"false "
	"k640x480@67 "
	"0 endcase "
	"endof "
	"drop "
	"false "
	"k640x480@67 "
	"0 endcase "
	"; "
	"HEADERLESS "
	"create std-16 "
	"\" \"(000000 0000AA 00AA00 00AAAA AA0000 AA00AA AA5500 AAAAAA)\" $c, "
	"\" \"(555555 5555FF 55FF55 55FFFF FF5555 FF55FF FFFF55 FFFFFF)\" $c, "
	"create std-gamma "
	"\" \"(00 05 09 0B 0E 10 13 15 17 19 1B 1D 1E 20 22 24)\" $c, "
	"\" \"(25 27 28 2A 2C 2D 2F 30 31 33 34 36 37 38 3A 3B)\" $c, "
	"\" \"(3C 3E 3F 40 42 43 44 45 47 48 49 4A 4B 4D 4E 4F)\" $c, "
	"\" \"(50 51 52 54 55 56 57 58 59 5A 5B 5C 5E 5F 60 61)\" $c, "
	"\" \"(62 63 64 65 66 67 68 69 6A 6B 6C 6D 6E 6F 70 71)\" $c, "
	"\" \"(72 73 74 75 76 77 78 79 7A 7B 7C 7D 7E 7F 80 81)\" $c, "
	"\" \"(81 82 83 84 85 86 87 88 89 8A 8B 8C 8C 8D 8E 8F)\" $c, "
	"\" \"(90 91 92 93 94 95 95 96 97 98 99 9A 9B 9B 9C 9D)\" $c, "
	"\" \"(9E 9F A0 A1 A1 A2 A3 A4 A5 A6 A6 A7 A8 A9 AA AB)\" $c, "
	"\" \"(AB AC AD AE AF B0 B0 B1 B2 B3 B4 B4 B5 B6 B7 B8)\" $c, "
	"\" \"(B8 B9 BA BB BC BC BD BE BF C0 C0 C1 C2 C3 C3 C4)\" $c, "
	"\" \"(C5 C6 C7 C7 C8 C9 CA CA CB CC CD CD CE CF D0 D0)\" $c, "
	"\" \"(D1 D2 D3 D3 D4 D5 D6 D6 D7 D8 D9 D9 DA DB DC DC)\" $c, "
	"\" \"(DD DE DF DF E0 E1 E1 E2 E3 E4 E4 E5 E6 E7 E7 E8)\" $c, "
	"\" \"(E9 E9 EA EB EC EC ED EE EE EF F0 F1 F1 F2 F3 F3)\" $c, "
	"\" \"(F4 F5 F5 F6 F7 F8 F8 F9 FA FA FB FC FC FD FE FF)\" $c, "
	": c+		( adr -- adr+1 val ) "
	"dup 1+ swap c@ "
	"; "
	": c!+		( adr val -- adr+1 ) "
	"swap dup 1+ -rot c! "
	"; "
	": do-gamma "
	"std-gamma + c@ "
	"; "
	": anti-gamma	( val -- orig ) "
	"h# 100 0 do "
	"std-gamma i + c@ over >= if "
	"drop i unloop exit "
	"then "
	"loop "
	"drop h# ff "
	"; "
	": W@++	( addr -- addr word ) "
	"dup 2+ swap w@ "
	"; "
	": CLUT@ ( -- ) "
	"3 0 do RADACAL-base >R.COLOR-PALETTE rb@ loop 2 ms "
	"; "
	": CLUT!	( -- ) "
	"3 0 do RADACAL-base >R.COLOR-PALETTE rb! loop 2 ms "
	"; "
	": RAD-REG-ADDR! "
	"RADACAL-base >R.REG-ADDR rb! 2 ms "
	"; "
	": RAD!	( c a -- ) "
	"( a ) rad-reg-addr! "
	"( c ) 	RADACAL-base >R.REG-DATA rb! 2 ms "
	"; "
	": init-RADACAL ( val -- ) "
	"( val ) h# 20 rad! "
	"bankb? 1 and h# 21 rad! "
	"0	h# 10 rad! "
	"0	h# 11 rad! "
	"; "
	"h# F3016000 constant vPortB "
	"h# F3016400 constant vDDRB "
	"h# F3017400 constant vSHR "
	"h# F3017600 constant vACR "
	"h# F3017800 constant vPCR "
	"h# F3017A00 constant vIFR "
	"h# F3017C00 constant vIER "
	"h# 0C constant kSRModeIn "
	"h# 1C constant kSRModeOut "
	"h# 04 constant kSRIReq "
	"h# 10 constant kByteAckBit "
	"h# DF constant kAssertTIP "
	"h# 20 constant kNegateTIP "
	"h# EF constant kAssertByteAck "
	"h# 10 constant kNegateByteAck "
	"h# 30 constant kTIPByteAckNeg "
	"h# 08 constant kTREQBit "
	": setByteAck "
	"vPortB rb@ swap if "
	"kAssertByteAck and "
	"else "
	"kNegateByteAck or "
	"then "
	"vPortB rb! "
	"; "
	": ToggleByteAck "
	"vPortB rb@ kByteAckBit and setByteAck "
	"; "
	": setTIP "
	"vPortB rb@ swap if "
	"kAssertTIP and "
	"else "
	"kTIPByteAckNeg or "
	"then "
	"vPortB rb! "
	"; "
	": ?TREQ	vPortB rb@ kTREQbit and 0= ; "
	": WaitTREQ "
	"begin "
	"?TREQ until "
	"; "
	": WaitVIAInt "
	"begin "
	"vIFR rb@ kSRIReq and until "
	"; "
	": WaitATTN "
	"WaitVIAInt "
	"vSHR rb@ drop "
	"; "
	": get-response	( -- ) "
	"WaitATTN "
	"true setTIP "
	"begin "
	"WaitATTN "
	"?TREQ while "
	"ToggleByteAck "
	"repeat "
	"false setTIP "
	"false setByteAck "
	"WaitATTN "
	"; "
	": start-send	( c -- ) "
	"kSRModeOut vACR rb! "
	"( c ) vSHR rb! "
	"true setTIP "
	"; "
	": cuda-write	{ _adr _len ; _actual _data } "
	"?TREQ if get-response then "
	"_adr c@ start-send "
	"begin "
	"WaitVIAInt "
	"?TREQ while "
	"vSHR rb@ drop "
	"false setTIP "
	"get-response "
	"_adr c@ start-send "
	"repeat "
	"1 -> _actual "
	"_len 1 ?do "
	"_adr i + c@ vSHR rb! "
	"_actual 1+ -> _actual "
	"ToggleByteAck "
	"WaitVIAInt "
	"loop "
	"2 ms "
	"kSRModeIn vACR rb! "
	"vSHR rb@ drop "
	"false setTIP "
	"false setByteAck "
	"_actual "
	"; "
	": cuda-read	( _adr _len -- _actual ) "
	"get-response "
	"nip "
	"; "
	"8 buffer: athens-data	\" \"(012250FFFF)\" athens-data swap move "
	"8 buffer: athens-rsp "
	": write-IIC	( -- ) "
	"athens-data 5 cuda-write drop "
	"athens-rsp 3 cuda-read drop "
	"; "
	": init-ATHENS	( P2Mux N2 D2 -- ) "
	"4 1 do "
	"i athens-data 3 + c! ( val ) athens-data 4 + c! "
	"( athens-data 5 dump cr ) "
	"write-IIC "
	"loop "
	"; "
	": ping-CONTROL	( enable-bit -- ) "
	"5 ms "
	"dup 8 or swap "
	"dup regs >C.TEST rl! 5 ms "
	"swap dup regs >C.TEST rl! 5 ms "
	"swap dup regs >C.TEST rl! 5 ms "
	"swap dup regs >C.TEST rl! 5 ms "
	"2drop "
	"; "
	": reset-CONTROL "
	"h# 433 ping-CONTROL "
	"1 regs >C.GSC-DIVIDE rl! "
	"; "
	": enable-CONTROL "
	"h# 033 ping-CONTROL "
	"; "
	": init-CONTROL	( tbl-ptr -- ) "
	"-1 to bankb? "
	"phys-fb-address dup h# 1000 _I_G do-map "
	"h# 31 regs >C.ENABLE rl! "
	"h# 12345678 phys-fb-address rl! "
	"regs >C.ENABLE rl@ drop "
	"h# 12345678 phys-fb-address rl@ <> "
	"phys-fb-address h# 1000 do-unmap "
	"if "
	"0 to bankb? "
	"phys-fb-address h# 600000 or to phys-fb-address "
	"then "
	"dup @ ( dup .h ) lbsplit init-ATHENS init-RADACAL cell+ "
	"d# 16 0 do "
	"w@++ ( dup .d ) regs >C.VFPEQ i 4 << + ( dup .h cr ) rl! "
	"loop "
	"w@++	regs >C.GSC-DIVIDE rl! "
	"w@++ dup to width	regs >C.ROW-WORDS rl! "
	"w@ to height "
	"h# 31 bankB? not 8 and or "
	"little? 2 and or	regs >C.ENABLE rl! "
	"0		regs >C.GBASE rl! "
	"h# 01e4	regs >C.REFRESH-COUNT rl! "
	"0		regs >C.INT-ENABLE rl! "
	"; "
	": my-open "
	"\" assigned-addresses\" get-my-property "
	"abort\" no REG property\"	( prop-adr prop-len ) "
	"begin "
	"dup 0> while "
	"decode-int h# FF and >r decode-int drop decode-int >r "
	"8 - swap 8 + swap							( prop-adr prop-len ) "
	"r> r> case "
	"h# 14 of "
	"to phys-regs "
	"endof "
	"h# 18 of "
	"h# 00800000 + to phys-fb-address "
	"endof "
	"swap drop "
	"endcase "
	"repeat "
	"2drop "
	"phys-regs 0 my-space h# 02000000 or h# 1000 \" map-in\" $call-parent to regs "
	"reset-CONTROL "
	"mon-sense "
	"get-mode swap to mono-mode? "
	"( mode-dependent-table-addr ) "
	"dup 0= if "
	"abort "
	"then "
	"( mode-dependent-table-addr ) "
	"init-CONTROL "
	"std-16 0 d# 16 set-colors "
	"enable-CONTROL "
	"phys-fb-address 0 my-space h# 02000000 or width height * \" map-in\" $call-parent to fb-address "
	"fb-address width height * 7 fill "
	"default-font set-font "
	"width height over 20 - char-width / over 20 - char-height / fb8-install "
	"width #columns char-width * - 2/ to window-left "
	"height #lines char-height * - 2/ to window-top "
	"fb-address to frame-buffer-adr "
	"width encode-int \" width\" property "
	"height encode-int \" height\" property "
	"width encode-int \" linebytes\" property "
	"8 encode-int \" depth\" property "
	"; "
	": my-close "
	"fb-address height width * \" map-out\" $call-parent "
	"regs h# 1000 \" map-out\" $call-parent "
	"; "
	"EXTERNAL "
	": DIMENSIONS "
	"width height "
	"; "
	": SET-COLORS	( adr index #indices ) "
	"swap RAD-REG-ADDR! "
	"( #indices ) 0 ?do				( adr ) "
	"mono-mode? if "
	"c+ h# 4d * >r				( red adr ) "
	"c+ h# 97 * >r				( red green adr ) "
	"c+ h# 1c * 					( red green blue adr ) "
	"r> + r> + 8 >>				( luminance ) "
	"do-gamma "
	"dup "
	"dup "
	"CLUT! "
	"( adr ) "
	"else "
	"c+ do-gamma swap			( R adr ) "
	"c+ do-gamma swap			( R G adr ) "
	"c+ do-gamma swap  			( R G B adr ) "
	">r swap rot CLUT! r>		( B G R ) "
	"then "
	"loop						( adr ) "
	"drop "
	"; "
	": GET-COLORS	( adr index #indices -- ) "
	"swap ( index ) RAD-REG-ADDR! ( #indices )  0 ?do "
	"CLUT@ anti-gamma >r anti-gamma >r anti-gamma		( R ) "
	"c!+ r> c!+ r> c!+ "
	"loop "
	"drop "
	"; "
	": COLOR!		( r g b index -- ) "
	">r RGB-temp 2+ c! RGB-temp 1+ c! RGB-temp c! "
	"RGB-temp r> 1 set-colors "
	"; "
	": COLOR@		( index -- r g b ) "
	"RGB-temp swap 1 get-colors "
	"RGB-temp c+ swap c+ swap c@ "
	"; "
	": rect-setup	( adr|index x y w h -- w adr|index xy-adr h ) "
	">r >r width * + fb-address + r> -rot r> "
	"; "
	": DRAW-RECTANGLE	( adr x y w h -- ) "
	"rect-setup "
	"( h ) 0 ?do								( w adr xy-adr ) "
	"2dup 4 pick move "
	"2 pick width d+ "
	"loop "
	"3drop "
	"; "
	": FILL-RECTANGLE	( index x y w h -- ) "
	"rect-setup 								( w index xy-adr h ) "
	"( h ) 0 ?do								( w index xy-adr ) "
	"dup 3 pick 3 pick fill "
	"width + "
	"loop "
	"3drop "
	"; "
	": READ-RECTANGLE	( adr x y w h -- ) "
	"rect-setup  >r swap r>					( w xy-adr adr h ) "
	"( h ) 0 ?do "
	"2dup 4 pick move "
	"width 3 pick d+ "
	"loop "
	"3drop "
	"; "
	"['] my-open is-install "
	"['] my-close is-remove "
,
 " device-end",0};
Commit	Line	Data
04fee52e A	1	/*
	2	* Copyright (c) 2000 Apple Computer, Inc. All rights reserved.
	3	*
	4	* @APPLE_LICENSE_HEADER_START@
	5	*
db839b1d	6	* Copyright (c) 1999-2003 Apple Computer, Inc. All Rights Reserved.
04fee52e	7	*
db839b1d A	8	* This file contains Original Code and/or Modifications of Original Code
	9	* as defined in and that are subject to the Apple Public Source License
	10	* Version 2.0 (the 'License'). You may not use this file except in
	11	* compliance with the License. Please obtain a copy of the License at
	12	* http://www.opensource.apple.com/apsl/ and read it before using this
	13	* file.
	14	*
	15	* The Original Code and all software distributed under the License are
	16	* distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER
04fee52e A	17	* EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,
04fee52e A	18	* INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,
db839b1d A	19	* FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.
	20	* Please see the License for the specific language governing rights and
	21	* limitations under the License.
04fee52e A	22	*
	23	* @APPLE_LICENSE_HEADER_END@
	24	*/
	25	/*
	26	* Control2.c - OF replacement driver for Control.
	27	*
	28	* Copyright (c) 1998-2000 Apple Computer, Inc.
	29	*
	30	* DRI: Josh de Cesare
	31	*/
	32
	33	const char *gControl2Source[] = {
	34	"\" /chaos/control\" find-device "
	35	"-1 value bankB? "
	36	"-1 value REGS "
	37	"-1 value FB-ADDRESS "
	38	"-1 value phys-regs "
	39	"-1 value phys-fb-address "
	40	"0 value mono-mode? "
	41	"0 value width "
	42	"0 value height "
	43	"0 value sense-code "
	44	"0 value ext-sense "
	45	"h# F301B000 constant RADACAL "
	46	"h# F301B000 constant RADACAL-base "
	47	"variable RGB-temp "
	48	"struct "
	49	"( 000 ) d# 16 field >C.CUR-LINE "
	50	"( 010 ) d# 16 field >C.VFPEQ "
	51	"( 020 ) d# 16 field >C.VFP "
	52	"( 030 ) d# 16 field >C.VAL "
	53	"( 040 ) d# 16 field >C.VBP "
	54	"( 050 ) d# 16 field >C.VBPEQ "
	55	"( 060 ) d# 16 field >C.VSYNC "
	56	"( 070 ) d# 16 field >C.VHLINE "
	57	"( 080 ) d# 16 field >C.PIPED "
	58	"( 090 ) d# 16 field >C.HPIX "
	59	"( 0A0 ) d# 16 field >C.HFP "
	60	"( 0B0 ) d# 16 field >C.HAL "
	61	"( 0C0 ) d# 16 field >C.HBWAY "
	62	"( 0D0 ) d# 16 field >C.HSP "
	63	"( 0E0 ) d# 16 field >C.HEQ "
	64	"( 0F0 ) d# 16 field >C.HLFLN "
	65	"( 100 ) d# 16 field >C.HSERR "
	66	"( 110 ) d# 16 field >C.CNTTST "
	67	"( 120 ) d# 16 field >C.TEST "
	68	"( 130 ) d# 16 field >C.GBASE "
	69	"( 140 ) d# 16 field >C.ROW-WORDS "
	70	"( 150 ) d# 16 field >C.MON-SENSE "
	71	"( 160 ) d# 16 field >C.ENABLE "
	72	"( 170 ) d# 16 field >C.GSC-DIVIDE "
	73	"( 180 ) d# 16 field >C.REFRESH-COUNT "
	74	"( 190 ) d# 16 field >C.INT-ENABLE "
	75	"( 1A0 ) d# 16 field >C.INT-STATUS "
	76	"drop "
	77	"struct "
	78	"d# 16 field >R.REG-ADDR "
	79	"d# 16 field >R.CRSR-PALETTE "
	80	"d# 16 field >R.REG-DATA "
	81	"d# 16 field >R.COLOR-PALETTE "
	82	"drop "
	83	"create k512x384@60 "
	84	"h# 0E1B6210 L, "
	85	"d# 811 w, d# 810 w, d# 42 w, d# 23 w, d# 4 w, d# 812 w, d# 814 w, d# 48 w, "
86	"d# 318 w, d# 305 w, d# 49 w, d# 15 w, d# 319 w, d# 8 w, d# 160 w, d# 304 w, "
87	"d# 2 w, d# 512 w, d# 384 w, "
88	"create k640x480@67 "
89	"h# 0E1B0210 L, "
90	"d# 1045 w, d# 1042 w, d# 82 w, d# 43 w, d# 4 w, d# 1048 w, d# 1050 w, d# 72 w, "
91	"d# 430 w, d# 393 w, d# 73 w, d# 31 w, d# 431 w, d# 16 w, d# 216 w, d# 400 w, "
92	"d# 2 w, d# 640 w, d# 480 w, "
93	"create k640x870@75 "
94	"h# 172A0310 L, "
95	"d# 1831 w, d# 1828 w, d# 88 w, d# 46 w, d# 4 w, d# 1834 w, d# 1836 w, d# 72 w, "
96	"d# 414 w, d# 393 w, d# 73 w, d# 39 w, d# 415 w, d# 20 w, d# 208 w, d# 376 w, "
97	"d# 2 w, d# 640 w, d# 870 w, "
98	"create k640x480@60VGA "
99	"h# 17250210 L, "
100	"d# 1037 w, d# 1026 w, d# 66 w, d# 34 w, d# 2 w, d# 1048 w, d# 1050 w, d# 64 w, "
101	"d# 398 w, d# 385 w, d# 65 w, d# 47 w, d# 399 w, d# 24 w, d# 200 w, d# 352 w, "
102	"d# 2 w, d# 640 w, d# 480 w, "
103	"create k832x624@75 "
104	"h# 172A0310 L, "
105	"d# 1331 w, d# 1330 w, d# 82 w, d# 43 w, d# 4 w, d# 1332 w, d# 1334 w, d# 136 w, "
106	"d# 574 w, d# 553 w, d# 137 w, d# 31 w, d# 575 w, d# 16 w, d# 288 w, d# 544 w, "
107	"d# 2 w, d# 832 w, d# 624 w, "
108	"create k1024x768@75 "
109	"h# 0B1C0310 L, "
110	"d# 1603 w, d# 1600 w, d# 64 w, d# 34 w, d# 4 w, d# 1606 w, d# 1608 w, d# 128 w, "
111	"d# 662 w, d# 641 w, d# 129 w, d# 47 w, d# 663 w, d# 24 w, d# 332 w, d# 616 w, "
112	"d# 2 w, d# 1024 w, d# 768 w, "
113	"create k1152x870@75 "
114	"h# 133D0310 L, "
115	"d# 1825 w, d# 1822 w, d# 82 w, d# 43 w, d# 4 w, d# 1828 w, d# 1830 w, d# 128 w, "
116	"d# 726 w, d# 705 w, d# 129 w, d# 63 w, d# 727 w, d# 32 w, d# 364 w, d# 664 w, "
117	"d# 2 w, d# 1152 w, d# 870 w, "
118	": SENSE! 5 ms regs >C.MON-SENSE rl! 5 ms ; "
119	": SENSE@ 5 ms regs >C.MON-SENSE rl@ 5 ms ; "
120	": MON-SENSE ( -- ) "
121	"o# 70 sense! "
122	"sense@ 6 >> 7 and dup to sense-code "
123	"dup 6 < if "
124	"b# 1000000 or "
125	"else drop "
126	"o# 30 sense! "
127	"sense@ 2 >> b# 110000 and "
128	"o# 50 sense! "
129	"sense@ dup 4 >> b# 000100 and swap 5 >> b# 001000 and or or "
130	"o# 60 sense! sense@ 7 >> b# 000011 and or "
131	"to ext-sense "
132	"then "
133	"o# 70 sense! "
134	"; "
135	": get-mode ( -- mode-table mono-mode? ) "
136	"sense-code case "
137	"0 of "
138	"false "
139	"k1152x870@75 "
140	"endof "
141	"1 of "
142	"true "
143	"k640x870@75 "
144	"endof "
145	"2 of "
146	"false "
147	"k512x384@60 "
148	"endof "
149	"3 of "
150	"true "
151	"k1152x870@75 "
152	"endof "
153	"5 of "
154	"false "
155	"k640x870@75 "
156	"endof "
157	"6 of "
158	"ext-sense case "
159	"3 of "
160	"false "
161	"k832x624@75 "
162	"endof "
163	"h# 0b of "
164	"false "
165	"k1024x768@75 "
166	"endof "
167	"h# 23 of "
168	"false "
169	"k1152x870@75 "
170	"endof "
171	"drop "
172	"false "
173	"k640x480@67 "
174	"0 endcase "
175	"endof "
176	"7 of "
177	"ext-sense case "
178	"h# 2d of "
179	"false "
180	"k832x624@75 "
181	"endof "
182	"h# 3a of "
183	"false "
184	"k1024x768@75 "
185	"endof "
186	"h# 17 of "
187	"false "
188	"k640x480@60VGA "
189	"endof "
190	"h# 3f of "
191	"false "
192	"0 "
193	"endof "
194	"drop "
195	"false "
196	"k640x480@67 "
197	"0 endcase "
198	"endof "
199	"drop "
200	"false "
201	"k640x480@67 "
202	"0 endcase "
203	"; "
204	"HEADERLESS "
205	"create std-16 "
206	"\" \"(000000 0000AA 00AA00 00AAAA AA0000 AA00AA AA5500 AAAAAA)\" $c, "
207	"\" \"(555555 5555FF 55FF55 55FFFF FF5555 FF55FF FFFF55 FFFFFF)\" $c, "
208	"create std-gamma "
209	"\" \"(00 05 09 0B 0E 10 13 15 17 19 1B 1D 1E 20 22 24)\" $c, "
210	"\" \"(25 27 28 2A 2C 2D 2F 30 31 33 34 36 37 38 3A 3B)\" $c, "
211	"\" \"(3C 3E 3F 40 42 43 44 45 47 48 49 4A 4B 4D 4E 4F)\" $c, "
212	"\" \"(50 51 52 54 55 56 57 58 59 5A 5B 5C 5E 5F 60 61)\" $c, "
213	"\" \"(62 63 64 65 66 67 68 69 6A 6B 6C 6D 6E 6F 70 71)\" $c, "
214	"\" \"(72 73 74 75 76 77 78 79 7A 7B 7C 7D 7E 7F 80 81)\" $c, "
215	"\" \"(81 82 83 84 85 86 87 88 89 8A 8B 8C 8C 8D 8E 8F)\" $c, "
216	"\" \"(90 91 92 93 94 95 95 96 97 98 99 9A 9B 9B 9C 9D)\" $c, "
217	"\" \"(9E 9F A0 A1 A1 A2 A3 A4 A5 A6 A6 A7 A8 A9 AA AB)\" $c, "
218	"\" \"(AB AC AD AE AF B0 B0 B1 B2 B3 B4 B4 B5 B6 B7 B8)\" $c, "
219	"\" \"(B8 B9 BA BB BC BC BD BE BF C0 C0 C1 C2 C3 C3 C4)\" $c, "
220	"\" \"(C5 C6 C7 C7 C8 C9 CA CA CB CC CD CD CE CF D0 D0)\" $c, "
221	"\" \"(D1 D2 D3 D3 D4 D5 D6 D6 D7 D8 D9 D9 DA DB DC DC)\" $c, "
222	"\" \"(DD DE DF DF E0 E1 E1 E2 E3 E4 E4 E5 E6 E7 E7 E8)\" $c, "
223	"\" \"(E9 E9 EA EB EC EC ED EE EE EF F0 F1 F1 F2 F3 F3)\" $c, "
224	"\" \"(F4 F5 F5 F6 F7 F8 F8 F9 FA FA FB FC FC FD FE FF)\" $c, "
225	": c+ ( adr -- adr+1 val ) "
226	"dup 1+ swap c@ "
227	"; "
228	": c!+ ( adr val -- adr+1 ) "
229	"swap dup 1+ -rot c! "
230	"; "
231	": do-gamma "
232	"std-gamma + c@ "
233	"; "
234	": anti-gamma ( val -- orig ) "
235	"h# 100 0 do "
236	"std-gamma i + c@ over >= if "
237	"drop i unloop exit "
238	"then "
239	"loop "
240	"drop h# ff "
241	"; "
242	": W@++ ( addr -- addr word ) "
243	"dup 2+ swap w@ "
244	"; "
245	": CLUT@ ( -- ) "
246	"3 0 do RADACAL-base >R.COLOR-PALETTE rb@ loop 2 ms "
247	"; "
248	": CLUT! ( -- ) "
249	"3 0 do RADACAL-base >R.COLOR-PALETTE rb! loop 2 ms "
250	"; "
251	": RAD-REG-ADDR! "
252	"RADACAL-base >R.REG-ADDR rb! 2 ms "
253	"; "
254	": RAD! ( c a -- ) "
255	"( a ) rad-reg-addr! "
256	"( c ) RADACAL-base >R.REG-DATA rb! 2 ms "
257	"; "
258	": init-RADACAL ( val -- ) "
259	"( val ) h# 20 rad! "
260	"bankb? 1 and h# 21 rad! "
261	"0 h# 10 rad! "
262	"0 h# 11 rad! "
263	"; "
264	"h# F3016000 constant vPortB "
265	"h# F3016400 constant vDDRB "
266	"h# F3017400 constant vSHR "
267	"h# F3017600 constant vACR "
268	"h# F3017800 constant vPCR "
269	"h# F3017A00 constant vIFR "
270	"h# F3017C00 constant vIER "
271	"h# 0C constant kSRModeIn "
272	"h# 1C constant kSRModeOut "
273	"h# 04 constant kSRIReq "
274	"h# 10 constant kByteAckBit "
275	"h# DF constant kAssertTIP "
276	"h# 20 constant kNegateTIP "
277	"h# EF constant kAssertByteAck "
278	"h# 10 constant kNegateByteAck "
279	"h# 30 constant kTIPByteAckNeg "
280	"h# 08 constant kTREQBit "
281	": setByteAck "
282	"vPortB rb@ swap if "
283	"kAssertByteAck and "
284	"else "
285	"kNegateByteAck or "
286	"then "
287	"vPortB rb! "
288	"; "
289	": ToggleByteAck "
290	"vPortB rb@ kByteAckBit and setByteAck "
291	"; "
292	": setTIP "
293	"vPortB rb@ swap if "
294	"kAssertTIP and "
295	"else "
296	"kTIPByteAckNeg or "
297	"then "
298	"vPortB rb! "
299	"; "
300	": ?TREQ vPortB rb@ kTREQbit and 0= ; "
301	": WaitTREQ "
302	"begin "
303	"?TREQ until "
304	"; "
305	": WaitVIAInt "
306	"begin "
307	"vIFR rb@ kSRIReq and until "
308	"; "
309	": WaitATTN "
310	"WaitVIAInt "
311	"vSHR rb@ drop "
312	"; "
313	": get-response ( -- ) "
314	"WaitATTN "
315	"true setTIP "
316	"begin "
317	"WaitATTN "
318	"?TREQ while "
319	"ToggleByteAck "
320	"repeat "
321	"false setTIP "
322	"false setByteAck "
323	"WaitATTN "
324	"; "
325	": start-send ( c -- ) "
326	"kSRModeOut vACR rb! "
327	"( c ) vSHR rb! "
328	"true setTIP "
329	"; "
330	": cuda-write { _adr _len ; _actual _data } "
331	"?TREQ if get-response then "
332	"_adr c@ start-send "
333	"begin "
334	"WaitVIAInt "
335	"?TREQ while "
336	"vSHR rb@ drop "
337	"false setTIP "
338	"get-response "
339	"_adr c@ start-send "
340	"repeat "
341	"1 -> _actual "
342	"_len 1 ?do "
343	"_adr i + c@ vSHR rb! "
344	"_actual 1+ -> _actual "
345	"ToggleByteAck "
346	"WaitVIAInt "
347	"loop "
348	"2 ms "
349	"kSRModeIn vACR rb! "
350	"vSHR rb@ drop "
351	"false setTIP "
352	"false setByteAck "
353	"_actual "
354	"; "
355	": cuda-read ( _adr _len -- _actual ) "
356	"get-response "
357	"nip "
358	"; "
359	"8 buffer: athens-data \" \"(012250FFFF)\" athens-data swap move "
360	"8 buffer: athens-rsp "
361	": write-IIC ( -- ) "
362	"athens-data 5 cuda-write drop "
363	"athens-rsp 3 cuda-read drop "
364	"; "
365	": init-ATHENS ( P2Mux N2 D2 -- ) "
366	"4 1 do "
367	"i athens-data 3 + c! ( val ) athens-data 4 + c! "
368	"( athens-data 5 dump cr ) "
369	"write-IIC "
370	"loop "
371	"; "
372	": ping-CONTROL ( enable-bit -- ) "
373	"5 ms "
374	"dup 8 or swap "
375	"dup regs >C.TEST rl! 5 ms "
376	"swap dup regs >C.TEST rl! 5 ms "
377	"swap dup regs >C.TEST rl! 5 ms "
378	"swap dup regs >C.TEST rl! 5 ms "
379	"2drop "
380	"; "
381	": reset-CONTROL "
382	"h# 433 ping-CONTROL "
383	"1 regs >C.GSC-DIVIDE rl! "
384	"; "
385	": enable-CONTROL "
386	"h# 033 ping-CONTROL "
387	"; "
388	": init-CONTROL ( tbl-ptr -- ) "
389	"-1 to bankb? "
390	"phys-fb-address dup h# 1000 _I_G do-map "
391	"h# 31 regs >C.ENABLE rl! "
392	"h# 12345678 phys-fb-address rl! "
393	"regs >C.ENABLE rl@ drop "
394	"h# 12345678 phys-fb-address rl@ <> "
395	"phys-fb-address h# 1000 do-unmap "
396	"if "
397	"0 to bankb? "
398	"phys-fb-address h# 600000 or to phys-fb-address "
399	"then "
400	"dup @ ( dup .h ) lbsplit init-ATHENS init-RADACAL cell+ "
401	"d# 16 0 do "
402	"w@++ ( dup .d ) regs >C.VFPEQ i 4 << + ( dup .h cr ) rl! "
403	"loop "
404	"w@++ regs >C.GSC-DIVIDE rl! "
405	"w@++ dup to width regs >C.ROW-WORDS rl! "
406	"w@ to height "
407	"h# 31 bankB? not 8 and or "
408	"little? 2 and or regs >C.ENABLE rl! "
409	"0 regs >C.GBASE rl! "
410	"h# 01e4 regs >C.REFRESH-COUNT rl! "
411	"0 regs >C.INT-ENABLE rl! "
412	"; "
413	": my-open "
414	"\" assigned-addresses\" get-my-property "
415	"abort\" no REG property\" ( prop-adr prop-len ) "
416	"begin "
417	"dup 0> while "
418	"decode-int h# FF and >r decode-int drop decode-int >r "
419	"8 - swap 8 + swap ( prop-adr prop-len ) "
420	"r> r> case "
421	"h# 14 of "
422	"to phys-regs "
423	"endof "
424	"h# 18 of "
425	"h# 00800000 + to phys-fb-address "
426	"endof "
427	"swap drop "
428	"endcase "
429	"repeat "
430	"2drop "
431	"phys-regs 0 my-space h# 02000000 or h# 1000 \" map-in\" $call-parent to regs "
432	"reset-CONTROL "
433	"mon-sense "
434	"get-mode swap to mono-mode? "
435	"( mode-dependent-table-addr ) "
436	"dup 0= if "
437	"abort "
438	"then "
439	"( mode-dependent-table-addr ) "
440	"init-CONTROL "
441	"std-16 0 d# 16 set-colors "
442	"enable-CONTROL "
443	"phys-fb-address 0 my-space h# 02000000 or width height * \" map-in\" $call-parent to fb-address "
444	"fb-address width height * 7 fill "
445	"default-font set-font "
446	"width height over 20 - char-width / over 20 - char-height / fb8-install "
447	"width #columns char-width * - 2/ to window-left "
448	"height #lines char-height * - 2/ to window-top "
449	"fb-address to frame-buffer-adr "
450	"width encode-int \" width\" property "
451	"height encode-int \" height\" property "
452	"width encode-int \" linebytes\" property "
453	"8 encode-int \" depth\" property "
454	"; "
455	": my-close "
456	"fb-address height width * \" map-out\" $call-parent "
457	"regs h# 1000 \" map-out\" $call-parent "
458	"; "
459	"EXTERNAL "
460	": DIMENSIONS "
461	"width height "
462	"; "
463	": SET-COLORS ( adr index #indices ) "
464	"swap RAD-REG-ADDR! "
465	"( #indices ) 0 ?do ( adr ) "
466	"mono-mode? if "
467	"c+ h# 4d * >r ( red adr ) "
468	"c+ h# 97 * >r ( red green adr ) "
469	"c+ h# 1c * ( red green blue adr ) "
470	"r> + r> + 8 >> ( luminance ) "
471	"do-gamma "
472	"dup "
473	"dup "
474	"CLUT! "
475	"( adr ) "
476	"else "
477	"c+ do-gamma swap ( R adr ) "
478	"c+ do-gamma swap ( R G adr ) "
479	"c+ do-gamma swap ( R G B adr ) "
480	">r swap rot CLUT! r> ( B G R ) "
481	"then "
482	"loop ( adr ) "
483	"drop "
484	"; "
485	": GET-COLORS ( adr index #indices -- ) "
486	"swap ( index ) RAD-REG-ADDR! ( #indices ) 0 ?do "
487	"CLUT@ anti-gamma >r anti-gamma >r anti-gamma ( R ) "
488	"c!+ r> c!+ r> c!+ "
489	"loop "
490	"drop "
491	"; "
492	": COLOR! ( r g b index -- ) "
493	">r RGB-temp 2+ c! RGB-temp 1+ c! RGB-temp c! "
494	"RGB-temp r> 1 set-colors "
495	"; "
496	": COLOR@ ( index -- r g b ) "
497	"RGB-temp swap 1 get-colors "
498	"RGB-temp c+ swap c+ swap c@ "
499	"; "
500	": rect-setup ( adr\|index x y w h -- w adr\|index xy-adr h ) "
501	">r >r width * + fb-address + r> -rot r> "
502	"; "
503	": DRAW-RECTANGLE ( adr x y w h -- ) "
504	"rect-setup "
505	"( h ) 0 ?do ( w adr xy-adr ) "
506	"2dup 4 pick move "
507	"2 pick width d+ "
508	"loop "
509	"3drop "
510	"; "
511	": FILL-RECTANGLE ( index x y w h -- ) "
512	"rect-setup ( w index xy-adr h ) "
513	"( h ) 0 ?do ( w index xy-adr ) "
514	"dup 3 pick 3 pick fill "
515	"width + "
516	"loop "
517	"3drop "
518	"; "
519	": READ-RECTANGLE ( adr x y w h -- ) "
520	"rect-setup >r swap r> ( w xy-adr adr h ) "
521	"( h ) 0 ?do "
522	"2dup 4 pick move "
523	"width 3 pick d+ "
524	"loop "
525	"3drop "
526	"; "
527	"['] my-open is-install "
528	"['] my-close is-remove "
529	,
530	" device-end",0};