;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/types)
(use goo/any)
(use goo/log)
(use goo/chr)
(use goo/mag)
(use goo/math)
(use goo/cols/col)
(use goo/cols/colx)
(use goo/cols/seq)
(use goo/cols/lst)
(use goo/cols/vec)

(exported
 (dg str (objects|...))
 (dg char->ascii (char|<chr> => <int>))
 (dv ascii-whitespaces #f)
 (dv ascii-limit #f)
 (dg str-to-num (string|<str> => (t? <num>))) ;; S48
 (dg num-to-str-base (num|<num> radix|<int> => <str>))
 (dg num-to-str (num|<num> => <str>))
 (dv *print-base* 10)
 )
;;; STRING

(dm nul ((c (t= <str>)) => <str>)
  %snul)

(dm elt-default (x|<str> => <any>)
  #\space)

(dm elt-type (x|<col> => <type>) <chr>)

(dm fab ((x (t= <str>)) s|<fixnum> => <str>)
  (%str (%iu s) (%cu #\space)))

(dm str (objects|...)
  (fabs <str> objects))

(dm (len inline) (x|<str> => <fixnum>)
  (%ib (%slen x)))

(dm (low-elt inline) (x|<str> i|<fixnum> => <chr>)
  (%cb (%selt x (%iu i))))

(dm (fab-elt-setter inline) (z|<chr> x|<str> i|<fixnum>)
  (set (%selt x (%iu i)) (%cu z)))

(dm elt-or (x|<str> i|<fixnum> default => <any>) ;; TODO: TIGHTEN RET TYPE
  (if (range-check? x i)
      (%cb (%selt x (%iu i))) ;; TODO: USE LOW-ELT
      default)) 

;; (dm elt-setter (z|<chr> x|<str> i|<int>)
;;   (range-check x i)
;;   (set (%selt x (%iu i)) (%cu z))) ;; TODO: USE LOW-ELT

(dm to-str (x|<str> => <str>)
  x)

(dm add (s|<str> c|<chr> => <str>)
  (cat (to-str c) s))

;;; ASCII -- S48

(dv ascii-limit 128)

(dv ascii-chars|<vec>
  (let ((ascii-chars
         (fill! (fab <vec> ascii-limit) #f))
        (init
         (fun (i s)
           (rep loop ((i i) (j 0))
             (unless (= j (len s))
               (set (elt ascii-chars i) (elt s j))
               (loop (+ i 1) (+ j 1)))))))
    (init 9 "\t")  ;; tab
    (init 10 "\n") ;; newline
    (init 12 "\f") ;; page
    (init 13 "\r") ;; carriage return
    (init 32 " !\"#$%&'()*+,-./0123456789:;<=>?")
    (init 64 "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_")
    (init 96 "`abcdefghijklmnopqrstuvwxyz{|}~")
    ascii-chars))

(dm ascii->char (n|<int> => <chr>)
  (or (elt ascii-chars n)
      (error "not a standard character's ASCII code: %=" n)))

(dm char->integer (char|<chr> => <int>)
  (as <int> char))

(dm integer->char (n|<int> => <chr>)
  (as <chr> n))

(dv (native-chars <lst>)
  (let ((end259 (len ascii-chars)))
    (rep loop ((i 0) (least #f) (greatest #f))
      (if (= i end259)
          (let ((v (fill! (fab <vec> (+ (- greatest least) 1)) #f)))
            (rep loop ((i 0))
              (if (= i end259)
                  (lst least v)
                  (let ((c (elt ascii-chars i)))
                    (if c (set (elt v (- (char->integer c) least)) i))
                    (loop (+ i 1))))))
          (let ((c (elt ascii-chars i)))
            (if c
                (let ((n (char->integer c)))
                  (loop (+ i 1) (if least (min least n) n)
                        (if greatest (max greatest n) n)))
                (loop (+ i 1) least greatest)))))))

(dm char->ascii (char|<chr> => <int>)
  (or (elt (head (tail native-chars))
           (- (char->integer char) (head native-chars)))
      (error "not a standard character: %=" char)))

(dv ascii-whitespaces '(32 10 9 12 13))

(dv ascii-digits|<vec>
  (let ((chars (fill! (fab <vec> ascii-limit) #f)))
    (rep loop ((i (char->ascii #\0)) (x 0))
      (unless (> x 9) (set (elt chars i) x) (loop (+ i 1) (+ x 1))))
    (rep loop ((i (char->ascii #\a)) (x 10))
      (unless (> x 15) (set (elt chars i) x) (loop (+ i 1) (+ x 1))))
    (rep loop ((i (char->ascii #\A)) (x 10))
      (unless (> x 15) (set (elt chars i) x) (loop (+ i 1) (+ x 1))))
    chars))

(dm to-digit-base (digit|<chr> => (t? <int>))
  (elt ascii-digits (char->ascii digit)))

(dm digit-base? (x|<chr> radix|<int> => (t? <int>))
  (let ((dig (to-digit-base x)))
    (and dig (< dig radix) dig)))

(dm str-to-num (string|<str> => (t? <num>)) ;; S48
  (def s 1)
  (def d 0)
  (def n 0)
  (def i 0)
  (def scale 1)
  (def length (len string))
  (def seen-decimal-point? #f)
  (def radix 10)
  (loc ((match (char)
          (if (and (< i length) (= (elt string i) char))
              (seq (set i (+ i 1)) #t)
              #f))
        (match-digit! (_)
          (esc return
            (loc ((fail!! () (return #f)))
              (if (>= i length) (fail!!))
              (def char (elt string i))
              (if (= char #\.)
                  (if seen-decimal-point?
                      (error "str-to-num: Two decimal points: %=" string)
                      (seq (set seen-decimal-point? #t)
                           (set i (+ i 1))
                           (if (>= i length) (fail!!))
                           (set char (elt string i)))))
              (set d (digit-base? char radix))
              (unless d (fail!!))
              (set i (+ i 1))
              (if seen-decimal-point?
                  (set scale (* scale radix)))
              #t)))
        (looking-at-alpha? ()
          (and (< i length) 
               (alpha? (elt string i)))))
    ;; Now we get to use all this matching machinery
    (and (or (match #\+)
             (and (match #\-) (set s -1))
             (if (match #\#) 
                 (or (and (match #\b) (set radix 2))
                     (and (match #\o) (set radix 8))
                     (and (match #\d) (set radix 10))
                     (and (match #\x) (set radix 16)))
                 #t))
         (and (match-digit! d) (set n d))
         (rep loop ()
           (if (and (match-digit! d) (set n (+ (* n radix) d)))
               (loop)
               #t))
         (= i length) ;; consumed all chars
         (let ((f (if (== 1 scale)
                      (* s n)
                      (* (as <flo> s) (/ (as <flo> n) (as <flo> scale))))))
           (if seen-decimal-point? f (trunc f))))))

(dv $digit-to-char "0123456789abcdefghijklmnopqrstuvwxyz")

(ddv *print-base* 10)

(dv epsilon 0.000001)

(dm num-to-str-base (num|<int> radix|<int> => <str>)
  (def s 
    (if (< num 0) -1 1))
  (def digit-list
    (rep loop ((digit-list '()) (num (* num s)))
      (if (= num 0)
          digit-list
          (let ((digit (elt $digit-to-char (rem num radix))))
            (loop (pair digit digit-list)
                  (1st (trunc/ num radix)))))))
  (as <str> (if (< s 0)
                (pair #\- digit-list)
                (if (= num 0) "0" digit-list))))

(dm num-to-str (num|<int> => <str>)
  (num-to-str-base num *print-base*))

(dm num-to-str-base (num|<flo> radix|<int> => <str>)
  (def s (if (< num 0) -1 +1))
  (def p (* num s))
  (def string "")
  (def e (rep loop ((p p) (e 0))
           (def i (trunc p))
           (if (< (- p i) epsilon)
               (seq (set string (num-to-str-base i radix)) e)
               (loop (* p radix) (+ e 1)))))
  (def length (len string))
  (set string
       (if (= e 0)
           (cat string ".0")
           (if (= e length)
               (cat "0." string)
               (if (< e length)
                   (cat (sub string 0 (- length e)) "." 
                        (sub string (- length e) length))
                   (cat (sub "0.0000000000000" 0 (+ (- e length) 2))
                        string)))))
    (if (< s 0) (cat "-" string) string))

(dm num-to-str (num|<flo> => <str>)
  (num-to-str-base num *print-base*))

;;; SYMBOL

(dm (as inline) ((_ (t= <str>)) s|<sym> => <str>)
  (sym-name s))

(dm (as inline) ((_ (t= <sym>)) s|<str> => <sym>)
  (fab-sym s)
  ;; (def sym (elt symbols s))
  ;; (if (== sym nul)
  ;;     (set (elt symbols s) sym)
  ;;     sym)
  )

(dm (< inline) (x|<sym> y|<sym> => <log>)
  (< (sym-name x) (sym-name y)))

(dm to-str (x|<sym> => <str>)
  (sym-name x))
