;"Copyright (C) 2018 Keziah Wesley

You can redistribute and/or modify this file under the terms of the
GNU Affero General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any
later version.

This file 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
Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public
License along with this file. If not, see
<http://www.gnu.org/licenses/>."

;"CHARTABLE"

;"A CHARTABLE maps reader-chars (Unicode chars optionally prefixed by
  a !) to properties. All special handling of any character is defined
  through CHARTABLE properties."

;"Properties are of two varieties:
  - Lexical classes. Each character is a member of 0 or more classes.
    Class membership alone determines tokenization.
  - Parse functions. Every SPECIAL character has an associated
    function that handles creating any resultant object, including
    PARSEing any children and matching delimiters, in
    recursive-descent fashion."

;"Lexical class combinations used by the standard parser:
  [.] Special non-breaking: (SP)
  [,] Special breaking: (SP BR)
  [A] Unspecial: ()
The behavior of a hypothetical non-special breaker is currently
unspecified: e.g. defining * as (BR) may cause *a* to parse as 2 or 3
unspecial tokens."

;"One category is particularly interesting: unspecial tokens, parsed
  by DEFAULT-HANDLER. The parser for unspecials has to distinguish
  between atoms and the various numeric encodings, but in all cases
  its outward behavior is the same: it consumes a non-SP followed by
  zero or more non-BR, and then pushes some kind of object onto the
  result stack. It's important to note that this scalar-decoding
  mechanism is independent of lexical classes, other than those
  necessary to delimit the sequence--a character may have a different
  meaning as part of an unspecial token."

;"The current implementation is simple, and reasonably efficient under
  typical circumstances (lots of low codepoints in input, not too many
  characters with properties defined). Rules are 'compiled' from an
  editable format into a query-optimized data structure, which is
  transparent to the user except that you'll want to use a BULK-UPDATE
  block if you have many edits to make and want to avoid spending time
  on unneeded intermediate recompiles."

<MOBLIST CHARTABLE>

;"Querying table contents"
BREAKER?!-CHARTABLE
SPECIAL?!-CHARTABLE
DEFAULT-HANDLER!-CHARTABLE

;"Creating / updating tables"
CHARTABLE!-CHARTABLE
SET-SPECIAL!-CHARTABLE
SET-UNSPECIAL!-CHARTABLE
SET-DEFAULT!-CHARTABLE
BULK-UPDATE!-CHARTABLE

;"Confusion can't %%"
%<AND <BLOCK (<MOBLIST ct> <GET CHARTABLE OBLIST> <ROOT>)> <>>

;"Lowest 21-bits: Unicode codepoint"
;"Highest non-sign bit: flag indicating ! prefix"
<NEWTYPE RCHAR FIX>

<NEWTYPE CTABLE VECTOR>
;"SRC: LIST (rchar)"
;"compiled: range table [start . post]"
<SETG is-breaker	1>
;"SRC: LIST (rchar)"
;"compiled: extended range table [start . post . index]"
<SETG is-special	2>
;"SRC: LIST ((rchar handler) !rest)"
;"compiled: vector of functions, ordered by char"
<SETG handlers	        3>
;"Compiled: points to read table data in editable data structures."
;"Simpler to keep the source data than decompile the range tables."
<SETG rt-src		4>
;"Keep track of BULK-UPDATEs in progress."
<SETG batch-depth	5>
<SETG is-dirty		6>
<SETG default		7>

;"--- edit operations (SRC tables) ---"

;"TODO: factor out redundancy between all these list-removers. Macro?"

<DEFINE set-is-breaker (src char val)
 ;"Remove from breakers whether setting or clearing. (Prevent dupes)."
 <PUT .src ,is-breaker
  <MAPF ,LIST <FUNCTION (x)
   <COND (<==? .x .char> <MAPRET>) (ELSE <MAPRET .x>)>>
  <is-breaker .src>>>
 ;"(Re-)add to breakers if setting."
 <COND (.val <PUT .src ,is-breaker (.char !<is-breaker .src>)>)>>

<DEFINE remove-special (src char)
 <PUT .src ,is-special
  <MAPF ,LIST <FUNCTION (x)
   <COND (<==? .x .char> <MAPRET>) (ELSE <MAPRET .x>)>>
   <is-special .src>>>>

