====== 4d2006-01 Listings ======


===== xchar =====


<file>

\ 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

</file>

===== hexadocu =====


<file>

\ 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

</file>

===== Regexp compile =====

<file>

\ 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

</file>