string.egi

;;;;;
;;;;;
;;;;; String
;;;;;
;;;;;

(define $string
  (matcher
    {[,$val []
      {[$tgt  (if (eq? val tgt)
                {[]}
                {})]}]
     [<nil> []
      {[$tgt (if (eq? "" tgt)
               {[]}
               {})]}]
     [<cons $ $> [char string]
      {[$tgt (if (eq? "" tgt)
               {}
               {(uncons-string tgt)})]}]
     [<join $ <cons ,$px $>> [string string]
      {[$tgt (match-all (S.split (pack {px}) tgt) (list string)
               [<join (& ^<nil> $xs) (& ^<nil> $ys)> [(S.intercalate (pack {px}) xs)
                                (S.intercalate (pack {px}) ys)
                                ]])]}]
     [<join $ <join ,$pxs $>> [string string]
      {[$tgt (match-all (S.split pxs tgt) (list string)
               [<join (& ^<nil> $xs) (& ^<nil> $ys)> [(S.intercalate pxs xs)
                                (S.intercalate pxs ys)
                                ]])]}]
     [<join $ $> [string string]
      {[$tgt (match-all tgt string
                 [(loop $i [1 $n] <cons $xa_i ...> $rs) [(pack (map (lambda [$i] xa_i) (between 1 n))) rs]])]}]
     [$ [something]
      {[$tgt {tgt}]}]
     }))

(define $chop
  (lambda [$xs]
    (match xs string
      {[<snoc (| ,'\n' ,' ') $ys> (chop ys)]
       [_ xs]})))

;;;
;;; String as Collection
;;;

(define $S.map
  (lambda [$f $xs]
    (pack (map f (unpack xs)))))

(define $S.length
  (lambda [$xs]
    (length-string xs)))

(define $S.split
  (lambda [$in $ls]
    (split-string in ls)))

(define $S.append
  (lambda [$xs $ys]
    (append-string xs ys)))

(define $S.concat
  (lambda [$xss]
    (foldr (lambda [$xs $rs] (S.append xs rs))
           ""
           xss)))

(define $S.intercalate (compose intersperse S.concat))

(define $katakana?
  (match-lambda char
    {[,'ア' #t] [,'イ' #t] [,'ウ' #t] [,'エ' #t] [,'オ' #t]
     [,'カ' #t] [,'キ' #t] [,'ク' #t] [,'ケ' #t] [,'コ' #t]
     [,'サ' #t] [,'シ' #t] [,'ス' #t] [,'セ' #t] [,'ソ' #t]
     [,'タ' #t] [,'チ' #t] [,'ツ' #t] [,'テ' #t] [,'ト' #t]
     [,'ナ' #t] [,'ニ' #t] [,'ヌ' #t] [,'ネ' #t] [,'ノ' #t]
     [,'ハ' #t] [,'ヒ' #t] [,'フ' #t] [,'ヘ' #t] [,'ホ' #t]
     [,'マ' #t] [,'ミ' #t] [,'ム' #t] [,'メ' #t] [,'モ' #t]
     [,'ヤ' #t] [,'ユ' #t] [,'ヨ' #t]
     [,'ラ' #t] [,'リ' #t] [,'ル' #t] [,'レ' #t] [,'ロ' #t]
     [,'ワ' #t] [,'ヲ' #t] [,'ン' #t]
     [,'ガ' #t] [,'ギ' #t] [,'グ' #t] [,'ゲ' #t] [,'ゴ' #t]
     [,'ザ' #t] [,'ジ' #t] [,'ズ' #t] [,'ゼ' #t] [,'ゾ' #t]
     [,'ダ' #t] [,'ヂ' #t] [,'ヅ' #t] [,'デ' #t] [,'ド' #t]
     [,'バ' #t] [,'ビ' #t] [,'ブ' #t] [,'ベ' #t] [,'ボ' #t]
     [,'パ' #t] [,'ピ' #t] [,'プ' #t] [,'ペ' #t] [,'ポ' #t]
     [,'ァ' #t] [,'ィ' #t] [,'ゥ' #t] [,'ェ' #t] [,'ォ' #t]
     [,'ャ' #t] [,'ュ' #t] [,'ョ' #t]
     [,'ッ' #t] [,'ー' #t]
     [_ #f]}))

(define $katakanas?
  (lambda [$s]
    (all katakana? (unpack s))))

(define $alphabet?
  (match-lambda char
    {[,'a' #t] [,'b' #t] [,'c' #t] [,'d' #t] [,'e' #t]
     [,'f' #t] [,'g' #t] [,'h' #t] [,'i' #t] [,'j' #t]
     [,'k' #t] [,'l' #t] [,'m' #t] [,'n' #t] [,'o' #t]
     [,'p' #t] [,'q' #t] [,'r' #t] [,'s' #t] [,'t' #t]
     [,'u' #t] [,'v' #t] [,'w' #t] [,'x' #t] [,'y' #t]
     [,'z' #t]
     [,'A' #t] [,'B' #t] [,'C' #t] [,'D' #t] [,'E' #t]
     [,'F' #t] [,'G' #t] [,'H' #t] [,'I' #t] [,'J' #t]
     [,'K' #t] [,'L' #t] [,'M' #t] [,'N' #t] [,'O' #t]
     [,'P' #t] [,'Q' #t] [,'R' #t] [,'S' #t] [,'T' #t]
     [,'U' #t] [,'V' #t] [,'W' #t] [,'X' #t] [,'Y' #t]
     [,'Z' #t]
     [_ #f]}))

(define $alphabets?
  (lambda [$s]
    (all alphabet? (unpack s))))

(define $upper-case
  (match-lambda char
    {[,'a' 'A'] [,'b' 'B'] [,'c' 'C'] [,'d' 'D'] [,'e' 'E']
     [,'f' 'F'] [,'g' 'G'] [,'h' 'H'] [,'i' 'I'] [,'j' 'J']
     [,'k' 'K'] [,'l' 'L'] [,'m' 'M'] [,'n' 'N'] [,'o' 'O']
     [,'p' 'P'] [,'q' 'Q'] [,'r' 'R'] [,'s' 'S'] [,'t' 'T']
     [,'u' 'U'] [,'v' 'V'] [,'w' 'W'] [,'x' 'X'] [,'y' 'Y']
     [,'z' 'Z']
     [$c c]}))