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

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