share/scripts/_example_tools.tcl at main · doomsdayone/openmsx

◆ main openmsx / share / scripts / _example_tools.tcl

11.4 KiB · Tcl · last changed chore(): initial commit 1 month ago source blame history raw

# Return the content of the MSX screen as a string (text-modes only)

set_help_text get_screen \
{Returns the content of the MSX screen as a string (only works for text-modes).
}

set ::is_svi [expr {[machine_info type] eq "SVI"}]
set ::cursor_chr  [expr {$::is_svi ? 191    : 255}]
set ::cursor_addr [expr {$::is_svi ? 0xFD67 : 0xFBCC}]
proc unknown_chr {c} {
	if {$c != $::cursor_chr} { return 32 }
	scan [msxcode2unicode [format %c [peek $::cursor_addr]]] %c u
	return $u
}
proc get_screen {} {
	set mode [get_screen_mode]
	switch -- $mode {
		TEXT40 { set addr    0 ; set width 40 }
		TEXT80 { set addr    0 ; set width 80 }
		1      { set addr 6144 ; set width 32 }
		default { error "Screen mode $mode not supported" }
	}

	# scrape screen and build string
	set screen ""
	for {set y 0} {$y < 24} {incr y} {
		set vram [debug read_block VRAM $addr $width]
		append screen [msxcode2unicode $vram unknown_chr] "\n"
		incr addr $width
	}
	return $screen
}

proc copy_screen_to_clipboard {} {
	set_clipboard_text [get_screen]
}

#***********************************************
#* Basic Reader
#*
#* A special thanks to Vincent van Dam for
#* giving me permission to translate his
#* script into Tcl
#***********************************************

set_help_text listing \
{Interpret the content of the memory as a BASIC program and return the
equivalent output of the BASIC LIST command. (May not be terribly useful, but
it does show the power of openMSX scripts ;-) You can add an optional start
address for the decoding; by default it's what the system variable TXTTAB says.
}

