|
( 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 ; |