REBOL[
  Title: "make-word-list"
  Version: 1.0.0
  Date: 2-Apr-2007
  Author: Peter W A Wood
  Copyright: {Copyright© PWA Wood 2007}
  File: %make-word-list.r
  Purpose: {Makes a list of words from a string}
  License: 'mit
  Library: [
    level: 'beginner
    platform: [all]
    type: [package function tool]
    domain: [files markup database]
    tested-under: [win mac]
    support: none
    license: [mit]
  ]
]

make-word-list: function
[
  {Makes a list of words from a string}
  config [object! none!]
    {Configuration options to be used instead of the default ones}
  content [string!]
    {The content from which the words are to be extracted}
  /for-search
    {The requested word list is being built to perform a search}
][
  word
    {An individual word from the content}
  word-list
    {The list of words for indexing}
  make-words-parse
    {A object in which to store the parse rules}
  ][
    
  make-words-parse: make object!
  [
    ;; default bitsets
    alpha: charset [#"a" - #"z" #"A" - #"Z"]
    digit: charset [#"0" - #"9"]
    alpha-or-digit: union alpha digit
    letter: union alpha-or-digit charset ["~"]
    no-character: charset []
    hex-digit: union digit charset [#"a" - #"f" #"A" - #"F"]
    hyphen: charset ["-_"]
    word-start: alpha
    word-letter: letter
    word-end: charset ["!" "?"]
    number: union digit charset [".,"]
    number-prefix: charset ["+-£$¢"]
    number-postfix: charset ["+-"]
    not-prefix: "~"
    
    ;; other default settings
    word-length: 1x40
    ignore-tags: false
    index-pairs: true
    stop-list: ["a" "is" "the"]
    word-list-length: 2000
    months: [ "jan" "feb" "mar" "apr" "may" "jun" 
              "jul" "aug" "sep" "oct" "nov" "dec"
    ]
    day-suffix: ["th" "st" "rd"]
    
    ;; apply supplied configuration changes
    if object! = type? config
    [
      foreach item next first config 
      [
        error? try
          [set in self to word! item get in config to word! item]
      ]
    ]
    
    ;; convert stop-list to a hash
    stop-list: to hash! stop-list
    
    ;; word definitions
    a-word: [word-start any word-letter opt word-end]
    a-hyphenated-word:
      [a-word hyphen some word-letter any [hyphen | word-letter]]
    either not-prefix
    [
      a-not-word: [not-prefix a-word]
    ][
      a-not-word: no-character              ;;effectively deactiviates the rule
    ]
    a-tag: ["<" thru ">"]
    a-closing-tag: [""]
    a-number: [opt number-prefix digit any number opt number-postfix]
    a-hex-number: [[digit] any #"x" any hex-digit]
    a-tuple: [some digit #"." some digit #"." some digit]
    a-rebol-pair: [opt "-" some digit #"x" opt "-" some digit]
    a-dotted-word: [word-start any word-letter #"." 
                    word-start any [word-letter | #"."] ]                
    a-slashed-word: [word-start any word-letter #"/" 
                     word-start any [word-letter | #"/"]]
    a-back-slashed-word: [word-start any word-letter backslash
                          word-start any [word-letter | backslash]]
    a-rebol-binary-string: ["#{" thru "}"]
    a-rebol-base64-string: ["64#{" thru "}"]
    a-rebol-debase: ["debase" any [" " | newline] "{" thru "}"]
    an-html-escaped: ["&" thru ";"]
    eg: ["e.g" opt "." | "E.G" opt "."]
    a-scheme: [word-start any word-start "://" opt "www."]
    
    ;; specification of a web page address
    a-web-page-address:
    [
      a-dotted-word #"/" word-start 
      any [word-letter | #"/"]
      any [ #"." any word-letter]
    ]
    
    ;; specification of an email address
     an-email-address: [word-start any [word-letter | #"."]  #"@" 
               word-start any word-letter #"." any [word-letter | #"."]]
    
    ;; charsets to speed skipping over unwanted portions of the content
    start-chars: copy [#"<" #"#"]
    if not-prefix
      [append start-chars to-char not-prefix]
    if index-pairs
      [append start-chars #"-"]
    start-chars: charset start-chars
    start-chars: union start-chars union word-start digit
    not-start-char: complement start-chars
    skip-to-next-possible-word: [some not-start-char]
    
    ;; the specification of a date
    ;; first build the day suffix list
    either 0 = length? day-suffix
    [
      a-day-suffix: [""]                
    ][
      ;; build the block of day-suffixes
      a-day-suffix: copy []
      foreach abbr day-suffix
      [
        append a-day-suffix abbr
        append a-day-suffix to-word "|"
      ]
      remove back tail a-day-suffix           ;; remove extraneous | at the end
    ]
    
    ;; build a definition of month abbreviation
    a-month-abbr: copy []
    foreach month months
    [
      append a-month-abbr month
      append a-month-abbr to-word "|"
    ]
    remove back tail a-month-abbr           ;; remove extraneous | at the end
    
    a-date:
    [
      ;; rebol date with alpha month
      [ [1 2 digit] #"-" a-month-abbr [any letter] #"-" [2 4 digit] ]
      |
      ;; rebol date with numeric month
      [ [1 2 digit] #"-" [ 1 2 digit] #"-" [ 2 4 digit] ]
      | 
      ;; date with alpha month
      [ [1 2 digit] #" " a-month-abbr [any letter] #" " [2 4 digit] ]
      |
      ;; dd/mm/yyyy  mm/dd/yyyy (numeric)
      [ [1 2 digit] slash [1 2 digit] slash [1 4 digit] ]
      |  
      ;; yyyy/mm/dd (numeric)
      [ [1 4 digit] slash [1 2 digit] slash [1 2 digit] ]
      |
      ;; date of types 1st June 2000; 3rd June 2000 or 15th June
      ;; this rule will also add phrases such as 21st Century to the word list
      [ [1 2 digit] a-day-suffix #" " [3 letter any letter]
        any [#" " 2 4 digit] ]
    ]
    
    ;; a set of definitions and rule to try to create a rebol format date from
    ;; a date that meets the a-date definition
    a-year-first-date: [ copy yy [4 digit] skip copy mm [1 2 digit] skip 
                              copy dd [1 2 digit]
    ]
    
    a-year-last-date: [
      copy dd [1 2 digit] skip 
      [
        [copy mm [3 letter] [any letter]] | 
        [copy mm [ 1 2 digit] ]
      ] skip
      copy yy [2 4 digit]
    ]
    
    a-day-suffix-date: [
      copy dd [1 2 digit] a-day-suffix #" " copy mm [3 letter] [any letter]
      #" " copy yy [2 4 digit]
    ]
    
    make-rebol-date-rule: [
      [a-year-first-date | a-year-last-date | a-day-suffix-date]
      (
        ;; check to see if there is a match with alpha month abbr
        if mmm: find months lowercase mm
        [
          ;; convert the alpha to a month number
          mm: index? mmm
        ]
        
        if not error? try [mmm: to integer! mm] ;; genuine month?
        [
          if mmm > 12
          [
            ;; swap dd and mm
            swap: mm
            mm: dd
            dd: swap
          ]
          
          ;; try to create a Rebol date
          date-str: join dd ["-" mm "-" yy]
        
          if attempt [date-str: to date! date-str]
          [
            _xadd word-list lowercase to string! date-str
          ]
        ]
      )
    ]
    
    ;; word-in-date-rule
    word-in-date-rule:
    [
      any 
      [
        [1 2 digit] a-day-suffix   ;; this rule ignores 1st, 15th etc.
        |
        copy word-in-date a-word
        (
          _xadd word-list lowercase word-in-date
        )
        |
        skip
      ]
    ]
    
    ;; date rule
    date-rule: 
    [
      copy date a-date
      (
        ;; add the date to the list in its current form
        _xadd word-list lowercase date
        
        ;; try to create a rebol date as well
        parse/all date make-rebol-date-rule
       
        ;; add any words in the date
        parse/all date word-in-date-rule
      )
    ]
    
    ;; word-rule - add a genuine word to the word-list
    word-rule:
    [
      copy word a-word
      (
        _xadd word-list lowercase word
      )
    ]
    
    ;; not-word-rule - remove the "not prefix" from the start of a word 
    ;; unless the for-search refinement is set
    not-word-rule: 
    [
      copy not-word [a-not-word]
      (
        if not for-search [remove not-word]
        _xadd word-list lowercase not-word
      )
    ]
    
    ;; tag rule
    tag-rule:
    [
      copy word a-tag
      (
        if not ignore-tags
        [
          ;; strip off <
          remove word
          ;; strip off >
          remove back tail word
          ;; now re-parse the remaining content
          parse/all word rule
        ]
      )
    ]
    
    ;; dotted-word rule - used for domain names and qualified variable names
    dotted-word-rule:
    [
      copy dotted-word a-dotted-word
      (
        ;; add each "level" of the dotted-word to the list
        ;; eg www.rebol.com will result in the following being added :
        ;;  www.rebol.com
        ;;  rebol.com
        ;;  com
        
        ;; if the last character is a "." remove it
        while
        [
          #"." = last dotted-word
        ]
        [
          remove back tail dotted-word
        ]
        _add-word-hierarchy dotted-word "."
      )
    ]
    
    ;; slashed-word rule - used for domain names and qualified variable names
    slashed-word-rule:
    [
      copy slashed-word a-slashed-word
      (
        ;; add each "level" of the slashed-word to the list
        ;; eg apps/rebolcore/rebol will result in the following being added :
        ;;  apps/rebolcore/rebol
        ;;  rebolcore/rebol
        ;;  rebol
        
        ;; if the last character is a "/" remove it
        while 
        [
          #"/" = last slashed-word
        ]
        [
          remove back tail slashed-word
        ]
        _add-word-hierarchy/with-individual-words slashed-word "/"
      )
    ]
    
    ;; back-slashed-word rule - used for domain names and qualified variable names
    back-slashed-word-rule:
    [
      copy back-slashed-word a-back-slashed-word
      (
        ;; add each "level" of the back-slashed-word to the list
        ;; eg apps\rebolcore\rebol will result in the following being added :
        ;;  apps\rebolcore\rebol
        ;;  rebolcore\rebol
        ;;  rebol
        
        ;; if the last character is a backslash remove it
        while
        [
          backslash = last back-slashed-word
        ]
        [
          remove back tail back-slashed-word
        ]
        _add-word-hierarchy/with-individual-words back-slashed-word backslash
        
      )
    ]
    
    ;; hyphenated-word rule
    ;; add each level of the hyphenated word and all the sub-words (if they are
    ;; valid words)
    hyphenated-word-rule:
    [
      copy hyphenated-word a-hyphenated-word
      (
        ;; if the last characters are hyphens remove them
        while 
        [
          parse to string! last hyphenated-word [hyphen]
        ]
        [
          remove back tail hyphenated-word
        ]
        ;; use the first hyphen found as the separator
        parse hyphenated-word
        [
          copy this-hyphen [a-word hyphen]
         
          ;; add the different levels of hierarchy and the individual words to
          ;; the list
          
          (
            this-hyphen: last this-hyphen
            _add-word-hierarchy/with-individual-words hyphenated-word
                                                      this-hyphen
          )
        ]
      )
    ]
    
    web-page-address-rule:
    [
      copy web-words a-web-page-address
      (
        ;; add each "level" of the web-page to the list
        ;; eg www.rebol.com/downloads.html will result in 
        ;; the following being added :
        ;;  www.rebol.com/downloads.html
        ;;  rebol.com
        ;;  com
        ;;  downloads
        
        ;; split off the domain name and process it
        parse copy/part web-words find web-words "/" dotted-word-rule
        remove/part web-words find/tail web-words "/"
        
        ;; extract valid words from the remainder ingnoring part after dot
        parse web-words 
        [
          any
          [
            copy sub-word a-word
            (
              _xadd word-list lowercase copy sub-word
            )
            |
            "/"
            |
            ["." a-word]
          ]
        ]
      )
    ]
    
    ;; Rebol pair rule
    ;; include rebol pairs in the wordlist if the index-pairs is true in the 
    ;; configuration object
    either index-pairs
    [
      rebol-pair-rule:
      [
        ;; add rebol-pairs to word-list
        copy rp a-rebol-pair
        (
          parse/all rp 
          [
            copy reb-pair a-rebol-pair
            (_xadd word-list reb-pair)
          ]
        )
      ]
    ][
      ;; ignore rebol-pairs
      rebol-pair-rule: no-character           ;; nothing can be selected
    ]
  
    ;; prefix-word-rule - strip of specified prefix and the word to word-list
    prefix-word-rule: 
    [
      copy prefix-word a-prefix-word
      (
        _xadd word-list lowercase next prefix-word
      )
    ]
    
    ;; e.g. rule - adds e.g. and e.g. to the words-list
    eg-rule:
    [
      copy eg-word eg
      (
        _xadd word-list lowercase eg-word
      )
    ]
    
    ;; rebol debase rule - adds the word debase and ignores the binary string
    rebol-debase-rule:
    [
      a-rebol-debase
      (
        _xadd word-list "debase"
      )
    ]
    
    ;; the main rule
    rule: 
    [
      any
      [
        skip-to-next-possible-word
        |
        an-email-address                              ;; ignore email adresses
        |
        hyphenated-word-rule
        |
        a-scheme                                        ;; ignore http:// etc
        |
        web-page-address-rule
        |
        eg-rule
        |
        dotted-word-rule
        |
        slashed-word-rule
        |
        back-slashed-word-rule
        |
        rebol-debase-rule
        |
        word-rule
        |
        date-rule
        |
        rebol-pair-rule
        |
        a-rebol-base64-string                         ;; ignore Rebol base64
        |
        a-rebol-binary-string                         ;; ignore Rebol binary 
        |
        a-tuple                                       ;; ignore tuples
        |
        [digit a-word]                                ;; ignore words starting
        |                                             ;; with a numeric digit
        a-hex-number                                  ;; ignore hex numbers
        |
        a-number                                      ;; ignore complete numbers
        |
        a-closing-tag                                 ;; ignore closing tags
        |
        not-word-rule
        |
        tag-rule
        |
        an-html-escaped               ;; ignore "escaped" html
        |
        skip
      ]
    ]
  _xadd: function
    [
      {exclusive add - add an element if the block doesn't already contain it}
      hsh [hash!]
      element
    ][
      len                                     ;; the length of the element
    ][
      ;; don't add:
      if any
      [
        ;; duplicates
        find hsh element
        ;; words in the stop-list
        find stop-list element
        ;; words greater than the maximum length required
        (len: length? element) > second word-length
        ;; words shorter than the minimum length required
        len < first word-length
      ][
        return
      ]
          
      ;;add the element
      insert hsh element
     
    ]
  
    _add-word-hierarchy: function
    [
      {adds the words from a hierarchy of words, each level being identified by 
       a specified separator. E.g. www.rebol.com will result in the following 
       being added to the word-list:
          ;;  www.rebol.com
          ;;  rebol.com
          ;;  com
      }
      word-hier [string!]
      separator [char! string!]
      /with-individual-words
        {stores any valid individual word in the hierarchy}
    ][
      ind-word
       "An individual word in the hierarchy"
    ][
      _xadd word-list copy lowercase word-hier
      until
      [
        if with-individual-words
        [
          parse word-hier
          [
            copy ind-word a-word
            (_xadd word-list lowercase ind-word)
          ]
        ]
        ;; strip off the first part of the hierarchy
        remove/part word-hier find/tail word-hier separator
        ;; add the hierarchy if it's first char is a letter
        if true = parse to string! first word-hier [word-start]
        [
          _xadd word-list copy lowercase word-hier
        ]
        none = find word-hier separator
      ]
    ]    
  ] ;; end make-words-parse
  
  ;; create the ouput block
  word-list: make hash! make-words-parse/word-list-length
  
  ;; parse the content
  parse/all content make-words-parse/rule
  
  ;; finally sort the list
  return sort to-block word-list
  
]