rebol [
   title: "SKIMP: Simple keyword index management program"
   author: "Sunanda"
   date: 23-apr-2007
   purpose: "Simple, fast way of indexing the text content of many documents"
   version: 0.0.2
   file: %skimp.r
   license: 'mit
   history: [
      [0.0.0 11-aug-2005 "Written"]
      [0.0.1  3-apr-2007 "Modified to use rse-ids.r and make-word-list.r"]
      [0.0.2 23-apr-2007 "Add flush-cache and flush-cache-all"]
   ]
   library: [
      level: 'intermediate
      platform: [all]
      type: [function tool package]
      domain: [files markup database]
      tested-under: [win unix mac]
      support: none
      license: [mit]
      see-also: [%rse-ids.r %make-word-list.r %skimp-tools.r]
      ]
   ]

if not value? 'rse-ids [do %rse-ids.r]  ;; Load rse-ids if not already there

skimp: make object!
[

;; =====================================
;; = Global settings                   =
;; = ---------------                   =
;; = Change the magic values here to   =
;; = alter skimp's over all settings   =
;; = ***                               =
;; = (to change behavior for a         =
;; =  specific index, use              =
;; =  skimp/set-config )               =
;; = ===================================

index-name-prefix: ""      ;; no prefix by default
index-name-suffix: ".sif"  ;; skimp index file

;; ===================================
;; = Public functions                =
;; = ----------------                =
;; = Call any or all of these to     =
;; = build or manage your index      =
;; ===================================

;; ========================================
index-exists?: func [
   index-name [file!]
][
  ;; An index exists:
  ;; * if it is in the cache
  ;;  (whether or not it has been ever
  ;;   written)
  ;; * Or the index header file exists
  ;;   on permanent storage.

   if find index-cache index-name [return true]
   return exists? to-file rejoin [index-name-prefix index-name index-name-suffix]
]



;; ========================================
get-index-information: func [
   index-name [file!]
   /document-list
   /local
   index-info
] [
   if not index-exists? index-name [return none] ;; no such index

   index-info: make object! [
      index-file: index-name
      top-index: copy []
      owner-data: none
      config: none
      word-parameters: none
      make-word-list: none
   ]

   _read-index-file index-name

   index-info/config: first reduce load/all mold cif/config
   index-info/owner-data: first reduce load/all mold cif/owner-data

   ;; Document list
   ;; -------------
   ;; Remembering to remove the "0" place-holders

   if document-list [
      index-info: make index-info [document-list: copy []]
      append index-info/document-list unique sort cif/document-list
      if find index-info/document-list 0 [alter index-info/document-list 0]
   ]

   ;; First letter list
   ;; -----------------
   ;; Create a block with all the
   ;; first letters of words indexed

   if 0 <> length? cif/word-index-block [
      foreach char cif/word-index-block/1 [
         append index-info/top-index to-string char
      ]
      sort index-info/top-index
   ]

   ;; Word parameter details
   ;; ----------------------
      index-info/word-parameters:  first reduce load/all mold cif/word-parameters
      index-info/make-word-list: get in cif 'make-word-list

   return index-info
]



;; ========================================
get-indexed-words: func [
   index-name [file!]
   index-char [char! string!]
   /document-list
   /local
    indexed-words
    current-word
    index-entry
] [
   if not index-exists? index-name [return none] ;; no such index
   if not string? index-char [index-char: to-string index-char]
   if 1 <> length? index-char [return none] ;; only one letter allowed

   indexed-words: copy []

   _read-index-file index-name

   if 0 = length? cif/word-index-block [return none] ;; no words indexed at all

   current-word: copy index-char
   lowercase current-word
   index-entry: find cif/word-index-block/1 current-word
   if not index-entry [return none] ;; no words with that one letter

   index-entry: 1 + index? index-entry

   _haul-in-entry cif/word-index-block index-entry current-word 1
   append indexed-words _extract-words current-word cif/word-index-block/:index-entry 1 document-list
   either document-list [
      sort/skip indexed-words 2
   ] [
      sort indexed-words
   ]
   return indexed-words

]


;; ========================================
get-indexed-words-for-document: func [
   index-name [file!]
   document-name [string! integer!]
   index-char [char! string!]
   /local
    doc-id
    current-word
    index-entry
] [
   if not index-exists? index-name [return none] ;; no such index
   if not string? index-char [index-char: to-string index-char]
   if 1 <> length? index-char [return none] ;; only one letter allowed

   indexed-words: copy []

   _read-index-file index-name

   if 0 = length? cif/word-index-block [return none] ;; no words indexed at all

   current-word: copy index-char
   lowercase current-word
   index-entry: find cif/word-index-block/1 current-word
   if not index-entry [return none] ;; no words with that one letter
   doc-id: _make-document-id/check document-name
   if not doc-id [return none]           ;; document is not in index

   index-entry: 1 + index? index-entry

   _haul-in-entry cif/word-index-block index-entry current-word 1
   append indexed-words _extract-words-for-document current-word cif/word-index-block/:index-entry 1 doc-id
   sort indexed-words

   return indexed-words

]







;; ========================================
get-indexed-document-names: func [
   index-name [file!]
   /local
    doc-list
][
   if not index-exists? index-name [return none] ;; no such index
   _read-index-file index-name

   doc-list: copy cif/document-list

   ;; Integer doc-names: simply
   ;; decompact the list
   ;; -------------------------

   if cif/config/integer-document-names [
      return _unpack-numset  doc-list
      ]

   ;; string doc-names: weed
   ;; out the zeroes first
   ;; ----------------------

   doc-list: unique sort doc-list
   if find doc-list 0 [alter doc-list 0]

   return doc-list

]





;; ========================================
write-cache: func [
   index-name [file!]
   /flush
   /local
   pointer
] [

   ;; Check we've got it first
   ;; ------------------------

   pointer: find index-cache index-name
   if none? pointer [return false] ;; not in memory, so nothing to do
   cif: first next pointer ;; make current item

   _write-index-file index-name

   if flush [
      remove pointer
      remove pointer
      cif: none
   ]
   return true ;; written back okay
]



;; ========================================
write-cache-all: func [
   /flush
] [
   ;; Writes *all* the indexes in the cache
   ;; -------------------------------------

   if flush [
      while [0 <> length? index-cache] [
         write-cache/flush index-cache/1
      ]
      cif: none
      recycle
      return true
   ]


   foreach [index-name index-file] index-cache [
      write-cache index-name
   ]
   return true
]




;; ========================================
flush-cache: func [
   index-name [file!]
   /flush
   /local
   pointer
] [

   ;; Check we've got it first
   ;; ------------------------

   pointer: find index-cache index-name
   if none? pointer [return false] ;; not in memory, so nothing to do

   cif: first next pointer ;; make current item
   remove pointer
   remove pointer
   cif: none

   return true ;; It's been flushed
]



;; ========================================
flush-cache-all: func [
   /flush
][
   ;; Flushes *all* the indexes in the cache
   ;; --------------------------------------
   cif: none
   recycle
   return true
]





;; ========================================
set-config: func [
   index-name [file!]
   con-set [object!]
   /defer
   /local
] [
   ;; Can only use if no words have been indexed
   ;; ------------------------------------------

   _read-index-file index-name

   if any [
      0 <> length? cif/document-list
      0 <> length? cif/word-index-block
   ] [
      make error! "SKIMP/set-config: cannot use on existing index"
      halt
   ]
   ;; =====================
   ;; TODO:  ADD VALIDATION
   ;; =====================
   foreach item next first con-set [
      error? try
      [set in cif/config to-word item get in con-set to-word item]
   ]

   ;; Set to working values, if crazy settings
   ;; ----------------------------------------
   ;; We'll do this until we add some proper validation

   if not integer? cif/config/index-levels [
      cif/config/index-levels: 3
   ]
   cif/config/index-levels: maximum 1 cif/config/index-levels
   if not logic? cif/config/integer-document-names [
        cif/config/integer-document-names: false
        ]
   if not logic? cif/config/one-file [
        cif/config/one-file: false
        ]

   if not defer [
      _write-index-file index-name
      ]

   return make object! third cif/config ;; ensure it's a copy not an updatable original

]



;; ========================================
set-owner-data: func [
   index-name [file!]
   owner-data-obj [object!]
   /defer
   /local
] [

   _read-index-file index-name

   cif/owner-data: first reduce load/all mold owner-data-obj

   if not defer [
      _write-index-file index-name
      ]

   return true

]






;; ======================================
set-word-definition: func [
    index-name [file!]
   /parameters parm-obj [object!]
   /make-word-list mwl [function! none! word!]
   /defer
   /local
    update-needed
  ][
    ;; set-word-defintions
    ;; ===================
    ;; Define or override the default
    ;; expectations of what a "word"
    ;; is.
    ;; Generally, this should be done
    ;; before adding any words to an index --
    ;; otherwise you may add things you cannot
    ;; later easily query.

   update-needed: false

   _read-index-file index-name


   if parameters [
          cif/word-parameters: make cif/word-parameters third parm-obj
          update-needed: true
         ]

   if make-word-list [
      cif/make-word-list: mwl
      either word? mwl [
           cif/make-word-list: get mwl
          ][
          if none? cif/make-word-list [  ;; minimal make-word-list function
             cif/make-word-list: get in skimp '_minimal-make-word-list
             ]
          ]

      update-needed: true
      ]

if all [update-needed not defer] [
   _write-index-file index-name ;; update the index
   ]

   return true
]

;; ======================================

find-word: func [
   index-name [file!]
   target [string!]
   /entry
   /local
   wb
   show-word
   tags
   short-tree
   res
   invert-needed?
] [


   invert-needed?: false
   if target/1 = #"~" [
      invert-needed?: true ;; we're doing a NOT search
      target: skip target 1 ;; slip past the tilde
   ]

   if 0 = length? target [return copy []] ;; find nothing


   _read-index-file index-name
   wb: cif/word-index-block

   set [short-word tags] _make-tags target



   for nn 1 length? tags 1 [
      set [short-tree wb] _find-tree-entry wb tags nn
      if short-tree [break]
      if none? wb [break]
   ]



   if none? wb [;; word not found
      return _map-to-doc-names _invert-list invert-needed? copy []
   ]

   res: select wb short-word
   if not block? res [res: reduce [res]]

   if entry [return _map-to-doc-names _invert-list invert-needed? res]

   if none? res [return _map-to-doc-names _invert-list invert-needed? copy []] ;; word not found

   return _map-to-doc-names _invert-list invert-needed? res
]