proc listing {{startaddr "default"}} {

	# TODO: reduce duplication, difference seems only in last couple of
	# lines

	set tokens1MSX [list \
		"" "END" "FOR" "NEXT" "DATA" "INPUT" "DIM" "READ" "LET" \
		"GOTO" "RUN" "IF" "RESTORE" "GOSUB" "RETURN" "REM" "STOP" \
		"PRINT" "CLEAR" "LIST" "NEW" "ON" "WAIT" "DEF" "POKE" "CONT" \
		"CSAVE" "CLOAD" "OUT" "LPRINT" "LLIST" "CLS" "WIDTH" "ELSE" \
		"TRON" "TROFF" "SWAP" "ERASE" "ERROR" "RESUME" "DELETE" \
		"AUTO" "RENUM" "DEFSTR" "DEFINT" "DEFSNG" "DEFDBL" "LINE" \
		"OPEN" "FIELD" "GET" "PUT" "CLOSE" "LOAD" "MERGE" "FILES" \
		"LSET" "RSET" "SAVE" "LFILES" "CIRCLE" "COLOR" "DRAW" "PAINT" \
		"BEEP" "PLAY" "PSET" "PRESET" "SOUND" "SCREEN" "VPOKE" \
		"SPRITE" "VDP" "BASE" "CALL" "TIME" "KEY" "MAX" "MOTOR" \
		"BLOAD" "BSAVE" "DSKO$" "SET" "NAME" "KILL" "IPL" "COPY" "CMD" \
		"LOCATE" "TO" "THEN" "TAB(" "STEP" "USR" "FN" "SPC(" "NOT" \
		"ERL" "ERR" "STRING$" "USING" "INSTR" "'" "VARPTR" "CSRLIN" \
		"ATTR$" "DSKI$" "OFF" "INKEY$" "POINT" ">" "=" "<" "+" "-" "*" \
		"/" "^" "AND" "OR" "XOR" "EQV" "IMP" "MOD" "\\" "\n" "" \
		"\0x127"]

	set tokens1SVI [list \
		"" "END" "FOR" "NEXT" "DATA" "INPUT" "DIM" "READ" "LET" \
		"GOTO" "RUN" "IF" "RESTORE" "GOSUB" "RETURN" "REM" "STOP" \
		"PRINT" "CLEAR" "LIST" "NEW" "ON" "WAIT" "DEF" "POKE" "CONT" \
		"CSAVE" "CLOAD" "OUT" "LPRINT" "LLIST" "CLS" "WIDTH" "ELSE" \
		"TRON" "TROFF" "SWAP" "ERASE" "ERROR" "RESUME" "DELETE" \
		"AUTO" "RENUM" "DEFSTR" "DEFINT" "DEFSNG" "DEFDBL" "LINE" \
		"OPEN" "FIELD" "GET" "PUT" "CLOSE" "LOAD" "MERGE" "FILES" \
		"LSET" "RSET" "SAVE" "LFILES" "CIRCLE" "COLOR" "DRAW" "PAINT" \
		"BEEP" "PLAY" "PSET" "PRESET" "SOUND" "SCREEN" "VPOKE" \
		"KEY" "CLICK" "SWITCH" "MAX" "MON" "MOTOR" "BLOAD" "BSAVE" \
		"MDM" "DIAL" "DSKO$" "SET" "NAME" "KILL" "IPL" "COPY" "CMD" \
		"LOCATE" "TO" "THEN" "TAB(" "STEP" "USR" "FN" "SPC(" "NOT" \
		"ERL" "ERR" "STRING$" "USING" "INSTR" "'" "VARPTR" "CSRLIN" \
		"ATTR$" "DSKI$" "OFF" "INKEY$" "POINT" "SPRITE" "TIME" ">" \
		"=" "<" "+" "-" "*" "/" "^" "AND" "OR" "XOR" "EQV" "IMP" \
		"MOD" "\\" "\0x127"]

	set tokens2 [list \
		"" "LEFT$" "RIGHT$" "MID$" "SGN" "INT" "ABS" "SQR" "RND" "SIN" \
		"LOG" "EXP" "COS" "TAN" "ATN" "FRE" "INP" "POS" "LEN" "STR$" \
		"VAL" "ASC" "CHR$" "PEEK" "VPEEK" "SPACE$" "OCT$" "HEX$" \
		"LPOS" "BIN$" "CINT" "CSNG" "CDBL" "FIX" "STICK" "STRIG" "PDL" \
		"PAD" "DSKF" "FPOS" "CVI" "CVS" "CVD" "EOF" "LOC" "LOF" "MKI$" \
		"MKS$" "MKD$" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" \
		"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" \
		"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" \
		"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" ""]

	if {[machine_info type] eq "SVI"} {
		set TXTTAB 0xF54A
		set tokens1 $tokens1SVI
	} else {
		set TXTTAB 0xF676
		set tokens1 $tokens1MSX
	}

	if {$startaddr eq "default"} {
		set startaddr [peek16 $TXTTAB]
	}

	# Loop over all lines
	set listing ""
	for {set addr $startaddr} {[peek16 $addr] != 0} {} {
		append listing [format "0x%x > " $addr]
		incr addr 2
		append listing "[peek16 $addr] "
		incr addr 2
		set inquotes false
		set inrem false
		# Loop over tokens in one line
		while {true} {
			set token [peek $addr]; incr addr
			set t [format "%c" $token]
			if {$token == 0x0} {
				set t ""
				break
			} elseif {$token == 0x22} {
				set inquotes [expr !$inquotes]
			}
			if {!$inquotes && !$inrem} {
				if {0x80 < $token && $token < 0xFF} {
					if {$token == 0x8F} {
						if {[peek $addr] == 0xE6} {
							set t "'"
							incr addr
						} else {
							set t "REM"
						}
						set inrem true
					} else {
						set t [lindex $tokens1 [expr {$token - 0x80}]]
					}
				} elseif {$token == 0xFF} {
					set t [lindex $tokens2 [expr {[peek $addr] - 0x80}]]
					incr addr
				} elseif {$token == 0x3a} {
					if {[peek $addr] == 0xA1 || ([peek $addr] == 0x8F && [peek [expr {$addr + 1}]] == 0xE6)} {
						set t ""
					}
				} elseif {$token == 0x0B} {
					set t [format "&O%o" [peek16 $addr]]
					incr addr 2
				} elseif {$token == 0x0C} {
					set t [format "&H%X" [peek16 $addr]]
					incr addr 2
				} elseif {$token == 0x0D} {
					# line number (stored as address)
					set t [format "%d" [peek16 [expr {[peek16 $addr] + 3}]]]
					incr addr 2
				} elseif {$token == 0x0E} {
					set t [format "%d" [peek16 $addr]]
					incr addr 2
				} elseif {$token == 0x0F} {
					set t [format "%d" [peek $addr]]
					incr addr
				} elseif {$token == 0x1C} {
					set t [format "%d" [peek16 $addr]]
					incr addr 2
				} elseif {$token == 0x1D} {
					set exp [peek $addr]
					incr addr
					set t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					set exp "E[expr {($exp & 0x7F) - 70}]"
					set t [make_msx_single $t$exp]
				} elseif {$token == 0x1F} {
					set exp [peek $addr]
					incr addr
					set t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					append t [format "%02x" [peek $addr]]
					incr addr
					set exp "E[expr {($exp & 0x7F) - 78}]"
					set t [make_msx_double $t$exp]
				} elseif {0x11 <= $token && $token <= 0x1A} {
					set t [expr {$token - 0x11}]
				}
			}
			append listing $t
		}
		append listing "\n"
	}
	return $listing
}

proc make_msx_double {num} {
	if {[string toupper $num] ne $num} {
		error "Invalid BASIC program"
	}
	set n [format "% .14E" $num]
	set ee [string range $n 18 20]
	set e [scan $ee %d]
	if {$e <-2 && $e >-5} {
		set n [format "%.14G" [string range $n 0 16]]E$ee
	} else {
		set n [format "%.14G" $num]
	}
	if {[string range $n 0 1] eq "0."} {\
		set n [string range $n 1 100]
	}
	if {![string match *E* $n]} {
		append n "#"
	}
	return $n
}

proc make_msx_single {num} {
	if {[string toupper $num] ne $num} {
		error "Invalid BASIC program"
	}
	set n [format "% .6E" $num]
	set ee [string range $n 10 12]
	set e [scan $ee %d ]
	if {$e <-2 && $e >-5} {
		set n [format "%.6G" [string range $n 0 8]]E$ee
	} else {
		set n [format "%.6G" $num]
	}
	if {[string range $n 0 1] eq "0."} {
		set n [string range $n 1 100]
	}
	if {$n >32767 && ![string match *.* $n]} {
		append n "!"
	}
	return $n
}

set_help_text get_color_count \
"Gives some statistics on the used colors of the currently visible screen. Does not take into account sprites, screen splits and other trickery.

Options:
    -sort <field>, where <field> is either 'color' (default) or 'amount'
    -reverse, to reverse the sorting order
    -all, to also include colors that have a count of zero
"
proc get_color_count {args} {
	set result ""

	set sortindex 0
	set sortorder "-increasing"
	set showall false

	# parse options
	while {1} {
		switch -- [lindex $args 0] {
		"" break
		"-sort" {
			set sortfield [lindex $args 1]
			if {$sortfield eq "color"} {
				set sortindex 0
			} elseif {$sortfield eq "amount"} {
				set sortindex 1
			} else {
				error "Unsupported sort field: $sortfield"
			}
			set args [lrange $args 2 end]
		}
		"-reverse" {
			set sortorder "-decreasing"
			set args [lrange $args 1 end]
		}
		"-all" {
			set showall true
			set args [lrange $args 1 end]
		}
		"default" {
			error "Invalid option: [lindex $args 0]"
		}
		}
	}

	set mode [get_screen_mode_number]
	switch -- $mode {
		5 {
			set nofbytes_per_line 128
			set nofpixels_per_byte 2
			set page_size [expr {32 * 1024}]
		}
		6 {
			set nofbytes_per_line 128
			set nofpixels_per_byte 4
			set page_size [expr {32 * 1024}]
		}
		7 {
			set nofbytes_per_line 256
			set nofpixels_per_byte 2
			set page_size [expr {64 * 1024}]
		}
		8 {
			set nofbytes_per_line 256
			set nofpixels_per_byte 1
			set page_size [expr {64 * 1024}]
		}
		default {
			error "Screen mode $mode not supported (yet)"
		}
	}
	set page [expr {([debug read "VDP regs" 2] & 96) >> 5}]
	set noflines [expr {([debug read "VDP regs" 9] & 128) ? 212 : 192}]
	set bpp [expr {8 / $nofpixels_per_byte}]
	set nrcolors [expr {1 << $bpp}]
	append result "Counting pixels of screen $mode, page $page with $noflines lines...\n"

	# get bytes into large list
	set offset [expr {$page_size * $page}]
	set nrbytes [expr {$noflines * $nofbytes_per_line}]
	binary scan [debug read_block VRAM $offset $nrbytes] c* myvram

	# analyze pixels
	set pixelstats [dict create]
	for {set p 0} {$p < $nrcolors} {incr p} {
		dict set pixelstats $p 0
	}
	set mask [expr {$nrcolors - 1}]
	foreach byte $myvram {
		for {set pixel 0} {$pixel < $nofpixels_per_byte} {incr pixel} {
			set color [expr {($byte >> ($pixel * $bpp)) & $mask}]
			dict incr pixelstats $color
		}
	}
	# convert to list
	set pixelstatlist [list]
	dict for {key val} $pixelstats {
		if {$showall || ($val != 0)} {
			lappend pixelstatlist [list $key $val]
		}
	}
	set pixelstatlistsorted [lsort -integer $sortorder -index $sortindex $pixelstatlist]
	# print results
	set number 0
	set colorwidth [expr {($mode == 8) ? 3 : 2}]
	set palette ""
	foreach pixelinfo $pixelstatlistsorted {
		incr number
		lassign $pixelinfo color amount
		if {$mode != 8} {
			set palette " ([getcolor $color])"
		}
		append result [format "%${colorwidth}d: color %${colorwidth}d$palette: amount: %6d\n" $number $color $amount]
	}
	return $result
}

variable tron_bp

proc toggle_tron {} {
	variable tron_bp

	if {[osd exists tron]} {
		osd destroy tron
		debug remove_bp $tron_bp
		return "Off"
	}

	set tron_bp [debug set_bp 0xFF43 {} {update_tron}]

	osd create rectangle tron \
		-x 269 -y 220 -h 7 -w 42 -scaled true \
		-borderrgba 0x00000040 -bordersize 0.5
	osd create text tron.text -x 3 -y 1 -size 4 -rgba 0xffffffff
	return "On"
}

proc update_tron {} {
	if {![osd exists tron]} return
	set tron ""
	if {[peek16 0xF41C] != 0xFFFF} {
		set tron "Line: [peek16 0xF41C]"
	}
	osd configure tron.text -text ${tron}
}

`/`	Search
`g` `c`	Code
`g` `h`	History
`g` `b`	Bookmarks
`g` `t`	Trust
`y`	Permalink to this state (files and trees)
`?`	This sheet

1	# Return the content of the MSX screen as a string (text-modes only)
2
3	set_help_text get_screen \
4	{Returns the content of the MSX screen as a string (only works for text-modes).
5	}
6
7	set ::is_svi [expr {[machine_info type] eq "SVI"}]
8	set ::cursor_chr [expr {$::is_svi ? 191 : 255}]
9	set ::cursor_addr [expr {$::is_svi ? 0xFD67 : 0xFBCC}]
10	proc unknown_chr {c} {
11	if {$c != $::cursor_chr} { return 32 }
12	scan [msxcode2unicode [format %c [peek $::cursor_addr]]] %c u
13	return $u
14	}
15	proc get_screen {} {
16	set mode [get_screen_mode]
17	switch -- $mode {
18	TEXT40 { set addr 0 ; set width 40 }
19	TEXT80 { set addr 0 ; set width 80 }
20	1 { set addr 6144 ; set width 32 }
21	default { error "Screen mode $mode not supported" }
22	}
23
24	# scrape screen and build string
25	set screen ""
26	for {set y 0} {$y < 24} {incr y} {
27	set vram [debug read_block VRAM $addr $width]
28	append screen [msxcode2unicode $vram unknown_chr] "\n"
29	incr addr $width
30	}
31	return $screen
32	}
33
34	proc copy_screen_to_clipboard {} {
35	set_clipboard_text [get_screen]
36	}
37
38	#***********************************************
39	#* Basic Reader
40	#*
41	#* A special thanks to Vincent van Dam for
42	#* giving me permission to translate his
43	#* script into Tcl
44	#***********************************************
45
46	set_help_text listing \
47	{Interpret the content of the memory as a BASIC program and return the
48	equivalent output of the BASIC LIST command. (May not be terribly useful, but
49	it does show the power of openMSX scripts ;-) You can add an optional start
50	address for the decoding; by default it's what the system variable TXTTAB says.
51	}
52
53	proc listing {{startaddr "default"}} {
54
55	# TODO: reduce duplication, difference seems only in last couple of
56	# lines
57
58	set tokens1MSX [list \
59	"" "END" "FOR" "NEXT" "DATA" "INPUT" "DIM" "READ" "LET" \
60	"GOTO" "RUN" "IF" "RESTORE" "GOSUB" "RETURN" "REM" "STOP" \
61	"PRINT" "CLEAR" "LIST" "NEW" "ON" "WAIT" "DEF" "POKE" "CONT" \
62	"CSAVE" "CLOAD" "OUT" "LPRINT" "LLIST" "CLS" "WIDTH" "ELSE" \
63	"TRON" "TROFF" "SWAP" "ERASE" "ERROR" "RESUME" "DELETE" \
64	"AUTO" "RENUM" "DEFSTR" "DEFINT" "DEFSNG" "DEFDBL" "LINE" \
65	"OPEN" "FIELD" "GET" "PUT" "CLOSE" "LOAD" "MERGE" "FILES" \
66	"LSET" "RSET" "SAVE" "LFILES" "CIRCLE" "COLOR" "DRAW" "PAINT" \
67	"BEEP" "PLAY" "PSET" "PRESET" "SOUND" "SCREEN" "VPOKE" \
68	"SPRITE" "VDP" "BASE" "CALL" "TIME" "KEY" "MAX" "MOTOR" \
69	"BLOAD" "BSAVE" "DSKO$" "SET" "NAME" "KILL" "IPL" "COPY" "CMD" \
70	"LOCATE" "TO" "THEN" "TAB(" "STEP" "USR" "FN" "SPC(" "NOT" \
71	"ERL" "ERR" "STRING$" "USING" "INSTR" "'" "VARPTR" "CSRLIN" \
72	"ATTR$" "DSKI$" "OFF" "INKEY$" "POINT" ">" "=" "<" "+" "-" "*" \
73	"/" "^" "AND" "OR" "XOR" "EQV" "IMP" "MOD" "\\" "\n" "" \
74	"\0x127"]
75
76	set tokens1SVI [list \
77	"" "END" "FOR" "NEXT" "DATA" "INPUT" "DIM" "READ" "LET" \
78	"GOTO" "RUN" "IF" "RESTORE" "GOSUB" "RETURN" "REM" "STOP" \
79	"PRINT" "CLEAR" "LIST" "NEW" "ON" "WAIT" "DEF" "POKE" "CONT" \
80	"CSAVE" "CLOAD" "OUT" "LPRINT" "LLIST" "CLS" "WIDTH" "ELSE" \
81	"TRON" "TROFF" "SWAP" "ERASE" "ERROR" "RESUME" "DELETE" \
82	"AUTO" "RENUM" "DEFSTR" "DEFINT" "DEFSNG" "DEFDBL" "LINE" \
83	"OPEN" "FIELD" "GET" "PUT" "CLOSE" "LOAD" "MERGE" "FILES" \
84	"LSET" "RSET" "SAVE" "LFILES" "CIRCLE" "COLOR" "DRAW" "PAINT" \
85	"BEEP" "PLAY" "PSET" "PRESET" "SOUND" "SCREEN" "VPOKE" \
86	"KEY" "CLICK" "SWITCH" "MAX" "MON" "MOTOR" "BLOAD" "BSAVE" \
87	"MDM" "DIAL" "DSKO$" "SET" "NAME" "KILL" "IPL" "COPY" "CMD" \
88	"LOCATE" "TO" "THEN" "TAB(" "STEP" "USR" "FN" "SPC(" "NOT" \
89	"ERL" "ERR" "STRING$" "USING" "INSTR" "'" "VARPTR" "CSRLIN" \
90	"ATTR$" "DSKI$" "OFF" "INKEY$" "POINT" "SPRITE" "TIME" ">" \
91	"=" "<" "+" "-" "*" "/" "^" "AND" "OR" "XOR" "EQV" "IMP" \
92	"MOD" "\\" "\0x127"]
93
94	set tokens2 [list \
95	"" "LEFT$" "RIGHT$" "MID$" "SGN" "INT" "ABS" "SQR" "RND" "SIN" \
96	"LOG" "EXP" "COS" "TAN" "ATN" "FRE" "INP" "POS" "LEN" "STR$" \
97	"VAL" "ASC" "CHR$" "PEEK" "VPEEK" "SPACE$" "OCT$" "HEX$" \
98	"LPOS" "BIN$" "CINT" "CSNG" "CDBL" "FIX" "STICK" "STRIG" "PDL" \
99	"PAD" "DSKF" "FPOS" "CVI" "CVS" "CVD" "EOF" "LOC" "LOF" "MKI$" \
100	"MKS$" "MKD$" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" \
101	"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" \
102	"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" \
103	"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" ""]
104
105	if {[machine_info type] eq "SVI"} {
106	set TXTTAB 0xF54A
107	set tokens1 $tokens1SVI
108	} else {
109	set TXTTAB 0xF676
110	set tokens1 $tokens1MSX
111	}
112
113	if {$startaddr eq "default"} {
114	set startaddr [peek16 $TXTTAB]
115	}
116
117	# Loop over all lines
118	set listing ""
119	for {set addr $startaddr} {[peek16 $addr] != 0} {} {
120	append listing [format "0x%x > " $addr]
121	incr addr 2
122	append listing "[peek16 $addr] "
123	incr addr 2
124	set inquotes false
125	set inrem false
126	# Loop over tokens in one line
127	while {true} {
128	set token [peek $addr]; incr addr
129	set t [format "%c" $token]
130	if {$token == 0x0} {
131	set t ""
132	break
133	} elseif {$token == 0x22} {
134	set inquotes [expr !$inquotes]
135	}
136	if {!$inquotes && !$inrem} {
137	if {0x80 < $token && $token < 0xFF} {
138	if {$token == 0x8F} {
139	if {[peek $addr] == 0xE6} {
140	set t "'"
141	incr addr
142	} else {
143	set t "REM"
144	}
145	set inrem true
146	} else {
147	set t [lindex $tokens1 [expr {$token - 0x80}]]
148	}
149	} elseif {$token == 0xFF} {
150	set t [lindex $tokens2 [expr {[peek $addr] - 0x80}]]
151	incr addr
152	} elseif {$token == 0x3a} {
153	if {[peek $addr] == 0xA1 \|\| ([peek $addr] == 0x8F && [peek [expr {$addr + 1}]] == 0xE6)} {
154	set t ""
155	}
156	} elseif {$token == 0x0B} {
157	set t [format "&O%o" [peek16 $addr]]
158	incr addr 2
159	} elseif {$token == 0x0C} {
160	set t [format "&H%X" [peek16 $addr]]
161	incr addr 2
162	} elseif {$token == 0x0D} {
163	# line number (stored as address)
164	set t [format "%d" [peek16 [expr {[peek16 $addr] + 3}]]]
165	incr addr 2
166	} elseif {$token == 0x0E} {
167	set t [format "%d" [peek16 $addr]]
168	incr addr 2
169	} elseif {$token == 0x0F} {
170	set t [format "%d" [peek $addr]]
171	incr addr
172	} elseif {$token == 0x1C} {
173	set t [format "%d" [peek16 $addr]]
174	incr addr 2
175	} elseif {$token == 0x1D} {
176	set exp [peek $addr]
177	incr addr
178	set t [format "%02x" [peek $addr]]
179	incr addr
180	append t [format "%02x" [peek $addr]]
181	incr addr
182	append t [format "%02x" [peek $addr]]
183	incr addr
184	set exp "E[expr {($exp & 0x7F) - 70}]"
185	set t [make_msx_single $t$exp]
186	} elseif {$token == 0x1F} {
187	set exp [peek $addr]
188	incr addr
189	set t [format "%02x" [peek $addr]]
190	incr addr
191	append t [format "%02x" [peek $addr]]
192	incr addr
193	append t [format "%02x" [peek $addr]]
194	incr addr
195	append t [format "%02x" [peek $addr]]
196	incr addr
197	append t [format "%02x" [peek $addr]]
198	incr addr
199	append t [format "%02x" [peek $addr]]
200	incr addr
201	append t [format "%02x" [peek $addr]]
202	incr addr
203	set exp "E[expr {($exp & 0x7F) - 78}]"
204	set t [make_msx_double $t$exp]
205	} elseif {0x11 <= $token && $token <= 0x1A} {
206	set t [expr {$token - 0x11}]
207	}
208	}
209	append listing $t
210	}
211	append listing "\n"
212	}
213	return $listing
214	}
215
216	proc make_msx_double {num} {
217	if {[string toupper $num] ne $num} {
218	error "Invalid BASIC program"
219	}
220	set n [format "% .14E" $num]
221	set ee [string range $n 18 20]
222	set e [scan $ee %d]
223	if {$e <-2 && $e >-5} {
224	set n [format "%.14G" [string range $n 0 16]]E$ee
225	} else {
226	set n [format "%.14G" $num]
227	}
228	if {[string range $n 0 1] eq "0."} {\
229	set n [string range $n 1 100]
230	}
231	if {![string match E $n]} {
232	append n "#"
233	}
234	return $n
235	}
236
237	proc make_msx_single {num} {
238	if {[string toupper $num] ne $num} {
239	error "Invalid BASIC program"
240	}
241	set n [format "% .6E" $num]
242	set ee [string range $n 10 12]
243	set e [scan $ee %d ]
244	if {$e <-2 && $e >-5} {
245	set n [format "%.6G" [string range $n 0 8]]E$ee
246	} else {
247	set n [format "%.6G" $num]
248	}
249	if {[string range $n 0 1] eq "0."} {
250	set n [string range $n 1 100]
251	}
252	if {$n >32767 && ![string match . $n]} {
253	append n "!"
254	}
255	return $n
256	}
257
258	set_help_text get_color_count \
259	"Gives some statistics on the used colors of the currently visible screen. Does not take into account sprites, screen splits and other trickery.
260
261	Options:
262	-sort <field>, where <field> is either 'color' (default) or 'amount'
263	-reverse, to reverse the sorting order
264	-all, to also include colors that have a count of zero
265	"
266	proc get_color_count {args} {
267	set result ""
268
269	set sortindex 0
270	set sortorder "-increasing"
271	set showall false
272
273	# parse options
274	while {1} {
275	switch -- [lindex $args 0] {
276	"" break
277	"-sort" {
278	set sortfield [lindex $args 1]
279	if {$sortfield eq "color"} {
280	set sortindex 0
281	} elseif {$sortfield eq "amount"} {
282	set sortindex 1
283	} else {
284	error "Unsupported sort field: $sortfield"
285	}
286	set args [lrange $args 2 end]
287	}
288	"-reverse" {
289	set sortorder "-decreasing"
290	set args [lrange $args 1 end]
291	}
292	"-all" {
293	set showall true
294	set args [lrange $args 1 end]
295	}
296	"default" {
297	error "Invalid option: [lindex $args 0]"
298	}
299	}
300	}
301
302	set mode [get_screen_mode_number]
303	switch -- $mode {
304	5 {
305	set nofbytes_per_line 128
306	set nofpixels_per_byte 2
307	set page_size [expr {32 * 1024}]
308	}
309	6 {
310	set nofbytes_per_line 128
311	set nofpixels_per_byte 4
312	set page_size [expr {32 * 1024}]
313	}
314	7 {
315	set nofbytes_per_line 256
316	set nofpixels_per_byte 2
317	set page_size [expr {64 * 1024}]
318	}
319	8 {
320	set nofbytes_per_line 256
321	set nofpixels_per_byte 1
322	set page_size [expr {64 * 1024}]
323	}
324	default {
325	error "Screen mode $mode not supported (yet)"
326	}
327	}
328	set page [expr {([debug read "VDP regs" 2] & 96) >> 5}]
329	set noflines [expr {([debug read "VDP regs" 9] & 128) ? 212 : 192}]
330	set bpp [expr {8 / $nofpixels_per_byte}]
331	set nrcolors [expr {1 << $bpp}]
332	append result "Counting pixels of screen $mode, page $page with $noflines lines...\n"
333
334	# get bytes into large list
335	set offset [expr {$page_size * $page}]
336	set nrbytes [expr {$noflines * $nofbytes_per_line}]
337	binary scan [debug read_block VRAM $offset $nrbytes] c* myvram
338
339	# analyze pixels
340	set pixelstats [dict create]
341	for {set p 0} {$p < $nrcolors} {incr p} {
342	dict set pixelstats $p 0
343	}
344	set mask [expr {$nrcolors - 1}]
345	foreach byte $myvram {
346	for {set pixel 0} {$pixel < $nofpixels_per_byte} {incr pixel} {
347	set color [expr {($byte >> ($pixel * $bpp)) & $mask}]
348	dict incr pixelstats $color
349	}
350	}
351	# convert to list
352	set pixelstatlist [list]
353	dict for {key val} $pixelstats {
354	if {$showall \|\| ($val != 0)} {
355	lappend pixelstatlist [list $key $val]
356	}
357	}
358	set pixelstatlistsorted [lsort -integer $sortorder -index $sortindex $pixelstatlist]
359	# print results
360	set number 0
361	set colorwidth [expr {($mode == 8) ? 3 : 2}]
362	set palette ""
363	foreach pixelinfo $pixelstatlistsorted {
364	incr number
365	lassign $pixelinfo color amount
366	if {$mode != 8} {
367	set palette " ([getcolor $color])"
368	}
369	append result [format "%${colorwidth}d: color %${colorwidth}d$palette: amount: %6d\n" $number $color $amount]
370	}
371	return $result
372	}
373
374	variable tron_bp
375
376	proc toggle_tron {} {
377	variable tron_bp
378
379	if {[osd exists tron]} {
380	osd destroy tron
381	debug remove_bp $tron_bp
382	return "Off"
383	}
384
385	set tron_bp [debug set_bp 0xFF43 {} {update_tron}]
386
387	osd create rectangle tron \
388	-x 269 -y 220 -h 7 -w 42 -scaled true \
389	-borderrgba 0x00000040 -bordersize 0.5
390	osd create text tron.text -x 3 -y 1 -size 4 -rgba 0xffffffff
391	return "On"
392	}
393
394	proc update_tron {} {
395	if {![osd exists tron]} return
396	set tron ""
397	if {[peek16 0xF41C] != 0xFFFF} {
398	set tron "Line: [peek16 0xF41C]"
399	}
400	osd configure tron.text -text ${tron}
401	}

Keyboard