( This file is part of muFORTH: http://pages.nimblemachines.com/muforth
Copyright 2002-2008 David Frech. All rights reserved, and all wrongs
reversed. (See the file COPYRIGHT for details.)
( draw the colorForth icons/characters)
comment %%
( Note: PROT_READ is 1)
: mmap-dev ( #blocks - a) open-file 1 rot Ki mmap ; %%
z" cf/color.com"
-- z" /home/david/Chuck/COLOR.COM.9sep"
-- z" /home/david/Chuck/colorForth.dist"
-- z" /tmp/cf"
-- 162 mmap-dev /dev/fd0
r/o open-file mmap-file swap nip constant |cf
: block Ki |cf + ;
variable #used ( # of cells in this block)
: tally 1 #used +! ; ( count it)
: ?tally =if tally then ; ( count it only if non-zero)
: c@+ ( a - a+ byte) dup 1+ swap c@ ;
: @+ dup cell+ swap @ ;
: w@+ c@+ ( hi) 8 << swap c@+ ( lo) rot + ;
: dot "8000 and if char # ^ then bl ;
: .16 cr 16 for dup dot dup emit emit 2* next drop ;
: .24 cr 24 for w@+ .16 next ;
: icon ( n - a) 48 * 12 block + ;
-- : icons ( n first) icon swap for .24 next drop ;
comment %%
: raw ; ( from when I could change tty modes)
: cooked ; %%
: = xor 0= ;
: done? tty raw key tty cooked char q = ;
: icons ( first)
dup icon begin .24 over space . 1 u+ done? until drop ;
: _chs for dup emit 1+ next cr ;
: .64 64 _chs ;
: .32 32 _chs ;
: chars 32 .32 .64 .64 .64 drop ;
( terminal ESC sequences)
: <esc <# char m hold ;
: esc> char [ hold ctrl [ hold #> type ;
( colored and attributed text)
comment %%
: color ctrl [ emit ( esc) char [ emit 30 + u. char m emit ;
: _color drop space ; %%
: attrib <esc #s esc> ;
: color ( foregd) 0 attrib 30 + attrib space ;
( : bright 1 attrib ;)
: bright char " emit ; ( bright yellow and green hard to read on white bg)
: black 0 color ;
: red 1 color ;
: green 2 color ;
: yellow 3 color ;
: blue 4 color ;
: magenta 5 color ;
: cyan 6 color ;
: _white 7 color ; ( for white-on-black)
-- : white _white ; ( for character console)
: white black ; ( for xterms and suchlike)
white
( printing source blocks)
variable case
: lc z" rtoeanismcylgfwdvpbhxuq0123456789j-k.z/;:!+@*,?" case ! ;
: uc z" RTOEANISMCYLGFWDVPBHXUQ0123456789J-K.Z/;:!+@*,?" case ! ;
: map case @ + c@ ;
: .4 swap 4 << swap 28 >> 7 and ;
: .5 swap 5 << swap 28 >> 7 and 8 + ;
: .7 swap 7 << swap 26 >> 31 and 16 + ;
: unpack dup dup 0< if 2* dup 0< if .7 ^ then .5 ^ then .4 ;
: 1char unpack map emit ;
: chars begin dup while 1char repeat drop ;
: .word lc chars ;
: .WORD uc chars ;
: .Word uc 1char .word ;
( numbers, with auto-radix)
: .d (.) type ;
: .h bright hex (u.) decimal type ;
: .radix "10 and if .h ^ then .d ;
: .num push @+ tally pop .radix ;
: .short dup push 2/ 2/ 2/ 2/ 2/ pop .radix ;
( kinds of words; "xW" names are from cf source - don't blame me!)
: ign .word ; ( ignored - doesn't change color)
: rW cr red .word ;
: wW yellow .word ; ( "white")
: gW green .word ;
: mW cyan .word ; ( macro)
: text white .word ;
: Text white .Word ;
: TEXT white .WORD ;
: nW yellow .num ;
: gnW green .num ;
: sW yellow .short ;
: gsW green .short ;
: var cr magenta .word @+ tally dup green .d green .h ;
( show value in hex & dec)
: format
dup -16 and swap 15 and jump
ign wW nW rW
gW gnW gsW mW
sW text Text TEXT
var ign ign ign [
( We'd like to do "256 for ... next" but since two kinds of words - full-
length numbers and variables - use an extra cell, it doesn't work. They
read an extra cell each, and we read into the next block. In other words,
instead of doing 256 @+'s we do 256+vars+nums.
We could fix this by going to a more complicated arrangement - essentially
a state machine, where every type returns a next state. This way normal
["single-cell"] words would return the normal "format" state; variables
and nums would return the state that would complete them. Then we could
put the fetching at the top-level and properly do "256 for @+ foo next".
That would be good.)
: .block
0 #used !
block begin @+ ?tally format dup [ 1 Ki 1 - ] and 0= until
drop ;
: header cr cr ." -*- Block " . ." -*-" cr ;
: footer cr cr ." (" #used @ dup (.) type ." /256 : "
100 256 */ (.) type ." % full)" ;
: sh decimal dup header .block white footer ;
: shs ( n) begin dup sh 1+ done? until ;
|