;; ==========================================
find-words: func [
   index-name [file!]
   targets [block!]
   /local
   hits
   seq
] [

   ;; -------------------------------
   ;; Finds all the words, assumed to
   ;; be connected by an AND
   ;; --------------------------------
   hits: copy []

   seq: 0
   foreach target targets [
      seq: seq + 1
      hits: _and-results hits
      find-word index-name target
      seq

   ]
   return unique hits

]



;; ==================================
remove-document: func [
   index-name [file!]
   document-name [string!]
   /defer ;; don't write back
   /local
   documents
] [
;; Just a courtesy wrapper for remove documents
;; --------------------------------------------
 documents: copy []
 append documents document-name
 either defer [
    remove-documents/defer index-name documents
   ][
    remove-documents index-name documents
   ]

return true
]



;; ==================================
remove-documents: func [
   index-name [file!]
   document-name-list [block!]
   /defer ;; don't write back
   /local
   temp
   doc-id-list
   starting-word-index
] [

   _read-index-file index-name

   doc-id-list: copy []
   foreach doc-name document-name-list [
        if  _make-document-id/check doc-name [
          append doc-id-list _make-document-id doc-name
          ]
       ]
   doc-id-list: sort unique doc-id-list


   if 0 = length? doc-id-list [return true] ;; we don't have those document-names on file
                                            ;; so there is nothing to remove

   if 0 = length? cif/word-index-block [   ;; no words indexed at all ...
                                    ;; ... not sure this can happen
      foreach doc-name doc-id-list [
         _remove-document-id doc-name
         ]
      return true
   ]


   ;; Capture starting word index
   ;; ---------------------------
   starting-word-index: copy cif/word-index-block/1


   ;; Make sure all top levels are hauled in
   ;; --------------------------------------

   for nn 1 length? cif/word-index-block/1 1 [
      _haul-in-entry cif/word-index-block nn + 1 to-string cif/word-index-block/1/:nn 1
   ]

   _remove-level cif/word-index-block 1 doc-id-list


   foreach doc-name document-name-list [
       _remove-document-id doc-name
      ]


   ;; design oversight here: we don't know
   ;; which of the subfiles we removed words
   ;; from....So set things so they are
   ;; all updated


   foreach letter unique join starting-word-index cif/word-index-block/1 [
      letter: to-string letter
      if not find cif/admin/dirty-tags letter [alter cif/admin/dirty-tags letter]
   ]


   if not defer [_write-index-file index-name]

   return true
]





