shrub/gen/capitalize.hoon

::
::  part 1: parse the file into {uppers}
::
/-  unicode-data
/+  new-hoon
/=  case-table
  /;  |=  a/(list line:unicode-data)
      =,  new-hoon
      |^  %-  build-tree
          %-  flop
          (build-case-nodes a)
      ::
      :>  #
      :>  #  %case-nodes
      :>  #
      :>    transforms raw unicode data into sequential case nodes.
      +|
      ++  build-case-nodes
        :>  raw list of unicode data lines to a compact list of chardata
        |=  a/(list line:unicode-data)
        ^-  (list case-node:unicode-data)
        =<  out
        ::
        ::  todo: we don't have the final case range in the output of this
        ::  gate. this is because this algorithm doesn't work when the last
        ::  char is part of a range. this doesn't happen with the real one,
        ::  only the excerpts i was using for testing.
        ::
        %^  foldl:ls  a  *case-fold
        |=  {c/case-fold l/line:unicode-data}
        ^+  c
        =+  state=(line-to-case-state l)
        ?:  (is-adjacent state prev.c)
          c(prev state)
        =.  c  (add-range c)
        %=  c
          start
            ?:  &(!=(case.state %missing) !=(case.state %none))
              `state
            ~
          prev  state
        ==
      ::
      ++  line-to-case-state
        :>  creates an easy to merge form.
        |=  line:unicode-data
        ^-  case-state
        =/  out/case-state
          [code %none [%none ~] [%none ~] [%none ~]]
        ?:  =(code `@c`0)
          =.  case.out  %missing
          out
        =.  case.out
          ?+  gen  %none
            $lu  %upper
            $ll  %lower
            $lt  %title
          ==
        ::
        ::  several characters aren't described as $lu or $ll but have lower or
        ::  upper state, such as u+2161. detect this and fix it up.
        ::
        =?  case.out  &(=(case.out %none) !=(low ~))  %upper
        =?  case.out  &(=(case.out %none) !=(up ~))  %lower
        ::
        ::  calculate offsets
        ::
        =?  upper.out  !=(up ~)     (calculate-offset (need up) code)
        =?  lower.out  !=(low ~)
           (calculate-offset (need low) code)
        =?  title.out  !=(title ~)  (calculate-offset (need title) code)
        out
      ::
      ++  calculate-offset
        |=  {src/@c dst/@c}
        ^-  case-offset:unicode-data
        ?:  =(src dst)
          [%none ~]
        ?:  (gth src dst)
          [%add (sub src dst)]
        [%sub (sub dst src)]
      ::
      ++  is-adjacent
        :>  is {rhs} a continuation of {lhs}?
        |=  {lhs/case-state rhs/case-state}
        ^-  ?
        ?:  (lth point.rhs point.lhs)
          $(lhs rhs, rhs lhs)
        ?:  !=(point.rhs +(point.lhs))
          %.n
        ?:  !=(case.rhs case.lhs)
          (upper-lower-adjacent lhs rhs)
        ?:  =(case.lhs %none)
          %.n
        ?:  =(case.lhs %missing)
          %.n
        ?:  !=(upper.lhs upper.rhs)
          %.n
        ?:  !=(lower.lhs lower.rhs)
          %.n
        ?:  !=(title.lhs title.rhs)
          %.n
        %.y
      ::
      ++  upper-lower-adjacent
        :>    detects %upper-lower spans.
        :>
        :>  is {lhs} the same as {rhs}, but with opposite case?
        |=  {lhs/case-state rhs/case-state}
        ?:  &(=(case.lhs %upper) !=(case.rhs %lower))
          %.n
        ?:  &(=(case.lhs %lower) !=(case.rhs %upper))
          %.n
        ::
        ::  to simplify detection, if things are in the opposite order, redo
        ::  things flipped.
        ::
        ?:  =(case.lhs %lower)
          $(lhs rhs, rhs lhs)
        ?&  (is-upper-lower lhs)
            (is-lower-upper rhs)
        ==
      ::
      ++  is-upper-lower
        |=  i/case-state
        =(+.+.i [[%none ~] [%add 1] [%none ~]])
      ::
      ++  is-lower-upper
        |=  i/case-state
        =(+.+.i [[%sub 1] [%none ~] [%sub 1]])
      ::
      ++  is-none
        |=  i/case-state
        =(+.+.i [[%none ~] [%none ~] [%none ~]])
      ::
      ++  add-range
        |=  c/case-fold
        ^+  c
        ?~  start.c
          c
        ?:  (is-none u.start.c)
          c
        ?:  ?&  (gth point.prev.c point.u.start.c)
                (is-upper-lower u.start.c)
            ==
          =/  node/case-node:unicode-data
            [`@ux`point.u.start.c `@ux`point.prev.c [%uplo ~] [%uplo ~] [%uplo ~]]
          c(out [node out.c])
        =/  node/case-node:unicode-data
          [`@ux`point.u.start.c `@ux`point.prev.c +.+.u.start.c]
        c(out [node out.c])
      ::
      ++  case-fold
        :>  state that's part of the fold which generates the list of case-nodes
        $:  :>  resulting data to pass to treeify.
            out/(list case-node:unicode-data)
            :>  the start of a run of characters; ~ for not active.
            start/(unit case-state)
            :>  previous character state
            prev/case-state
        ==
      ::
      ++  case-state
        :>  a temporary model which we compress later in a second pass.
        $:  point/@c
            case/case-class
            upper/case-offset:unicode-data
            lower/case-offset:unicode-data
            title/case-offset:unicode-data
        ==
      ::
      ++  case-class
        :>  classification of an individual character.
        $?  $upper
            $lower
            $title
            $none
            $missing
        ==
      ::
      :>  #
      :>  #  %tree-building
      :>  #
      :>    builds a binary search tree out of the list
      +|
      ++  build-tree
        |=  a/(list case-node:unicode-data)
        ^-  case-tree:unicode-data
        ::  there's probably a bottom up approach that doesn't require walking
        ::  a list over and over again.
        ?~  a
          ~
        =+  len=(lent a)
        =+  [lhs rhs]=(split-at:ls (div len 2) a)
        ?~  rhs
          ?~  lhs
            ~
          [i.lhs ~ ~]
        =+  x=[i.rhs $(a lhs) $(a t.rhs)]
        x
      --
  /:  /===/lib/unicode-data  /&unicode-data&/txt/
::
::  part 2: utility core
::
|%
++  transform
  |=  {a/tape fun/$-(@c @c)}
  %-  tufa
  (turn (tuba a) fun)
::
++  to-upper
  :>  returns the uppercase of unicode codepoint {a}
  |=  a/@c
  ^-  @c
  ::  special case ascii to not perform map lookup.
  ?:  (lte a max-ascii)
    ?:  &((gte a 'a') (lte a 'z'))
      (sub a 32)
    a
  (apply-table a case-table %upper)
::
++  to-lower
  :>  returns the lowercase of unicode codepoint {a}
  |=  a/@c
  ^-  @c
  ?:  (lte a max-ascii)
    ?:  &((get a 'A') (lte a 'Z'))
      (add 32 a)
    a
  (apply-table a case-table %lower)
::
++  apply-table
  :>    searches {table} and apples applies {type} to {a}.
  :>
  :>  this recursively walks the case tree {table}. if it finds an entry which
  :>  matches on {a}, it will apply the offset. otherwise, returns {a}.
  |=  {a/@c table/case-tree:unicode-data type/?($upper $lower $title)}
  ^-  @c
  ?~  table
    a
  ?:  (lth a start.n.table)
    $(table l.table)
  ?:  (gth a end.n.table)
    $(table r.table)
  ?.  &((lte start.n.table a) (lte a end.n.table))
    a
  %^  apply-offset  a  type
  ?-  type
    $upper  upper.n.table
    $lower  lower.n.table
    $title  title.n.table
  ==
::
++  apply-offset
  :>  applies an character offset to {a}.
  |=  {a/@c type/?($upper $lower $title) offset/case-offset:unicode-data}
  ^-  @c
  ?-  offset
    {$add *}   (add a a.offset)
    {$sub *}   (sub a s.offset)
    {$none *}  a
  ::
      {$uplo *}
    ?-  type
      $upper  (sub a 1)
      $lower  (add a 1)
      $title  (sub a 1)
    ==
  ==
::
++  max-ascii  `@c`0x7f
--
::
::  part 3: generator
::
:-  %say
|=  $:  {now/@da eny/@uvJ bec/beak}
        {n/tape $~}
        $~
    ==
:-  %tape  (transform n to-upper)