; This file contains the functions which manipulate words and sentences.

(define (end-of-line-char? c)
  (eq? c #\newline))

(define true #t)
(define false #f)

; Make number->string remove leading "+" if necessary

(if (char=? #\+ (string-ref (number->string 1.0) 0))
    (let ((old-ns number->string))
      (set! number->string
            (lambda (number)
              (let ((result (old-ns number)))
                (if (char=? #\+ (string-ref result 0))
                    (substring result 1 (string-length result))
                    result)))))
    'no-problem)

; Get string in error messages to print nicely (especially "")

(define (error-printform x)
  (if (string? x)
      (string-append "" x "")
      x))
(define e-p error-printform)

; word/ sentence implementation

(define word?
  (let ((number? number?))
    (lambda (x)
      (or (symbol? x) (number? x) (string? x)))))

(define sentence?
  (let ((pair? pair?))
    (define (list-of-words? l)
      (cond ((null? l) true)
            ((pair? l)
             (and (word? (car l)) (list-of-words? (cdr l))))
            (else false)))
    list-of-words?))

(define (empty? x)
  (or (null? x)
      (and (string? x) (string=? x ""))))

(define char-rank
  ; 0 Letter in good case or special initial
  ; 1 ., + or -
  ; 2 Digit
  ; 3 Letter in bad case or weird char
  (let ((*the-char-ranks* (make-vector 256 3)))
    (define (give-rank char rank)
      (vector-set! *the-char-ranks* (char->integer char) rank))
    (for-each (lambda (c) (give-rank c 0))
              (string->list (symbol->string 'abcdefghijklmnopqrstuvwxyz)))
    (for-each (lambda (c) (give-rank c 0))
              (string->list "!$%&*/:<=>?~_^"))
    (for-each (lambda (c) (give-rank c 1))
              (string->list "+-."))
    (for-each (lambda (c) (give-rank c 2))
              (string->list "0123456789"))
    (lambda (char)                                     ; value of char-rank
      (vector-ref *the-char-ranks* (char->integer char)))))

(define string->word
  (let ((= =) (<= <=) (+ +) (- -))
    (lambda (string)
      (define (subsequents? string i length)
        (cond ((= i length) true)
              ((<= (char-rank (string-ref string i)) 2)
               (subsequents? string (+ i 1) length))
              (else false)))
      (define (special-id? string)
        (or (string=? string "+")
            (string=? string "-")
            (string=? string "...")))
      (define (ok-symbol? string)
        (if (string=? string "")
            false
            (let ((rank1 (char-rank (string-ref string 0))))
              (cond ((= rank1 0) (subsequents? string 1 (string-length string)))
                    ((= rank1 1) (special-id? string))
                    (else false)))))
      (define (nn-helper string i len seen-point?)
        (cond ((= i len)
               (if seen-point?
                   (not (char=? (string-ref string (- len 1)) #\0))
                   true))
              ((char=? #\. (string-ref string i))
               (cond (seen-point? false)
                     ((= (+ i 2) len) true) ; Accepts "23.0"
                     (else (nn-helper string (+ i 1) len true))))
              ((= 2 (char-rank (string-ref string i)))
               (nn-helper string (+ i 1) len seen-point?))
              (else false)))
      (define (narrow-number? string)
        (if (string=? string "")
            false
            (let* ((c0 (string-ref string 0))
                   (start 0)
                   (len (string-length string))
                   (cn (string-ref string (- len 1))))
              (if (and (char=? c0 #\-) (not (= len 1)))
                  (begin
                    (set! start 1)
                    (set! c0 (string-ref string 1)))
                  false)
              (cond ((not (= (char-rank cn) 2)) false) ; Reject "-" among others
                    ((char=? c0 #\.) false)
                    ((char=? c0 #\0)
                     (cond ((= len 1) true) ; Accepts "0" but not "-0"
                           ((= len 2) false) ; Rejects -) and 03"
                           ((char=? (string-ref string (+ start 1)) #\.)
                            (nn-helper string (+ start 2) len true))
                           (else false)))
                    (else (nn-helper string start len false))))))
      
      ; The body of string->word:
      (cond ((narrow-number? string) (string->number string))
            ((ok-symbol? string) (string->symbol string))
            (else string)))))


(define char->word
  (let ((= =))
    (lambda (char)
      (let ((rank (char-rank char))
            (string (make-string 1 char)))
        (cond ((= rank 0) (string->symbol string))
              ((= rank 2) (string->number string))
              ((char=? char #\+) '+)
              ((char=? char #\-) '-)
              (else string))))))

(define word->string
  (let ((number? number?))
    (lambda (wd)
      (cond ((string? wd) wd)
            ((number? wd) (number->string wd))
            (else (symbol->string wd))))))

(define (word . x)
  (let ((bad (filter (lambda (arg) (not (word? arg))) x)))
    (if (null? bad)
        (string->word (apply string-append (map word->string x)))
        (error "Invalid argument to WORD: " (e-p (car bad))))))

(define se
  (let ((pair? pair?))
    (define (paranoid-append a original-a b)
      (cond ((null? a) b)
            ((word? (car a))
             (cons (car a) (paranoid-append (cdr a) original-a b)))
            (else (error "Argument to SENTENCE no a word or sentence"
                         original-a))))
    (define (combine-two a b)
      (cond ((pair? a) (paranoid-append a a b))
            ((null? a) b)
            ((word? a) (cons a b))
            (else (error "Argument to SENTENCE not a word or sentence:" a))))
    ; Helper function so recursive calls don't show up in TRACE
    (define (real-se args)
      (if (null? args)
          '()
          (combine-two (car args) (real-se (cdr args)))))
    (lambda args
      (real-se args))))

(define sentence se)

(define first
  (let ((pair? pair?))
    (define (word-first wd)
      (char->word (string-ref (word->string wd) 0)))
    (lambda (x)
      (cond ((pair? x) (car x))
            ((empty? x) (error "Invalid argument to FIRST: " (e-p x)))
            ((word? x) (word-first x))
            (else (error "Invalid argument to FIRST: " (e-p x)))))))

(define last
  (let ((pair? pair?) (- -))
    (define (word-last wd)
      (let ((s (word->string wd)))
        (char->word (string-ref s (- (string-length s) 1)))))
    (define (list-last lst)
      (if (empty? (cdr lst))
          (car lst)
          (list-last (cdr lst))))
    (lambda (x)
      (cond ((pair? x) (list-last x))
            ((empty? x) (error "Invalid argument to LAST: " (e-p x)))
            ((word? x) (word-last x))
            (else (error "Invalid argument to LAST: " (e-p x)))))))

(define bf
  (let ((pair? pair?))
    (define (string-bf s)
      (substring s 1 (string-length s)))
    (define (word-bf wd)
      (string->word (string-bf (word->string wd))))
    (lambda (x)
      (cond ((pair? x) (cdr x))
            ((empty? x) (error "Invalid argument to BUTFIRST: " (e-p x)))
            ((word? x) (word-bf x))
            (else (error "Invalid argument to BUTFIRST: " (e-p x)))))))

(define butfirst bf)

(define bl
  (let ((pair? pair?) (- -))
    (define (list-bl list)
      (if (null? (cdr list))
          '()
          (cons (car list) (list-bl (cdr list)))))
    (define (string-bl s)
      (substring s 0 (- (string-length s) 1)))
    (define (word-bl wd)
      (string->word (string-bl (word->string wd))))
    (lambda (x)
      (cond ((pair? x) (list-bl x))
            ((empty? x) (error "Invalid argument to BUTLAST: " (e-p x)))
            ((word? x) (word-bl x))
            (else (error "Invalid argument to BUTLAST: " (e-p x)))))))

(define butlast bl)

(define item
  (let ((> >) (- -) (< <) (integer? integer?) (list-ref list-ref))
    (define (word-item n wd)
      (char->word (string-ref (word->string wd) (- n 1))))
    (lambda (n stuff)
      (cond ((not (integer? n))
             (error "Invalid first argument to ITEM (must be an integer): "
                    (e-p n)))
            ((< n 1)
             (error "Invalid first argument to ITEM (must be positive): "
                    (e-p n)))
            ((> n (count stuff))
             (error "No such item: " (e-p n) (e-p stuff)))
            ((word? stuff) (word-item n stuff))
            ((pair? stuff) (list-ref stuff (- n 1)))
            (else (error "Invalid second argument to ITEM: " (e-p stuff)))))))

(define member?
  (let ((> >) (- -) (< <))
    (define (real-member? x lst)
      (if (member x lst) true false))
    (define (word-member? small big)
      (let ((one-letter-str (word->string small)))
        (if (> (string-length one-letter-str) 1)
            (error "Invalid arguments to MEMBER?: " (e-p small) (e-p big))
            (let ((big-str (word->string big)))
              (char-in-string? (string-ref one-letter-str 0)
                               big-str
                               (- (string-length big-str) 1))))))
    (define (char-in-string? char string i)
      (cond ((< i 0) false)
            ((char=? char (string-ref string i)) true)
            (else (char-in-string? char string (- i 1)))))
    (lambda (x stuff)
      (cond ((empty? stuff) false)
            ((word? stuff) (word-member? x stuff))
            ((string? (car stuff)) (real-member? (word->string x) stuff))
            (else (real-member? x stuff))))))

(define (before? wd1 wd2)
  (cond ((not (word? wd1))
         (error "Invalid first argument to BEFORE? (not a word): " (e-p wd1)))
        ((not (word? wd2))
         (error "Invalid second argument to BEFORE? (not a word): " (e-p wd2)))
        (else (string<? (word->string wd1) (word->string wd2)))))

(define (count stuff)
  (if (word? stuff)
      (string-length (word->string stuff))
      (length stuff)))


; High Order Functions

(define (filter pred l)
  ; Helper function so recursive calls don't show up in TRACE
  (define (real-filter l)
    (cond ((empty? l) '())
          ((pred (car l))
           (cons (car l) (real-filter (cdr l))))
          (else (real-filter (cdr l)))))
  (cond ((not (procedure? pred))
         (error "Invalid first argument to FILTER (not a procedure): "
                (e-p pred)))
        ((not (pair? l))
         (error "Invalide second argument to FILTER (not a list): "
                (e-p l)))
        (else (real-filter l))))

(define keep
  (let ((+ +) (= =) (pair? pair?))
    (lambda (pred w-or-s)
      (define (keep-string in i out out-len len)
        (cond ((= i len) (substring out 0 out-len))
              ((pred (char->word (string-ref in i)))
               (string-set! out out-len (string-ref in i))
               (keep-string in (+ i 1) out (+ out-len 1) len))
              (else (keep-string in (+ i 1) out out-len len))))
      (define (keep-word wd)
        (let* ((string (word->string wd))
               (len (string-length string)))
          (string->word
            (keep-string string 0 (make-string len) 0 len))))
      (cond ((not (procedure? pred))
             (error "Invalid first argument to KEEP (not a procedure): "
                    (e-p pred)))
            ((pair? w-or-s) (filter pred w-or-s))
            ((word? w-or-s) (keep-word w-or-s))
            ((null? w-or-s) '())
            (else
              (error "Bad second argument to KEEP (not a word or sentence): "
                     (e-p w-or-s)))))))

(define every
  (let ((= =) (+ +))
    (lambda (fn stuff)
      (define (string-every string i length)
        (if (= i length)
            '()
            (se (fn (char->word (string-ref string i)))
                (string-every string (+ i 1) length))))
      (define (sent-every sent)
        (if (empty? sent)
            sent
            (se (fn (first sent))
                (sent-every (bf sent)))))
      (cond ((not (procedure? fn))
             (error "Invalid first argument to EVERY (not a procedure): "
                    (e-p fn)))
            ((word? stuff)
             (let ((string (word->string stuff)))
               (string-every string 0 (string-length string))))
            (else (sent-every stuff))))))

(define (accumulate combiner stuff)
  (define (real-accumulate stuff)
    (if (empty? (bf stuff))
        (first stuff)
        (combiner (first stuff) (real-accumulate (bf stuff)))))
  (cond ((not (procedure? combiner))
         (error "Invalid first argument to ACCUMULATE (not a procedure): "
                (e-p combiner)))
        ((not (empty? stuff)) (real-accumulate stuff))
        ((member combiner (list + * word se append)) (combiner))
        (else (error "Can't accumulate empty input with that combiner"))))