;; ==================================
remove-index: func [
   index-name [file!]
][

;; Remove index
;; ============
;; Deletes an index entirely.
;; We're using a lazy/slow
;; method:
;; 1. set all index files to empty
;; 2. write the cache -- that will
;;    delete all files except the header
;; 3. delete the header file

if not index-exists? index-name [return true]  ;;  no such index

_read-index-file index-name

if not 0 = length? cif/word-index-block [
   foreach tag cif/word-index-block/1 [
     append cif/admin/dirty-tags to-string tag
     ]
   cif/admin/dirty-tags: unique cif/admin/dirty-tags
   cif/word-index-block/1: copy ""
   write-cache/flush index-name
  ]

delete to-file rejoin [index-name-prefix index-name index-name-suffix]
return true

]


;; ==================================
extract-words-from-string: func [
   index-name [file!]
   words [string! block!]
  /for-search
][
 ;; extract-words-from-string
 ;; =========================
 ;; An interface to the make-word-list
 ;; function saved in the index header
 ;; that changes strings into
 ;; a block of words.
 ;; Useful for testing, especially
 ;; if you write your own function

 if block? words [return words]  ;; nothing to do

_read-index-file index-name

either for-search [
    return do [cif/make-word-list/for-search cif/word-parameters words]
][
    return do [cif/make-word-list cif/word-parameters words]
]
]




