vd-archiv:listings:4d2006-01-listings
Inhaltsverzeichnis
4d2006-01 Listings
xchar
\ xchar reference implementation: UTF-8 (and ISO-LATIN-1)
\ environmental dependency: characters are stored as bytes
\ environmental dependency: lower case words accepted
base @ hex
80 Value maxascii
: xc-size ( xc -- n )
dup maxascii u< IF drop 1 EXIT THEN \ special case ASCII
$800 2 >r
BEGIN 2dup u>= WHILE 5 lshift r> 1+ >r dup 0= UNTIL THEN
2drop r> ;
: xc@+ ( xcaddr -- xcaddr' u )
count dup maxascii u< IF EXIT THEN \ special case ASCII
7F and 40 >r
BEGIN dup r@ and WHILE r@ xor
6 lshift r> 5 lshift >r >r count
\ dup C0 and 80 <> abort" malformed character"
3F and r> or
REPEAT r> drop ;
: xc!+ ( xc xcaddr -- xcaddr' )
over maxascii u< IF tuck c! char+ EXIT THEN \ special case ASCII
>r 0 swap 3F
BEGIN 2dup u> WHILE
2/ >r dup 3F and 80 or swap 6 rshift r>
REPEAT 7F xor 2* or r>
BEGIN over 80 u< 0= WHILE tuck c! char+ REPEAT nip ;
: xc!+? ( xc xcaddr u -- xcaddr' u' flag )
>r over xc-size r@ over u< IF ( xc xc-addr1 len r: u1 )
\ not enough space
drop nip r> false
ELSE
>r xc!+ r> r> swap - true
THEN ;
\ scan to next/previous character
: xchar+ ( xcaddr -- xcaddr' ) xc@+ drop ;
: xchar- ( xcaddr -- xcaddr' )
BEGIN 1 chars - dup c@ C0 and maxascii <> UNTIL ;
: xstring+ ( xcaddr u -- xcaddr u' )
over + xchar+ over - ;
: xstring- ( xcaddr u -- xcaddr u' )
over + xchar- over - ;
: +xstring ( xc-addr1 u1 -- xc-addr2 u2 )
over dup xchar+ swap - /string ;
: -xstring ( xc-addr1 u1 -- xc-addr2 u2 )
over dup xchar- swap - /string ;
\ utf key and emit
: xkey ( -- xc )
key dup maxascii u< IF EXIT THEN \ special case ASCII
7F and 40 >r
BEGIN dup r@ and WHILE r@ xor
6 lshift r> 5 lshift >r >r key
\ dup C0 and 80 <> abort" malformed character"
3F and r> or
REPEAT r> drop ;
: xemit ( xc -- )
dup maxascii u< IF emit EXIT THEN \ special case ASCII
0 swap 3F
BEGIN 2dup u> WHILE
2/ >r dup 3F and 80 or swap 6 rshift r>
REPEAT 7F xor 2* or
BEGIN dup 80 u< 0= WHILE emit REPEAT drop ;
\ utf size
\ uses wcwidth ( xc -- n )
: wc, ( n low high -- ) 1+ , , , ;
Create wc-table \ derived from wcwidth source code, for UCS32
0 0300 0357 wc,
0 035D 036F wc,
0 0483 0486 wc,
0 0488 0489 wc,
0 0591 05A1 wc,
0 05A3 05B9 wc,
0 05BB 05BD wc,
0 05BF 05BF wc,
0 05C1 05C2 wc,
0 05C4 05C4 wc,
0 0600 0603 wc,
0 0610 0615 wc,
0 064B 0658 wc,
0 0670 0670 wc,
0 06D6 06E4 wc,
0 06E7 06E8 wc,
0 06EA 06ED wc,
0 070F 070F wc,
0 0711 0711 wc,
0 0730 074A wc,
0 07A6 07B0 wc,
0 0901 0902 wc,
0 093C 093C wc,
0 0941 0948 wc,
0 094D 094D wc,
0 0951 0954 wc,
0 0962 0963 wc,
0 0981 0981 wc,
0 09BC 09BC wc,
0 09C1 09C4 wc,
0 09CD 09CD wc,
0 09E2 09E3 wc,
0 0A01 0A02 wc,
0 0A3C 0A3C wc,
0 0A41 0A42 wc,
0 0A47 0A48 wc,
0 0A4B 0A4D wc,
0 0A70 0A71 wc,
0 0A81 0A82 wc,
0 0ABC 0ABC wc,
0 0AC1 0AC5 wc,
0 0AC7 0AC8 wc,
0 0ACD 0ACD wc,
0 0AE2 0AE3 wc,
0 0B01 0B01 wc,
0 0B3C 0B3C wc,
0 0B3F 0B3F wc,
0 0B41 0B43 wc,
0 0B4D 0B4D wc,
0 0B56 0B56 wc,
0 0B82 0B82 wc,
0 0BC0 0BC0 wc,
0 0BCD 0BCD wc,
0 0C3E 0C40 wc,
0 0C46 0C48 wc,
0 0C4A 0C4D wc,
0 0C55 0C56 wc,
0 0CBC 0CBC wc,
0 0CBF 0CBF wc,
0 0CC6 0CC6 wc,
0 0CCC 0CCD wc,
0 0D41 0D43 wc,
0 0D4D 0D4D wc,
0 0DCA 0DCA wc,
0 0DD2 0DD4 wc,
0 0DD6 0DD6 wc,
0 0E31 0E31 wc,
0 0E34 0E3A wc,
0 0E47 0E4E wc,
0 0EB1 0EB1 wc,
0 0EB4 0EB9 wc,
0 0EBB 0EBC wc,
0 0EC8 0ECD wc,
0 0F18 0F19 wc,
0 0F35 0F35 wc,
0 0F37 0F37 wc,
0 0F39 0F39 wc,
0 0F71 0F7E wc,
0 0F80 0F84 wc,
0 0F86 0F87 wc,
0 0F90 0F97 wc,
0 0F99 0FBC wc,
0 0FC6 0FC6 wc,
0 102D 1030 wc,
0 1032 1032 wc,
0 1036 1037 wc,
0 1039 1039 wc,
0 1058 1059 wc,
1 0000 1100 wc,
2 1100 115f wc,
0 1160 11FF wc,
0 1712 1714 wc,
0 1732 1734 wc,
0 1752 1753 wc,
0 1772 1773 wc,
0 17B4 17B5 wc,
0 17B7 17BD wc,
0 17C6 17C6 wc,
0 17C9 17D3 wc,
0 17DD 17DD wc,
0 180B 180D wc,
0 18A9 18A9 wc,
0 1920 1922 wc,
0 1927 1928 wc,
0 1932 1932 wc,
0 1939 193B wc,
0 200B 200F wc,
0 202A 202E wc,
0 2060 2063 wc,
0 206A 206F wc,
0 20D0 20EA wc,
2 2329 232A wc,
0 302A 302F wc,
2 2E80 303E wc,
0 3099 309A wc,
2 3040 A4CF wc,
2 AC00 D7A3 wc,
2 F900 FAFF wc,
0 FB1E FB1E wc,
0 FE00 FE0F wc,
0 FE20 FE23 wc,
2 FE30 FE6F wc,
0 FEFF FEFF wc,
2 FF00 FF60 wc,
2 FFE0 FFE6 wc,
0 FFF9 FFFB wc,
0 1D167 1D169 wc,
0 1D173 1D182 wc,
0 1D185 1D18B wc,
0 1D1AA 1D1AD wc,
2 20000 2FFFD wc,
2 30000 3FFFD wc,
0 E0001 E0001 wc,
0 E0020 E007F wc,
0 E0100 E01EF wc,
here wc-table - Constant #wc-table
\ inefficient table walk:
: wcwidth ( xc -- n )
wc-table #wc-table over + swap ?DO
dup I 2@ within IF I 2 cells + @ UNLOOP EXIT THEN
3 cells +LOOP 1 ;
: x-width ( xcaddr u -- n )
0 rot rot over + swap ?DO
I xc@+ swap >r wcwidth +
r> I - +LOOP ;
: char ( "name" -- xc ) bl word count drop xc@+ nip ;
: [char] ( "name" -- rt:xc ) char postpone Literal ; immediate
\ switching encoding is only recommended at startup
\ only two encodings are supported: UTF-8 and ISO-LATIN-1
80 Constant utf-8
100 Constant iso-latin-1
: set-encoding to maxascii ;
: get-encoding maxascii ;
base !
\ finis
hexadocu
\ hexadocu - sudoku in hex
hex \ Diesmal ist es einfacher, alles im Hexmodus zu betreiben
12 Value spielebenen \ So viele Ebenen brauche ich
Create Aufgabe \ ab hier wird die Aufgabe gespeichert
," E A 56 F8 "
," 65 E 18 F 03A"
," 3 7B 65 D 2 "
," 8 B 34 5 "
," 07 19 2 "
," 9B 2 0F7 8D 6"
," 5 E7 FBD16 C "
," D 6 3 2 0 A 7"
," D C 287 "
," 73BE 9C0A82 6 "
," A 1 7E B9 "
," 29 0 64D A "
," 476 F A0 2"
," B C3A 5480 EF "
," DE9 0C2 4 F5 18"
," F 5 B 19 4D3"
Create Spielfeld \ Jetzt folgt der Speicherbereich fuer das Spiel
10 10 spielebenen * * \ so viele Bytes braucht's schon
allot here value spielfeldende
\ ---------------------------------------------- Verwaltung -------------------------
\ Da es nur ein Spielfeld gibt, wird mit absoluten Adressen gerechnet
: ebene ( n -- adr ) \ gibt die Anfangsadresse der Ebene n zurueck
10 10 * * spielfeld + ;
: zse>adr ( zeile spalte ebene -- adr ) \ gibt die Adresse der gewaehlten Speicherstelle
10 10 * * -rot swap
10 * + + spielfeld + ;
: leer? ( zeile spalte ebene -- flag ) \ ist die gewaehlte Zelle leer?
zse>adr c@ FF = ;
: neu ( -- ) \ Aufgabe ins Spielfeld uebertragen
Aufgabe 10 0
DO count 0
DO count bl = IF FF ELSE dup 1- 1 s>number drop THEN
0 ebene J 10 * i + + c!
LOOP
LOOP drop ;
: vorbesetzen ( -- ) \ Jede Ebene wird mit 'ihrem' Wert gefuellt
10 0 DO
10 0 DO
10 0 DO K J I 1+ zse>adr I swap c!
LOOP
LOOP
LOOP
11 ebene 10 10 * erase ;
: fuelle_zeile ( n zeile ebene -- ) \ eine ganze Zeile mit einem Wert fuellen
ebene swap 10 * + 10 rot fill ;
: fuelle_spalte ( n spalte ebene -- ) \ eine ganze Spalte mit einem Wert fuellen
ebene + 10 0 DO 2dup c! 10 + LOOP 2drop ;
: fuelle_quadrat ( n Index ebene -- ) \ Ein Spielquadrat mit einem Wert fuellen (Index 0-F)
ebene swap 4 /mod 40 * swap 4 * + +
4 0 DO 2dup swap 4 swap fill 10 + LOOP 2drop ;
: loesche_saeule? ( zeile spalte -- ) \ bei besetzter Zelle alle Moeglichkeiten stornieren
2dup 0 leer? \ wenn Spielfeld (noch) leer ist ...
IF 2drop \ tu nichts
ELSE swap 10 * + 10 0 \ ansonsten:
DO FF over I 1+ ebene + c! \ trage in jeder Ebene den Leermarker (FF) ein
LOOP drop
THEN ;
: zaehle_saeule ( zeile spalte -- ) \ Eintraege einer Saeule ( moegliche Werte fuer die
swap 10 * + \ entsprechende Zelle) zaehlen, Ergebnis in Ebene 11
0 pad ! \ speichern
10 0 DO dup I 1+ ebene + c@ FF <>
IF 1 pad +! THEN
LOOP
11 ebene + pad @
swap c! ;
: zaehle_saeulen ( -- ) \ fuer jede Zelle die Anzahl der Moeglichkeiten ermitteln
10 0 DO
10 0 DO I J loesche_saeule? I J zaehle_saeule
LOOP
LOOP ;
Variable gueltige_Zahl \ hier wird der gueltige Wert gespeichert
: notiere_wert ( zeile spalte -- ) \ falls es nur einen Wert gibt, ihn notieren
0 gueltige_Zahl !
swap 10 * +
dup 11 ebene + c@
1 = IF 10 0 DO dup I 1+ ebene + c@ dup
FF <> IF gueltige_Zahl +! ELSE drop THEN
LOOP
dup 11 ebene + 0 swap c!
gueltige_Zahl @ swap 0 ebene + c!
ELSE drop
THEN ;
: schreibe_zahlen ( -- ) \ fuer jede Zelle den 'einen' Wert notieren
10 0 DO
10 0 DO J I notiere_wert
LOOP
LOOP ;
: wert! ( n zeile spalte -- ) \ einen Wert in eine Zelle schreiben
swap 10 * + 0 ebene + c! ;
\ ----------------------------- Erlaubte Zahlen pruefen -------------------------
: markiere_zeile ( zeile -- ) \ benutzte Zahlen als besetzt markieren (Zeilen/Ebene)
dup 10 * spielfeld +
10 0 DO dup I + c@ dup FF <> \ zeile adr n flag
IF FF 3 pick rot 1+ fuelle_zeile
ELSE drop
THEN
LOOP 2drop ;
: markiere_zeilen ( -- ) \ dies fuer alle Zeilen
10 0 DO I markiere_zeile LOOP ;
: markiere_spalte ( spalte -- ) \ benutzte Zahlen als besetzt markieren (Spalten/Ebene)
dup spielfeld +
10 0 DO dup I 10 * + c@ dup FF <>
IF FF 3 pick rot 1+ fuelle_spalte
ELSE drop
THEN
LOOP 2drop ;
: markiere_spalten ( -- ) \ ... fuer alle Spalten
10 0 DO I markiere_spalte LOOP ;
: sz>index ( spalte zeile -- index ) \ errechne aus Koordinaten den Index eines Quadrates
4 / swap 4 / 4 * + ;
: markiere_quadrat ( Index -- ) \ benutzte Zahlen als besetzt markieren (Quadrate/Ebene)
dup
4 /mod 40 * swap 4 * + 0 ebene +
4 0 DO
4 0 DO count dup FF <>
IF 1+ 2 pick swap FF -rot fuelle_quadrat
ELSE drop
THEN
LOOP
10 4 - +
LOOP 2drop ;
: markiere_quadrate ( -- ) \ fuer alle Quadrate
10 0 DO I markiere_quadrat LOOP ;
: markiere_spiel \ alle Felder des Spieles pruefen und markieren
markiere_quadrate
markiere_zeilen
markiere_spalten ;
Variable minimum \ Speicherstelle
: finde_minima ( -- ) \ welche 'leere' Zelle hat die wenigsten Loesungen
10 minimum !
11 ebene
10 10 * 0 DO count dup 0<> IF minimum @ min minimum ! ELSE drop THEN
LOOP drop ;
: loese_1 ( -- flag ) \ alle Zellen, die eindeutig (1) sind, loesen
vorbesetzen
markiere_spiel
zaehle_saeulen
finde_minima
minimum @ 1 = IF schreibe_zahlen true ELSE false THEN ;
\ ----------------------------- Spielstaende merken ----------------------------
Create zug_stack 3 10 10 * * allot \ einen Stack fuer die Spielzuege einrichten
Variable zug# 0 zug# \ sozusagen der Zug-Stackpointer
: merke_zug ( n n n -- ) \ Wertetripel in den Zugstack schreiben
2dup zug# @ 3 * zug_stack + dup >R 2 + c!
R@ 1 + c!
2 pick R> c!
zug# @ 1+ 10 10 * mod zug# ! ; \ 'ueberfluessige' ? Ueberlaufsicherung
: hole_zug ( n -- n n n ) \ Wertetripel vom Zugstack holen
3 * zug_stack + count swap count swap c@ ;
: .zuege ( -- ) \ den Zugstack ausgeben (jeweils letzte Eintraege)
0 50 at ." Wert Zeile Spalte"
zug# @ dup 18 - dup 0 <=
IF drop 0 0 ELSE dup THEN
-rot
?DO
I over - 2+ 50 at
I hole_zug rot 4 .r swap 6 .r 6 .r
LOOP drop ;
: zeige_dateien ( -- ) s" dir zuege*.f " evaluate ; \ der Name sagt's
Variable datei_ID \ Platzhalter
: save_zuege ( -- ) \ Zugstack (human readable) in Datei speichern
s" zuege_" pad place
base @
&10 base !
time&date rot 0 <# [char] _ hold # # #> pad +place
swap 0 <# [char] _ hold # # #> pad +place
0 <# [char] _ hold # # # # #> pad +place
0 <# [char] : hold # # #> pad +place
0 <# [char] : hold # # #> pad +place
0 <# # # #> pad +place
s" .f" pad +place
base !
pad count r/w create-file cr drop
datei_ID !
zug# @ 0 DO
3 0 DO J 3 * I + zug_stack + c@ 0 <# bl hold # # #> datei_ID @ write-file drop
LOOP 0A pad c! pad 1 datei_ID @ write-file drop
LOOP
datei_ID @ close-file drop
." Getan!" ;
: lade_zuege ( c-addr count -- ) \ Zugstack aus Datei fuellen
0 zug# !
r/o open-file
IF datei_ID !
BEGIN pad &10 datei_ID @ read-file nip nip
WHILE zug# @ 3 * zug_stack +
3 0 DO I over + pad I + 2 s>number drop swap c! LOOP drop
zug# @ 1+ zug# !
REPEAT
datei_ID @ close-file
THEN ;
\ ----------------------------- Statistik --------------------------------------
Create Doppelte 16 cells allot \ Speicherbereich fuer benutzte Werte
Variable Fehler Fehler off \ flag
: frei_vorbereiten ( -- ) \ Fehlerabfrage initialisieren
0 pad !
Fehler off
Doppelte 16 FF fill ;
: gueltig_zaehlen ( n -- ) \ sind Eintraege doppelt vorhanden?
dup FF = IF drop 1 pad +!
ELSE dup doppelte + dup
c@ ff <> IF 2drop Fehler on bell ELSE c! THEN
THEN ;
: frei_quadrat ( index -- n ) \ alle Werte eines Spielquadrates miteinander vergleichen
frei_vorbereiten
4 /mod 40 * swap 4 * + 0 ebene +
4 0 DO
4 0 DO count gueltig_zaehlen
LOOP 10 4 - +
LOOP drop
pad @ ;
: frei_zeile ( zeile -- n ) \ alle Werte einer Zeile miteinander vergleichen
frei_vorbereiten
10 * 0 ebene + 10 0 DO count gueltig_zaehlen LOOP drop
pad @ ;
: frei_spalte ( spalte -- n ) \ alle Werte einer Spalte miteinander vergleichen
frei_vorbereiten
0 ebene +
10 0 DO dup c@ gueltig_zaehlen 10 + LOOP drop
pad @ ;
: Moeglichkeiten ( -- d ) \ Moeglichkeiten errechnen (Ueberlauf!!!!!)
1 s>d
10 0 do 10 0 do J I 11 zse>adr c@ dup 0<> IF s>d d* ELSE drop THEN LOOP LOOP ;
: .Moeglichkeiten ( -- ) \ Ausgeben
Moeglichkeiten ." Moegl.: " ud. ;
\ ----------------------------- Anzeige ----------------------------------------
: .wert ( c -- ) \ Spielfeldwert ausgeben, wenn gueltig!
dup FF = IF drop ." " ELSE 2 .r THEN ;
: .trenner ( -- ) ." +-----------+-----------+-----------+-----------+" ;
: .spalten ( -- ) ." 0 1 2 3 4 5 6 7 8 9 A B C D E F" ;
: .zeile ( adr -- adr )
." |"
4 0 DO
3 0 DO count .wert ." " LOOP count .wert ." |"
LOOP ;
: .saeule ( zeile spalte -- ) \ alle Moeglichkeiten einer Zelle anzeigen
1 zse>adr 10 0 DO dup c@ dup FF <>
IF . ELSE drop THEN 10 10 * +
LOOP drop ;
Variable Statistik? Statistik? on \ flag
: .Fehler ( -- ) \ gibt ein X aus, falls ein Fehler bemerkt wurde
Fehler @ IF ." X" ELSE ." " THEN ;
: .ebene ( n -- ) \ Zeigt eine Spielfeldebene formatiert an
page
ebene
cr .spalten
cr .trenner
4 0 DO
4 0 DO cr j 4 * I + . .zeile j 4 * I + 2 .r
Statistik? @ IF ." --> " J 4 * I + frei_zeile . .Fehler THEN
LOOP
cr .trenner
Statistik? @ IF ." " 4 0 DO ." - " J 4 * I + frei_quadrat . .Fehler LOOP THEN
LOOP drop
cr .spalten
Statistik? @ IF cr ." " 10 0 DO I frei_spalte . .Fehler LOOP THEN
.zuege 1A 2 at ;
: .spielfeld \ Zeigt das Spielfeld
0 .ebene ;
\
\ : .wuerfel \ Tasteneingabe bei eingeschaltetem Numpad dort ... schei... 'key'
\ cr 0 .ebene 1
\ BEGIN cr dup ." Ebene: " .
\ key
\ dup 1b = IF 2drop true THEN
\ dup 38 ( FF52 ) = IF drop 1+ 11 min dup .ebene false then
\ dup 32 ( FF54 ) = IF drop 1- 0 max dup .ebene false then
\ UNTIL ;
\ ------------------------- Kuerzel -----------------
: start ( -- )
neu vorbesetzen 0 .ebene ;
: automatik ( -- n ) \ loest alle eindeutigen Zellen
0 >R
Begin r> 1+ >R loese_1 false =
UNTIL r> ;
: au ( -- ) automatik drop \ zeigt das Spielfeld
0 .ebene ." " .moeglichkeiten ;
: z! ( wert zeile spalte -- ) \ einen Wert bei den Koordinaten eintragen
merke_zug
wert! automatik 0 .ebene ." " . ." Zuege!" .moeglichkeiten ;
: wiederhole ( -- ) \ alle Eintraege des Zugstacks nochmal abspielen
neu
zug# @ 0 ?DO I hole_zug wert! automatik drop LOOP
0 .ebene ." " .moeglichkeiten ;
: ? ( zeile spalte -- werte ) \ Moegliche Werte fuer die Koordinaten anzeigen
." :" .saeule ;
: .v 11 .ebene .moeglichkeiten ; \ Anzahl der Moeglichkeiten pro Zelle anzeigen
: z ( -- ) zug# @ 1- 0 max zug# ! wiederhole ; \ einen Zug zurueckgehen
: n ( -- ) zug# @ 1+ 100 min zug# ! wiederhole ; \ einen Zug wiederherstellen (nochmal)
\ ----------------------- Loslegen -----------------
start
2 f 1 z! \ drei
6 8 0 z! \ moegliche
E 5 E z! \ Eingaben
\ 10 0 [do] [i] dup 6 swap z! [loop]
\ 10 0 [do] [i] dup 7 swap z! [loop]
\ finis
Regexp compile
\ Regexp compile
\ Copyright (C) 2005 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2
\ of the License, or (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
\ The idea of the parser is the following:
\ As long as there's a match, continue
\ On a mismatch, LEAVE.
\ Insert appropriate control structures on alternative branches
\ Keep the old pointer (backtracking) on the stack
\ I try to keep the syntax as close to a real regexp system as possible
\ All regexp stuff is compiled into one function as forward branching
\ state machine
\ special control structure
: FORK ( compilation -- orig ; run-time f -- ) \ core
POSTPONE call >mark ; immediate restrict
: JOIN ( orig -- ) postpone THEN ; immediate restrict
\ Charclasses
: +bit ( addr n -- ) + 1 swap c! ;
: -bit ( addr n -- ) + 0 swap c! ;
: @+ ( addr -- n addr' ) dup @ swap cell+ ;
0 Value cur-class
: charclass ( -- ) Create here dup to cur-class $100 dup allot erase ;
: +char ( char -- ) cur-class swap +bit ;
: -char ( char -- ) cur-class swap -bit ;
: ..char ( start end -- ) 1+ swap ?DO I +char LOOP ;
: or! ( n addr -- ) dup @ rot or swap ! ;
: and! ( n addr -- ) dup @ rot and swap ! ;
: +class ( class -- ) $100 0 ?DO @+ swap
cur-class I + or! cell +LOOP drop ;
: -class ( class -- ) $100 0 ?DO @+ swap invert
cur-class I + and! cell +LOOP drop ;
: char? ( addr class -- addr' flag )
>r count r> + c@ ;
\ Charclass tests
: c? ( addr class -- ) ]] char? 0= ?LEAVE [[ ; immediate
: -c? ( addr class -- ) ]] char? ?LEAVE [[ ; immediate
charclass digit '0 '9 ..char
charclass blanks 0 bl ..char
\ bl +char #tab +char #cr +char #lf +char ctrl L +char
charclass letter 'a 'z ..char 'A 'Z ..char
charclass any 0 $FF ..char #lf -char
: \d ( addr -- addr' ) ]] digit c? [[ ; immediate
: \s ( addr -- addr' ) ]] blanks c? [[ ; immediate
: .? ( addr -- addr' ) ]] any c? [[ ; immediate
: -\d ( addr -- addr' ) ]] digit -c? [[ ; immediate
: -\s ( addr -- addr' ) ]] blanks -c? [[ ; immediate
: ` ( -- )
]] count [[ char ]] Literal <> ?LEAVE [[ ; immediate
\ A word for string comparison
: $= ( addr1 addr2 u -- f ) tuck compare ;
: ,=" ( addr u -- ) tuck ]] dup SLiteral $= ?LEAVE Literal + noop [[ ;
: =" ( <string>" -- ) '" parse ,=" ; immediate
\ loop stack
Variable loops $40 3 * cells allot
: 3@ ( addr -- a b c ) dup >r 2 cells + @ r> 2@ ;
: 3! ( a b c addr -- ) dup >r 2! r> 2 cells + ! ;
: loops> ( -- addr ) -3 loops +! loops @+ swap cells + 3@ ;
: >loops ( addr -- ) loops @+ swap cells + 3! 3 loops +! ;
: BEGIN, ( -- ) ]] BEGIN [[ >loops ;
: DONE, ( -- ) loops @ IF loops> ]] DONE [[ THEN ]] noop [[ ;
\ variables
Variable vars &18 cells allot
Variable varstack 9 cells allot
Variable varsmax
: >var ( -- addr ) vars @+ swap 2* cells +
vars @ varstack @+ swap cells + !
1 vars +! 1 varstack +! ;
: var> ( -- addr ) -1 varstack +!
varstack @+ swap cells + @
1+ 2* cells vars + ;
\ start end
0 Value end$
0 Value start$
: !end ( addr u -- addr ) over + to end$ dup to start$ ;
: $? ( addr -- addr flag ) dup end$ u< ;
: ^? ( addr -- addr flag ) dup start$ u> ;
: ?end ( addr -- addr ) ]] dup end$ u> ?LEAVE [[ ; immediate
\ start and end
: \^ ( addr -- addr )
]] ^? ?LEAVE [[ ; immediate
: \$ ( addr -- addr )
]] $? ?LEAVE [[ ; immediate
\ regexp block
\ FORK/JOIN are like AHEAD THEN, but producing a call on AHEAD
\ instead of a jump.
: (( ( addr u -- ) vars off varsmax off loops off
]] FORK AHEAD BUT JOIN !end [[ BEGIN, ; immediate
: )) ( -- addr f )
]] ?end drop true EXIT [[
DONE, ]] drop false EXIT THEN [[ ; immediate
\ greedy loops
\ Idea: scan as many characters as possible, try the rest of the pattern
\ and then back off one pattern at a time
: drops ( n -- ) 1+ cells sp@ + sp! ;
: {** ( addr -- addr addr )
0 ]] Literal >r BEGIN dup [[ BEGIN, ; immediate
' {** Alias {++ ( addr -- addr addr ) immediate
: n*} ( sys n -- ) >r ]] r> 1+ >r $? 0= UNTIL dup [[ DONE, ]] drop [[
r@ IF r@ ]] r@ Literal u< IF r> 1+ drops false EXIT THEN [[ THEN
r@ ]] r> 1+ Literal U+DO FORK BUT [[
]] IF I' I - [[ r@ 1- ]] Literal + drops true UNLOOP EXIT THEN LOOP [[
r@ IF r@ ]] Literal drops [[ THEN
rdrop ]] false EXIT JOIN [[ ; immediate
: **} 0 postpone n*} ; immediate
: ++} 1 postpone n*} ; immediate
\ non-greedy loops
\ Idea: Try to match rest of the regexp, and if that fails, try match
\ first expr and then try again rest of regexp.
: {+ ( addr -- addr addr )
]] BEGIN [[ BEGIN, ; immediate
: {* ( addr -- addr addr )
]] {+ dup FORK BUT IF drop true EXIT THEN [[ ; immediate
: *} ( addr addr' -- addr' )
]] dup end$ u> UNTIL [[
DONE, ]] drop false EXIT JOIN [[ ; immediate
: +} ( addr addr' -- addr' )
]] dup FORK BUT IF drop true EXIT [[
DONE, ]] drop false EXIT THEN *} [[ ; immediate
: // ( -- ) ]] {* 1+ *} [[ ; immediate
\ alternatives
\ idea: try to match one alternative and then the rest of regexp.
\ if that fails, jump back to second alternative
: THENs ( sys -- ) BEGIN dup WHILE ]] THEN [[ REPEAT drop ;
: {{ ( addr -- addr addr ) 0 ]] dup BEGIN [[ vars @ ; immediate
: || ( addr addr -- addr addr ) vars @ varsmax @ max varsmax !
]] nip AHEAD [[ >r >r >r vars !
]] DONE drop dup [[ r> r> r> ]] BEGIN [[ vars @ ; immediate
: }} ( addr addr -- addr addr ) vars @ varsmax @ max vars !
]] nip AHEAD [[ >r >r >r drop
]] DONE drop LEAVE [[ r> r> r> THENs ; immediate
\ match variables
: \( ( addr -- addr ) ]] dup [[
>var ]] ALiteral ! [[ ; immediate
: \) ( addr -- addr ) ]] dup [[
var> ]] ALiteral ! [[ ; immediate
: \0 ( -- addr u ) start$ end$ over - ;
: \: ( i -- )
Create 2* 1+ cells vars + ,
DOES> ( -- addr u ) @ 2@ tuck - ;
: \:s ( n -- ) 0 ?DO I \: LOOP ;
9 \:s \1 \2 \3 \4 \5 \6 \7 \8 \9
\finis
vd-archiv/listings/4d2006-01-listings.txt · Zuletzt geändert: 2017-05-21 18:19 von mka