<DEFINE remove-handler (src char)
 <PUT .src ,handlers
  <MAPF ,LIST <FUNCTION (x)
   <COND (<==? <1 .x> .char> <MAPRET>) (ELSE <MAPRET .x>)>>
   <handlers .src>>>>

<DEFINE SET-UNSPECIAL (tab char "OPTIONAL" (is-breaker #FALSE ()) "AUX" (src <rt-src .tab>))
 <remove-special .src .char>
 <remove-handler .src .char>
 <set-is-breaker .src .char .is-breaker>
 <maybe-recompile .tab>>

<DEFINE SET-SPECIAL (tab char is-breaker fn "AUX" (src <rt-src .tab>))
 ;"remove any previous specialness properties and update is-breaker"
 <SET-UNSPECIAL .tab .char .is-breaker>
 <PUT .src ,is-special (.char !<is-special .src>)>
 <PUT .src ,handlers ((.char .fn) !<handlers .src>)>
 <maybe-recompile .tab>>

<DEFINE SET-DEFAULT (tab fn) <PUT .tab ,default .fn>>
<DEFINE DEFAULT-HANDLER (tab) <NTH .tab ,default>>

;"--- query operations (compiled tables) ---"

;"Simple linear search implementation."

;"Look up whether the character is a breaker."
<DEFINE BREAKER? (t c "AUX" (breakers <is-breaker .t>) "NAME" act)
 <COND
  (<EMPTY? .breakers> <>)
  (<L? .c <1 .breakers>> <>)
  (<L? .c <2 .breakers>> T)
  (ELSE <SET breakers <REST .breakers 2>> <AGAIN .act>)>>

;"Look up whether the character is special. If it is, return its handler."
<DEFINE SPECIAL? (t c "AUX" (specials <is-special .t>) "NAME" act)
 <COND
  (<EMPTY? .specials> <>)
  (<L? .c <1 .specials>> <>)
  (<L? .c <2 .specials>> <NTH <handlers .t> <- .c <3 .specials>>>)
  (ELSE <SET specials <REST .specials 3>> <AGAIN .act>)>>

;"--- other ---"

;"Create a new empty CHARTABLE."
<DEFINE CHARTABLE () <CHTYPE [![] ![] ![] (() () ()) 0 <> <>] CTABLE>>

<DEFINE end-update (tab)
 <PUT .tab ,batch-depth <- <batch-depth .tab> 1>>
 <is-dirty .tab>
 <maybe-recompile .tab>
 .tab>

;"defer any recompiles to the end of the block"
<DEFINE BULK-UPDATE (tab "ARGS" stmts)
 <PUT .tab ,batch-depth <+ <batch-depth .tab> 1>>
 <UNWIND <MAPF <> ,EVAL .stmts> <end-update .tab>>
 <end-update .tab>>

;"Call after modifying the table. Will recompile now, or later if
  there's a BULK-UPDATE in progress."
<DEFINE maybe-recompile (t)
 <COND (<0? <batch-depth .t>> <recompile .t>)
       (ELSE <PUT .t ,is-dirty T>)>>

<DEFINE sorted (xs) <SORT <> ![!.xs!]>>

<DEFINE count-spans (v "AUX" (pv -2) (n 0) "NAME" act)
 <COND (<EMPTY? .v> <RETURN .n .act>)
       (<L? 1 <- <1 .v> .pv>> <SET n <+ 1 .n>>)>
 <SET pv <1 .v>>
 <SET v <REST .v>>
 <AGAIN .act>>

<SETG std 2>
<SETG ext 3>

;"Given a list of values, return a rangetable: [begin end...]"
<DEFINE make-rt (xs)
 <COND (<EMPTY? .xs> ![])
       (ELSE <make-rt-imp std <sorted .xs>>)>>

;"Given a list of values, return an extended rangetable: [begin end running-excluded...]"
<DEFINE make-ext-rt (xs)
 <COND (<EMPTY? .xs> ![])
       (ELSE <make-rt-imp ext <sorted .xs>>)>>

<DEFINE make-rt-imp (type v "AUX"
 (rt <IUVECTOR <* ,.type <count-spans .v>> 0>)
 (t .rt)
 (gaps <- <1 .v> 1>)
 pv
 "NAME" act)
 ;"Begin a span."
 <PUT .t 1 <SET pv <1 .v>>>
 <SET v <REST .v>>
 ;"Advance v until it points to a value beyond the span."
 <REPEAT ("NAME" span)
  <SET pv <+ 1 .pv>> ;"increment prev in advance"
  <COND (<COND (<EMPTY? .v> <RETURN <> .span>)>)
        (<==? <1 .v> .pv> <SET v <REST .v>>)
	(ELSE <RETURN <> .span>)>>
 ;"End the span. pv is the first value missing. <1 .v> will begin the next span."
 <PUT .t 2 .pv>
 <COND (<==? .type ext> <PUT .t 3 .gaps>)>
 <SET t <REST .t ,.type>>
 <COND (<EMPTY? .v> <RETURN .rt .act>)>
 <SET gaps <+ .gaps <- <1 .v> .pv>>>
 <AGAIN .act>>

;"XXX: Confusion's sort is crashy with predicates."
;<DEFINE sort-handlers (xs) <MAPF ,UVECTOR 2 <SORT <FUNCTION (a b) <G? <1 .a> <1 .b>>> ![!.xs]>>>
;"XXX: Confusion's sort ignores the second sequence."
;<DEFINE sort-handlers (xs "AUX" (keys <MAPF ,UVECTOR 1 .xs>) (vals <MAPF ,UVECTOR 2 .xs>))
 <SORT <> .keys 1 0 .vals>
 .vals>

;"Given a sequence of (key value) pairs, return a vector of the values
 sorted by their keys."
<DEFINE sort-handlers (xs "AUX"
 ;"Zip the inputs."
 (kv <MAPF ,VECTOR ,MAPRET <MAPF ,UVECTOR 1 .xs> <MAPF ,UVECTOR 2 .xs>>))
 ;"Sort zipped inputs."
 <SORT <> .kv 2 0>
 ;"Gather every 2nd value."
 <MAPR ,UVECTOR <FUNCTION (xs)
  <COND (<==? #WORD 0 <ANDB 1 <LENGTH .xs>>> <MAPRET>)
  	(ELSE <MAPRET <1 .xs>>)>> .kv>>

;"Rebuild the table to incorporate any new modifications."
<DEFINE recompile (t "AUX" (src <rt-src .t>))
 <PUT .t ,is-breaker <make-rt <is-breaker .src>>>
 <PUT .t ,is-special <make-ext-rt <is-special .src>>>
 <PUT .t ,handlers <sort-handlers <handlers .src>>>
 <PUT .t ,is-dirty #FALSE ()>>

%<AND <ENDBLOCK> <>>

;<DEFINE assert ('x "AUX" (ex <EVAL .x>)) <COND (<NOT .ex> <ERROR ASSERT-FAILED .x .ex>)>>
;<DEFINE assert-eq ('x 'y "AUX" (ex <EVAL .x>) (ey <EVAL .y>))
 <COND (<N=? .ex .ey> <ERROR ASSERT-FAILED (.x .y) (.ex .ey)>)>>

;<PROG ((t <CHARTABLE!-CHARTABLE>))
 <PRINT (PRE .t)>
 <assert <NOT <SPECIAL?!-CHARTABLE .t *007*>>>
 <assert <NOT <BREAKER?!-CHARTABLE .t *007*>>>
 <SET-SPECIAL!-CHARTABLE .t *007* T <FUNCTION () 5>>
 <SET-SPECIAL!-CHARTABLE .t *006* T <FUNCTION () 3>>
 <PRINT (POST .t)>
 <assert <SPECIAL?!-CHARTABLE .t *007*>>
 <assert <BREAKER?!-CHARTABLE .t *007*>>
 <BULK-UPDATE!-CHARTABLE .t
  <SET-UNSPECIAL!-CHARTABLE .t *007*>>
 <PRINT (POST-UN .t)>
 <assert <NOT <SPECIAL?!-CHARTABLE .t *007*>>>
 <assert <NOT <BREAKER?!-CHARTABLE .t *007*>>>
 <TERPRI>>

;"Confusion needs this."
<>