;; ==================================
add-words: func [
   index-name [file!]
   document-name [string! integer!]
   words [block! string!]
   /defer ;; no index update at end
   /local
   add-list
   e-id
   new-word? ;; new word indexed for this document
] [

   _read-index-file index-name

   ;; Get the unique list of words
   ;; that we are going to add
   ;; ----------------------------

   either block? words [
      add-list: copy words  ;; block: their words are taken literally
   ][
      add-list: copy []
      append add-list do [cif/make-word-list cif/word-parameters words]
   ]

   add-list: unique add-list

   if find add-list copy "" [alter add-list copy ""] ;; can't index the null string
   if 0 = length? add-list [return true] ;; nothing to do

   ;; Let's go and add them
   ;; ---------------------

   doc-id: _make-document-id document-name

   foreach w add-list [
      _add-a-word w doc-id
   ]


   if not defer [_write-index-file index-name]

   return true
]

;; ==================================
add-bulk-words: func [
   index-name [file!]
   data-block [block!]
   /defer
   /local
   all-words
   inverted-list
   new-word? ;; new word indexed for this document
   temp
   doc-ids
   db
] [

   _read-index-file index-name

   ;; ensure all documents are in word format
   ;; ----------------------------------------
   ;; ie  ["doc-1" "this are my words" ...] becomes
   ;;     ["doc-1" ["these" "are" "my" "words"] ...]


   for nn 1 length? data-block 2 [
      if not block? pick data-block nn + 2 [
          poke data-block nn + 1 do [cif/make-word-list cif/word-parameters pick data-block nn + 1]
          ]
      ]

   ;; Strip out any empty word lists
   ;; ------------------------------

   db: make block! length? data-block
   foreach [file block] data-block [
      if 0 <> length? block [
         append db file
         append/only db block
      ]
   ]


   ;; Ensure each block entry is unique
   ;; --------------------------------
   temp: 0
   all-words: copy []
   for nn 2 length? db 2 [

      poke db nn sort unique db/:nn
      temp: temp + length? db/:nn
      append all-words db/:nn
   ]


   ;; Convert document names to their doc-ids
   ;; ---------------------------------------
   doc-ids: make block! length? db ;; could be half the length
   foreach [document-name words] db [
      append doc-ids _make-document-id document-name
   ]


   all-words: unique sort all-words

   ;; Now invert the list
   ;; -------------------
   inverted-list: make block! (2 * length? all-words)
   foreach w all-words [
      temp: copy []
      append inverted-list form w
      for nn 2 length? db 2 [
         if w = db/:nn/1 [
            insert temp pick doc-ids (nn / 2) ;; document id
            poke db nn next db/:nn
         ]
      ]
      append/only inverted-list temp
   ]


   ;; Sort inverted list so common words are first
   ;; --------------------------------------------

;;   error? try [;; fails on some earlier versions
;;      sort/skip/all/compare inverted-list 2
;;      func [a b] [
;;         if (length? a/2) > length? b/2 [return -1]
;;         if (length? a/2) < length? b/2 [return +1]
;;         if a/1 < b/1 [return 1]
;;         if a/1 > b/1 [return -1]
;;         return 0 ;; how did we get here?
;;      ]
;;  ]




   foreach [word document-list] inverted-list [
      if 0 <> length? word [;; can't index the null word
         _add-a-word word document-list
      ]
   ]



   if not defer [_write-index-file index-name]


   return true
]






;; ===================================
;; = Private stuff                   =
;; = ----------------                =
;; = DON'T call or mess with any of  =
;; = these, unless you are doing     =
;; = your own development            =
;; ===================================


;; ----------
;; data areas
;; ----------

cif: none ;; current index file
current-file-name: none
index-cache: copy []



;; =======================================================
_read-index-file: func [
   index-name [file!]
][

   ;; -------------------------------
   ;; Results in the index file being
   ;; in cif.
   ;; If the index file does not
   ;; exist, a new one is created.
   ;; -------------------------------

   current-file-name: copy index-name

   ;; Read from cache, if possible
   ;; ----------------------------
   cif: select index-cache index-name
   if not none? cif [return true]

   ;; Read from file, if possible
   ;; ---------------------------
   if not error? try [
       cif: first reduce load/all decompress
             read/binary to-file rejoin [index-name-prefix index-name index-name-suffix]
       ][
      insert index-cache cif
      insert index-cache index-name
      return true
   ]

   ;; Create a new one
   ;; ----------------
   ;; Note we don't write the empty file --
   ;; that's done after the first update
   ;; operation, or when a user use a
   ;; write-cache[-all]/flush operation.


   cif: make object! [
      owner-data: make object! []
      admin: make object! [
         last-updated: now/precise
         dirty-tags: copy [] ;; for multiple files: parts that have changed
      ]
      config: make object! [
         index-levels: 3 ;; number of higher-level index layers
         ;; (there will always be one bottom-level index layer)
         integer-document-names: false  ;; ie they are strings
         one-file: false ;; ie is multiple files
      ]

      word-parameters: make object! [
      alpha: charset [#"a" - #"z" #"A" - #"Z"]
      digit: charset [#"0" - #"9"]
      initial-letter: alpha
      letter: union alpha union digit charset ["~"]
      number: union digit charset [".,"]
      number-prefix: charset ["+-£$¢"]
      number-postfix: charset ["+-"]
      word-length: 1x40
      not-prefix: "~"
      stop-list: []
      ignore-tags: false
      index-pairs: true
      final-letter: charset ["!" "?"]
      hyphen: charset ["-_"]
    ]
      make-word-list: get-make-word-list


      document-list: copy []      ;; document-ids

      word-index-block: copy []          ;; indexed words / highest level index
   ]

   insert index-cache cif
   insert index-cache index-name
   return true

] ;; func





;; =======================================================
_write-index-file: func [
   index-name [file!]
   /local
    pointer
    temp-cif
    nn
    file-name
][
   cif: select index-cache index-name
   if none? cif [return false] ;; file is not current, so nothing to write

   cif/admin/last-updated: now/precise

   ;; add file if not in cache
   ;; ------------------------
   pointer: find index-cache index-name
   if none? pointer [
      insert index-cache cif
      insert index-cache index-name
      return true
   ]

   ;; Write it -- as a single file
   ;; ----------------------------

   if cif/config/one-file [
      cif/admin/dirty-tags: copy []
      write/binary to-file rejoin [index-name-prefix index-name index-name-suffix]
                   compress mold cif
      return true
   ]

   ;; Write it -- as a set of files
   ;; -----------------------------

   ;;    Empty file?
   ;;    -----------

   if 0 = length? cif/word-index-block [
      write/binary to-file rejoin [index-name-prefix index-name index-name-suffix]
                   compress mold cif
      return true
   ]

   ;;       Build a CIF that has everything except the
   ;;       word-index-block (we don't do a straight object
   ;;       clone on account of the potential size of
   ;;       the thing)

   temp-cif: make object! []
   foreach entry next first cif [
      if entry <> 'word-index-block [
         temp-cif: make temp-cif reduce [to-set-word entry none]
         set in temp-cif entry get in cif entry
      ]
      temp-cif: make temp-cif [word-index-block: none]
   ]
   temp-cif/word-index-block: copy []

   append temp-cif/word-index-block cif/word-index-block/1 ;; node index
   for nn 1 length? cif/word-index-block/1 1 [
      append temp-cif/word-index-block none] ;; entries
   if _has-leaf-node cif/word-index-block [
      append/only temp-cif/word-index-block last cif-word-index-block/1] ;; node, if there is one (shouldn't be at this level)



   ;; Write first-character files
   ;; ---------------------------

   foreach tag cif/admin/dirty-tags [
      file-name: to-file rejoin [index-name-prefix index-name "-" to-integer tag/1 index-name-suffix]
      either nn: find cif/word-index-block/1 tag [
         nn: 1 + index? nn
         write/binary file-name compress mold cif/word-index-block/:nn
      ] [
         error? try [delete file-name]
      ]
   ]

   temp-cif/admin/dirty-tags: copy []
   cif/admin/dirty-tags: copy []

   write/binary to-file rejoin [index-name-prefix index-name index-name-suffix]
                compress mold temp-cif
   return true

] ;; func



;; =================================================
_make-document-id: func [
   document-name [string! integer!]
   /check
   /local
   doc-id
   find-res
] [
   ;; ---------------------------
   ;; Returns the position of the
   ;; document name in the cif
   ;; ----------------------------

   if cif/config/integer-document-names  [
      ;; This is simple: we use the user's value directly
      ;; ------------------------------------------------
      ;; Though it must be a positive integer, or
      ;; things later will fail very badly

      if any [
         not integer? document-name
         document-name < 1
         ][
         make error! rejoin ["SKIMP: id must be a positive integer..." document-name]
         halt
         ]

      find-res: _find-packed cif/document-list document-name
      if all [check find-res] [return true] ;; it exists already
      if find-res [return document-name] ;; already exists
      if check [return false] ;; does not exist & is just a check


      ;; create a new entry
      ;; ------------------
      doc-id: document-name
      _insert-packed cif/document-list document-name
      return doc-id
   ]


   ;; Need (perhaps) to make a new one
   ;; --------------------------------

   doc-id: find cif/document-list form document-name
   if not none? doc-id [
      return index? doc-id ;; simple: it exists already
   ]


   ;; Just a check on existence?
   ;; --------------------------

   if check [return none] ;; not an existing document

   ;; document doesn't exist ....
   ;; --------------------------

   ;; reuse an empty slot
   ;; ------------------
   if doc-id: find cif/document-list 0 [
      doc-id/1: form document-name
      return index? doc-id
   ]



   ;; Let's make a new one
   ;; --------------------

   append cif/document-list form document-name ;; document-name
   return length? cif/document-list

]



;; =================================================
_remove-document-id: func [document-name [string! integer!]
   /local
   pointer
] [
   ;; ---------------------------
   ;; Deletes an existing
   ;; document name in the cif
   ;; ----------------------------


   ;; Deal with external-doc-id
   ;; ----------------------

   if cif/config/integer-document-names  [
      if find cif/document-list document-name [
         alter cif/document-list document-name
      ]
      return true
   ]

   ;; Deal with internal-doc-id
   ;; ----------------------

   pointer: find cif/document-list form document-name

   if none? pointer [;; doesn't exist already (shouldn't happen)
      return true
   ]

   pointer/1: 0 ;; doesn't exist any more

   ;; trim trailing zeroes
   ;; --------------------
   ;; trailing zeroes just waste space
   ;; on the document list while giving
   ;; us nothing of any use.

   while [
      all [0 <> length? cif/document-list
         0 = last cif/document-list
      ]
   ] [
      remove back tail cif/document-list
   ]
   return true
]




;; ==============================================
_make-word-block: func [word [string!]
   /local wb
   initial
   initial-offset
   wl-entry
   tags
   short-word
   short-tree
] [

   wb: cif/word-index-block
   set [short-word tags] _make-tags word

   for nn 1 length? tags 1 [
      set [short-tree wb] _make-tree-entry wb tags nn

      if short-tree [break]
      if none? tags/:nn [break]
   ]

   return reduce [short-word tags wb]

]


;; ==========================================
_make-tags: func [word [string!]
   /local
   tags
   tag
   shortened-word
] [
   ;; --------------------------------
   ;; The config/index-levels define a tree
   ;; structure. Means we don't have to
   ;; store those letters as they are
   ;; can be recovered.
   ;; eg if the config/index-levels is 3:
   ;; It means take the first letter,
   ;; three times.  So "AMEND" is
   ;; stored in a tree three deep,
   ;; and we only need to store the
   ;; "ND"
   ;; A --> M --> E  ["ND" [1x34]]

   tags: copy []
   shortened-word: copy word

   for nn 1 cif/config/index-levels 1 [
      tag: none
      error? try [tag: first shortened-word]

      shortened-word: copy next shortened-word
      if not none? tag [
         tag: to-string tag
      ]
      append tags tag
   ]

   return reduce [shortened-word tags]

]

;; ==========================================

_has-leaf-node: func [wb [block!]
] [
   if 0 = length? wb [return false]
   return (2 + length? wb/1) = length? wb
]


;; ==========================================
_find-tree-entry: func [
   wb [block!]
   tags [block!]
   nn [integer!]
   /local
   ti
   target
] [

   if 0 = length? wb [return reduce [true none]]

   ti: find wb/1 tags/:nn
   if not none? ti [
      _haul-in-entry wb (1 + index? ti) tags/1 nn
      return reduce [false first at wb (1 + index? ti)] ;; return existing entry
   ]

   if none? tags/:nn [
      if not _has-leaf-node wb [
         return reduce [true none]
      ]

      return reduce [true first at wb length? wb] ;; return existing leaf entry
   ]
   return reduce [true none]
]



;; ==========================================

_haul-in-entry: func [
   wb [block!]
   offset [integer!]
   tag [string!]
   level [integer!]
   /local
   index-segment
] [

   ;;     ------------------------------
   ;;     If the top level of an index
   ;;     is not in memory, haul it in
   ;;     ----------------------------


   if any [level <> 1 ;; only haul top levels
      'none <> wb/:offset ;; and only of none
   ] [
      return true ;; nothing to do
   ]

   index-segment: first reduce
           load/all decompress
               read/binary to-file rejoin [index-name-prefix current-file-name "-" to-integer tag/1 index-name-suffix]



   poke wb offset index-segment
   return true
]

;; ==========================================
_make-tree-entry: func [
   wb [block!]
   tags [block!]
   nn [integer!]
   /local
   ti
] [

   if 0 = length? wb [insert wb copy ""] ;; null level index

   ti: find wb/1 tags/:nn
   if not none? ti [
      _haul-in-entry wb (1 + index? ti) tags/1 nn
      return reduce [false first at wb (1 + index? ti)] ;; return existing entry
   ]

   if none? tags/:nn [
      if not _has-leaf-node wb
      [
         append/only wb copy []
      ]

      return reduce [true first at wb length? wb] ;; return existing leaf entry
   ]

   ;; New level tag
   ;; -------------

   append wb/1 tags/:nn
   insert/only at wb 1 + length? wb/1 copy []
   return reduce [false first at wb 1 + length? wb/1]

]


;; ==============================================
_add-a-word: func [
   word [string!]
   doc-id [integer! block!]
   /local
   w-block ;; word block
   w-entry ;; word entry
   short-word
   temp
   unpacked-doc-ids
   res
   tags

] [
   set [short-word tags w-block] _make-word-block lowercase word

   ;; We got the word block, ie w-block
   ;; is positioned at something like:
   ;; ["mile" [1 7 5] "mite" [668 433] "mitten" 55  ]


   ;; set the index entry as dirty, so it will be saved later
   ;; -------------------------------------------------------
   if not find cif/admin/dirty-tags tags/1 [alter cif/admin/dirty-tags tags/1]


   ;; Now we find the entry for the word we want
   ;; ------------------------------------------
   word-entry: find/skip w-block short-word 2
   if none? word-entry [
      ;; The entry we want does not exist
      ;; --------------------------------
      ;; We are either adding a single integer
      ;; for a new word, or a block of
      ;; integers:
      ;; "snickers" 45
      ;; "snickers" [30 12 49 26]

      append w-block short-word
      temp: copy []
      foreach e either block? doc-id [doc-id] [reduce [doc-id]] [_insert-packed temp e]
      append/only w-block temp
      return true ;; we've added a new word

   ]


   ;; We are now pointing at an existing word
   ;; entry, eg:
   ;;
   ;; ["snickers" [1 3x6 8x19]]

   temp: copy []
   foreach e either block? doc-id [doc-id] [reduce [doc-id]] [_insert-packed word-entry/2 e]
   return true ;; we've added a new word


]



;; ==========================================
_map-to-doc-names: func [
   doc-ids [block! integer! pair!]
   /local
   ent-block
] [
   if not block? doc-ids
   [doc-ids: reduce [doc-ids]]


   doc-ids: _unpack-numset doc-ids

   if cif/config/integer-document-names  [return doc-ids]

   ent-block: make block! length? doc-ids

   foreach e doc-ids [
      insert ent-block pick cif/document-list e
   ]

   return ent-block
]




;;    =======================================
_unpack-numset: func [
   doc-id-block [block!]
] [
   return rse-ids/decompact doc-id-block
]




;;  ==================================
_pack-numset: func [doc-id-block [block!]
] [
   return rse-ids/compact doc-id-block
]



;; ===============================================
_find-packed: func [
   blk [block!]
   target [integer!]
] [
   return rse-ids/find-compact blk target
]


;; ===================================================
_insert-packed: func [
   blk [block!]
   new-entry [integer!]
] [

   return rse-ids/insert-compact blk new-entry

]



;; ==================================
_remove-packed: func [
   entry [block!]
   doc-id [integer!]
   /local
   new-wb
] [
   rse-ids/remove-compact entry doc-id
   return entry
]


;; ===========================================

get-make-word-list: func [
  /local
][
    ;; Supply a minimal dummy function if we
    ;; have no access to make-word-list.r function
if not exists? %make-word-list.r [
   return get in skimp '_minimal-make-word-list
   ]

 do %make-word-list.r
 return :make-word-list
]


;; ===========================================

_minimal-make-word-list: func [
   parms        ;; could be any type -- we don't check
   string [string!]
  /for-search
][
;; Minimal function needed to parse a
;; string into a set of words
   return unique sort parse/all trim/lines copy string " "
]



;; ========================================
_extract-words: func [
   current-word [string!]
   wb [block!]
   level [integer!]
   document-list [logic! none!]
   /local
   word-list
   doc-list
][
  ;; Extract words
  ;; =============
  ;; Returns all the words in the index
  ;; that begin with the first letter
  ;; of the supplied current-word
  ;; Optionally (with document-list
  ;; parameter) also returns
  ;; the document names that
  ;; contain each word.

   word-list: copy []
   if document-list [doc-list: copy []]

   ;; Handle lowest-level index
   ;; -------------------------
   if level = cif/config/index-levels [
      foreach [word index] wb [
         append word-list join current-word word
         if document-list [append/only word-list sort _map-to-doc-names _unpack-numset index]
      ]
      return word-list
   ]


   ;; Handle higher-level indexes
   ;; ---------------------------

   for nn 1 length? wb/1 1 [
      append word-list
          _extract-words
           join current-word wb/1/:nn
           pick wb nn + 1
           level + 1
           document-list
   ]
   if _has-leaf-node wb [
      append word-list current-word
      if document-list [append/only word-list sort _map-to-doc-names _unpack-numset last last wb]
   ]
   return word-list
]


;; ========================================
_extract-words-for-document: func [
   current-word [string!]
   wb [block!]
   level [integer!]
   doc-id [integer!]
   /local
   word-list
][
  ;; Extract words-for-document
  ;; ==========================
  ;; Returns all the words in the index
  ;; that begin with the first letter
  ;; of the supplied current-word that
  ;; are indexed for the given doc-id

   word-list: copy []

   ;; Handle lowest-level index
   ;; -------------------------
   if level = cif/config/index-levels [
      foreach [word index] wb [
         if rse-ids/find-compact index doc-id [append word-list join current-word word]
      ]
      return word-list
   ]


   ;; Handle higher-level indexes
   ;; ---------------------------

   for nn 1 length? wb/1 1 [
      append word-list
          _extract-words-for-document
           join current-word wb/1/:nn
           pick wb nn + 1
           level + 1
           doc-id
   ]
   if _has-leaf-node wb [
      if rse-ids/find-compact first next last wb doc-id [append word-list current-word]

   ]
   return word-list
]



;; ===========================================================
_invert-list: func [
   invert-needed? [logic!]
   res [block!]
   /local
   all-doc-ids
] [
   if not invert-needed? [return res]



   ;; handle doc names are integers
   ;; -----------------------------

   if cif/config/integer-document-names  [
      return difference _unpack-numset res _unpack-numset cif/document-list
      ]


   ;; Handle doc names are strings
   ;; ----------------------------


   all-doc-ids: make block! length? cif/document-list
   repeat nn length? cif/document-list [
      if 0 <> cif/document-list/:nn [;; ignore deletion placeholders
         insert all-doc-ids nn
      ]
   ]
   return difference _unpack-numset res all-doc-ids
]


;; ===================================

_and-results: func [
   prev-hits [block!]
   new-hits [block!]
   seq [integer!]
] [

   ;; ANDs later results to the results set

   if seq = 1 [
      return copy new-hits
      return
   ]

   return intersect prev-hits new-hits

]




;; ==================================
_remove-level: func [
   wb [block!]
   level [integer!]
   doc-ids [block!]
   /local
   pointer
   removed
   temp
] [

   if 0 = length? wb [return true] ;; can this happen!?

   ;; Remove any leaf node entry
   ;; --------------------------


   if _has-leaf-node wb [
      temp: second last wb
      foreach doc-id doc-ids [_remove-packed temp doc-id]
      poke last wb 2 temp
      if ["" []] = last wb [  ;; empty leaf
         remove back tail wb
         if 1 = length? wb [
            clear wb
            return true
         ]
      ]
   ]


   ;; Recurse downwards to the bottom for most removal work
   ;; ------------------------------------------------------

   if level <> cif/config/index-levels [
      for nn 1 length? wb/1 1 [
         _remove-level first at wb (nn + 1) level + 1 doc-ids
      ]
      _remove-empties wb
      return true
   ]


   ;; Main removal job
   ;; ----------------

   ;; Step 1
   ;;
   ;; we're positioned on something like this:
   ;;   ["abc"
   ;;       ["ct" [3] "dd" [3 5] ]          "act" and "add"
   ;;       ["at" [3x6] "et" [3x2 89x2] ]   "bat" and "bet"
   ;;       ["am" [3] "og" [3] ]            "cam" and "cog"
   ;;   ]
   ;;
   ;; So, as the next step, we step through those inner blocks
   ;; and remove the doc-id.  If we are removing doc-id 3, then this
   ;; structure will become
   ;;
   ;;   ["abc"
   ;;       ["dd" [5] ]                  "act" gone
   ;;       ["at" [4x5] "et" [4 89x2] ]  "bat" and "bet"
   ;;       []                           "cam" and "cog" both gone
   ;;   ]

   ;;
   ;; See Step 2 for sorting out the empty block left by"cam" and "cog"



   for nn 1 length? wb/1 1
   [nn: nn + 1

      pointer: head wb/:nn
      loop (length? wb/:nn) / 2 [
         foreach doc-id doc-ids [_remove-packed pointer/2 doc-id]
         either all [block? pointer/2 0 = length? pointer/2] [
            remove pointer
            remove pointer
         ] [
            pointer: next next pointer
         ]
      ]

   ]



   ;; Step 2
   ;; ------
   ;; Something like:
   ;;   ["abc"
   ;;       [dd" [5] ]                   "add"
   ;;       ["at" 4x5 "et" [4 89x2] ]    "bat" and "bet"
   ;;       []                            empty c entry
   ;;   ]

   ;; Must become:
   ;;   ["ab"                            c gone
   ;;       [dd" [5] ]                   "add"
   ;;       ["at" [4x5] "et" [4 89x2] ]    "bat" and "bet"
   ;;   ]

   _remove-empties wb



   ;; Step 3
   ;; ------


   if 1 = length? wb [clear wb] ;; removes stray [""]

   if 0 = length? wb [return true]


   return true

]


;; ==================================
_remove-empties: func [
   wb [block!]
   /local removed
] [

   forever [
      removed: false
      for nn 1 length? wb/1 1 [

         nn: nn + 1
         if any [0 = length? wb/:nn
            all [1 = length? wb/:nn "" = wb/:nn/1]
         ] [
            removed: true
            remove at wb nn
            alter wb/1 to-string pick wb/1 nn - 1
            break ;; so the loop can restart
         ]
      ] ;; for
      if not removed [break] ;; no more forever loop
   ] ;; forever


   ;; Check if leaf node is empty
   ;; ===========================
   if all [_has-leaf-node wb
      0 = length? last wb] [
      remove at wb length? wb
   ]


   return true

]


] ;;  skimp object