(module utilities mzscheme
  (require (lib "etc.ss")
           (lib "list.ss")
           (lib "plt-match.ss")
           (lib "class.ss")
           (lib "errortrace-lib.ss" "errortrace")
           (lib "contract.ss")
           "voice-exn.ss"
           "rope.ss")
  
  (provide (all-from "voice-exn.ss"))
  
  (define voice-debug false)
  (define (voice-printf . args)
    (when voice-debug
      (apply printf args)))
  
  (provide print-current-stack-trace)
  (define (print-current-stack-trace)
    (with-handlers ([exn:fail? 
                     (lambda (exn)
                       (print-error-trace (current-output-port) exn))])
      (error 'print-current-stack-trace)))
  
  
  (provide end-cons)
  ;; end-cons : ('a list) 'a -> ('a list)
  (define (end-cons l a)
    (reverse (cons a (reverse l))))
  
  
  (provide list-gcd)
  ;; list-gcd : (('a list) list) -> ('a list)
  (define (list-gcd lst)
    (define ?
      (lambda args
        (if (empty? args)
            true
            (let* ([a (first args)]
                   [? (lambda (b) (equal? a b))])
              (andmap ? (rest args))))))
    
    (if (empty? lst)
        empty
        (let loop ([lst lst])
          (if (ormap empty? lst)
              empty
              (let ([a (map first lst)]
                    [b (map rest lst)])
                (if (apply ? a)
                    (cons (first a) (loop b))
                    empty))))))
  
  
  (provide blank-string?)
  ;; blank-string? string -> boolean
  ;; Returns true if the string consists only of whitespace characters.
  (define (blank-string? text)
    (let loop ([i 0])
      (cond
        [(= i (string-length text))
         #t]
        [(char-whitespace? (string-ref text i))
         (loop (add1 i))]
        [else #f])))
  
  
  ;; alt/meta-prefix: string -> string
  ;; Given a string, constructs a key description appending
  ;; whatever system-specific control character describes meta.
  (provide alt/meta-prefix)
  (define (alt/meta-prefix str)
    (format "~a~a" (case (system-type)
                     [(macosx macos) "d:"]
                     [(windows) "m:"]
                     [(unix) "m:"]
                     [else "m:"]) str))
  
  
  (provide filter-double)
  (define (filter-double xs)
    (define ht (make-hash-table 'equal))
    (define (seen? x) 
      (hash-table-get ht x (lambda () #f)))
    (define (mark! x)
      (hash-table-put! ht x #t))
    
    (let loop ([xs xs])
      (cond 
        [(empty? xs) '()]
        [(seen? (first xs)) 
         (loop (rest xs))]
        [else 
         (mark! (first xs))
         (cons (first xs) (loop (rest xs)))])))
  
  (provide list-ref/safe)
  ;; list-ref/safe : ('a list) int -> 'a
  ;; Calls list-ref with error.
  ;; i can be negative because of back. We do not control the value.
  (define (list-ref/safe lst i)
    (if (and (>= i 0) (< i (length lst)))
        (list-ref lst i)
        (raise (make-voice-exn (format "there are only ~a matches" (length lst))))))
  
  
  
          
                 
  

  (provide compute-new-start-index/insert
           compute-new-end-index/insert
           compute-new-selection/insert
           compute-new-index/delete
           compute-new-selection/delete
           compute-new-selection/replace)

  ;; compute-new-start-index/insert : index index non-negative-integer -> index
  ;; We want to compute the new index of the 'current-index' knowing
  ;; we are inserting a string of length 'insertion-length' at
  ;; index 'insertion-index'.
  (define (compute-new-start-index/insert current-index insertion-index insertion-length)
    (cond
     [(< current-index insertion-index) current-index]
     [else (+ current-index insertion-length)]))

  ;; compute-new-end-index/insert : index index non-negative-integer -> index
  ;; This function differs from the start one on the behavior
  ;; if the current-index is equal to the insertion-index,
  ;; and in this case the recult of compute-new-end-index can be lesser then compute-new-start-index, so becareful.
  ;; This should be understood in the context of inserting text in a selection.
  (define (compute-new-end-index/insert current-index insertion-index insertion-length)
    (cond
     [(<= current-index insertion-index) current-index]
     [else (+ current-index insertion-length)]))

  ;; compute-new-selection/insert : index non-negative-integer index non-negative-integer -> (index non-negative-integer values)
  ;; Given a selection and an inserting text, it returns the new selection.
  (define (compute-new-selection/insert current-index current-length insertion-index insertion-length)
    (let* ([new-index     (compute-new-start-index/insert current-index insertion-index insertion-length)]
           [new-end-index (compute-new-end-index/insert (+ current-index current-length) insertion-index insertion-length)])
      (if (<= new-index new-end-index) ; the false case only happens when current-index == insertion-index and current-length == 0
          (values new-index (- new-end-index new-index))
          (values new-index 0))))

  ;; compute-new-index/delete : index index non-negative-integer -> index
  (define (compute-new-index/delete current-index deletion-index deletion-length)
    (cond
     [(<  current-index deletion-index) current-index]
     [(and (>= current-index deletion-index)
           (<= current-index (+ deletion-index deletion-length))) deletion-index]
     [else (- current-index deletion-length)]))

  ;; compute-new-selection/delete : index non-negative-integer index non-negative-integer -> (index non-negative-integer values)
  (define (compute-new-selection/delete current-index current-length deletion-index deletion-length)
    (let* ([new-start-index (compute-new-index/delete current-index deletion-index deletion-length)]
           [new-end-index   (compute-new-index/delete (+ current-index current-length) deletion-index deletion-length)])
      (values new-start-index (- new-end-index new-start-index))))

  ;; compute-new-selection/replace : index non-negative-integer index non-negative-integer non-negative-integer -> (index non-negative-integer values)
  (define (compute-new-selection/replace current-index current-length replace-index deletion-length insertion-length)
    (let-values ([(new-index new-length) (compute-new-selection/delete current-index current-length replace-index deletion-length)])
      (compute-new-selection/insert new-index new-length replace-index insertion-length)))


  (provide symbol/stx? prefix/string? prefix/symbol?)

  ;; symbol/stx? : syntax -> boolean
  (define (symbol/stx? stx)
    (symbol? (syntax-e stx)))

  ;; prefix/symbol? : symbol -> symbol -> boolean
  (define ((prefix/symbol? a) b)
    ((prefix/string? (symbol->string a)) (symbol->string b)))

  ;; prefix/string? : string -> string -> boolean
  (define ((prefix/string? a) b)
    (let ([a-len (string-length a)]
          [b-len (string-length b)])
      (and (<= a-len b-len)
           (string=? a (substring b 0 a-len)))))
  
  (provide syntax-begins-with/is-symbol? syntax-is-symbol? syntax-begins-with? identifier-match? tokenize-identifier)

  ;; syntax-begins-with/is-symbol? : symbol -> syntax -> boolean
  (define ((syntax-begins-with/is-symbol? symbol) stx)
    (or ((syntax-begins-with? symbol) stx)
        ((syntax-is-symbol?   symbol) stx)))
  
  ;; syntax-is-symbol? : symbol -> syntax -> boolean
  (define ((syntax-is-symbol? symbol) stx)
    (let ([stx-e (syntax-e stx)])
      (and (atomic? stx-e)
           (if (symbol? stx-e)
               (identifier-match? symbol stx-e)
               (eq? symbol (string->symbol (format (cond
                                                    [(string? stx-e) "\"~a\""]
                                                    [(char?   stx-e)  "#\\~a"]
                                                    [else                "~a"]) stx-e)))))))

  ;; syntax-begins-with? : symbol -> syntax -> boolean
  (define ((syntax-begins-with? symbol) stx)
    (let ([lst (stx->lst stx)])
      (and (not (empty? lst))
           ((syntax-is-symbol? symbol) (first lst)))))
  
  ;; This function returns true if the first parameter matched the rule up given the second parameter.
  ;; identifier-match? : symbol symbol -> boolean
  (define (identifier-match? symbol element)
    (or ((prefix/symbol? symbol) element)
        ;;(and (member (symbol->string symbol) (tokenize-identifier (symbol->string element))) true)))
        (let ([tokens (tokenize-identifier (symbol->string element))])
          (and (not (empty? tokens))
               ((prefix/string? (symbol->string symbol)) (first tokens))))))

  ;; tokenize-identifier : string -> (string list)
  (define (tokenize-identifier str)
    ;; count : (char -> boolean) (char list) -> non-negative-integer
    (define (count pred lst)
      (let loop ([lst lst])
        (cond
         [(empty? lst) 0]
         [(pred (first lst)) (add1 (loop (rest lst)))]
         [else 0])))
    (let loop ([lst (string->list str)])
      (cond
       [(empty? lst) empty]
       [else
        (let* ([nb-alpha-char (count char-alphabetic? lst)]
               [sub-alpha-str (substring (list->string lst) 0 nb-alpha-char)]
               [lst (string->list (substring (list->string lst) nb-alpha-char (length lst)))]
               [nb-non-alpha-char (count (lambda (a) (not (char-alphabetic? a))) lst)]
               [lst (string->list (substring (list->string lst) nb-non-alpha-char (length lst)))])
          (if (= 0 nb-alpha-char)
              (loop lst)
              (cons sub-alpha-str (loop lst))))])))
    
  
  
  
  (define print-mem-labels '())
  (provide print-mem)
  (define (print-mem label thunk)
    (thunk)
    #; (begin
         (set! print-mem-labels (cons label print-mem-labels))
         (let* ([a (current-memory-use)]
                [_1 (collect-garbage)]
                [b (current-memory-use)]
                [t1 (current-inexact-milliseconds)]
                [result (call-with-values thunk (lambda args args))]
                [t2 (current-inexact-milliseconds)]
                [c (current-memory-use)]
                [_2 (collect-garbage)]
             [d (current-memory-use)])
        (printf "PM ~a ms | ~a: GC pre ~a kb | GC post ~a kb~n"
                (- t2 t1)
                (reverse print-mem-labels)
                (round (/ (- a b) 1000))
                (round (/ (- c d) 1000)))
        (set! print-mem-labels (rest print-mem-labels))
        (apply values result))))
  
  (provide print-time*)
  (define-syntax (print-time* stx)
    (syntax-case stx ()
      [(_ label exprs ...)
       (syntax/loc stx
         (let* ([start-time (current-inexact-milliseconds)]
                [result (call-with-values (lambda () exprs ...)
                                          (lambda args args))])
           (printf "~a: time ~a~n"
                   label
                   (- (current-inexact-milliseconds)
                      start-time))
           (apply values result)))]))
  
  (provide print-mem*)
  (define-syntax (print-mem* stx)
    (syntax-case stx ()
      [(_ label e ...)
       (syntax/loc stx
         (print-mem label (lambda () e ...)))]))
  
  
  (provide reverse-take)
  ;; reverse-take: (listof X) number -> (listof X)
  ;; Returns the first n elements of lst in reverse order.
  (define (reverse-take lst n)
    (let loop ([lst lst]
               [n n]
               [acc empty])
      (cond
        [(= n 0) acc]
        [else
         (loop (rest lst) (sub1 n) (cons (first lst) acc))])))
  
  (provide map*)
  ;; map*: (X -> Y) (listof X) -> (listof Y)
  ;; map, but with some care to avoid generating garbage.
  (define (map* fn elts)
    (define (fast-path lst n)
      (cond
        [(empty? lst) elts]
        [else
         (let ([result (fn (first lst))])
           (cond
             [(eq? result (first lst))
              (fast-path (rest lst) (add1 n))]
             [else (slow-path (rest lst)
                              (cons result (reverse-take elts n)))]))]))
    
    (define (slow-path lst acc)
      (cond
        [(empty? lst) (reverse acc)]
        [else
         (slow-path (rest lst)
                    (cons (fn (first lst)) acc))]))
    (fast-path elts 0))
  
  
  
  
  
  (provide id)
  ;; id : 'a -> 'a
  ;;       x ->  y
  (define (id x) x)
  
  
  (provide or* atomic? atomic/stx? gmap orgmap andgmap syntax-is-syntax? equal-syntax?)
  
  ;; or* : ('a list) -> 'a
  (define (or* args)
    (ormap id args))
  
  ;; atomic? : any -> boolean
  (define (atomic? x)
    (not (or (pair? x)
             (list? x)
             (vector? x))))
  
  ;; atomic/stx? : syntax -> boolean
  (define (atomic/stx? stx)
    (atomic? (syntax-e stx)))
  
  ;; stx->lst : syntax -> (syntax list)
  (provide/contract [stx->lst (syntax? . -> . (listof syntax?))])
  (define (stx->lst stx)
    (match (syntax-e stx)
      [(? atomic?)           empty]
      [(vector xs ...)       xs]
      [(list xs   ...)       xs]
      [(list-rest lst ... last) (append lst (list last))])) ; for things like '(a b c . d)
  
  ;; gmap : (syntax -> 'a) syntax -> ('a list)
  (define (gmap fn stx)
    (map fn (stx->lst stx)))
  
  ;; orgmap : (syntax -> 'a) syntax -> 'a
  (define (orgmap fn stx)
    (ormap fn (stx->lst stx)))
  
  ;; andgmap : (syntax -> 'a) syntax -> 'a
  (define (andgmap fn stx)
    (andmap fn (stx->lst stx)))
  
  ;; syntax-is-syntax? : syntax -> syntax -> boolean
  (define ((syntax-is-syntax? stx) sty)
    (equal-syntax? stx sty))
  
  ;; equal-syntax? : syntax syntax -> boolean
  (define (equal-syntax? stx1 stx2)
    (equal? (syntax-object->datum stx1) (syntax-object->datum stx2)))

  (provide list-equal? syntax<-symbol)
  ;; syntax<-symbol : symbol -> syntax
  (define (syntax<-symbol symbol)
    #`#,symbol)

  ;; I need it to compare 2 lists of syntax object.
  ;; list-equal? : ('a 'a -> boolean) -> ('a list) ('a list) -> boolean
  (define ((list-equal? equal?) l1 l2)
    (with-handlers ([(lambda args true) (lambda args false)])
      (andmap equal? l1 l2)))


  ;; This function converts the first element and the last element
  ;; into parenthesis, with form according to its parameter.
  (provide shape-paren)
  
  ;; shape-paren : (union false 'Round 'Square 'Curly) string -> string
  (define (shape-paren type text)
    ;; aux : char char -> string
    (define (aux open close)
      (format "~a~a~a" open (substring text 1 (sub1 (string-length text))) close))
    (match type
      [#f       text]
      ['Round  (aux #\( #\))]
      ['Square (aux #\[ #\])]
      ['Curly  (aux #\{ #\})]))
  
  
  (provide quoting-char?)
  ;; Returns true if the character appears to be a quoting char.
  (define (quoting-char? ch)
    (member ch (list #\` #\' #\, #\#)))
  
  
  ;; This function is to read the content of a file.
  ;; Use it for test ("engine.ss" of MzTake).
  (provide file->string)
  
  ;; file -> string : string -> string
  (define (file->string filename)
    (define input false)
    (dynamic-wind
     (lambda () (set! input (open-input-file filename)))
     (lambda () (list->string (let loop ([char (read-char input)])
                                (if (eof-object? char)
                                    empty
                                    (cons char (loop (read-char input)))))))
        (lambda () (close-input-port input))))


  ;; These functions are to convert a string to Scheme tree,
  ;; with syntax objects.
  (provide input->syntax-list string->syntax-list string->syntax)
  
  ;; input->syntax-list : input-port -> (syntax list)
  (define (input->syntax-list input-port)
    ;(letrec ([read-scheme-tree (lambda () (with-handlers ([list (lambda args (read-scheme-tree))]) (read-syntax 'voice:action:get-syntax input-port)))])
    (let ([read-scheme-tree (lambda () (read-syntax 'voice:action:get-syntax input-port))])
      (port-count-lines! input-port)
      (with-handlers
          ([(lambda args true)
            (lambda (exn)
              (raise (make-voice-exn "The parenthesis of the definitions text are not correctly balanced.")))])
        (let loop ([stx (read-scheme-tree)])
          (if (eof-object? stx)
              ()
              (cons stx (loop (read-scheme-tree))))))))
  
  ;; string->syntax-list : string -> (syntax list)
  (define (string->syntax-list text)
    (input->syntax-list (open-input-string text)))
  
  ;; string->syntax : string -> syntax
  (define (string->syntax text)
    (match (string->syntax-list text)
      [(list head tail ...) head]
      [_ (raise (make-voice-exn "string->syntax: empty text"))]))
  
  
  ;; Offset begins at 1 (syntax-first) for syntax object instead of 0.
  (provide syntax-first syntax-pos->index index->syntax-pos syntax-index syntax-end-position syntax-end-index pos->index index->pos syntax-position->mred-position mred-position->syntax-position)

  ;; This is from where the positions are counted in syntax-object.
  (define syntax-first (syntax-position (string->syntax "a")))
  
  (define (syntax-pos->index pos)
    (- pos syntax-first))
  
  (define (index->syntax-pos index)
    (+ index syntax-first))

  ;; Accessor for syntax element in index instead of position.
  (define (syntax-index stx)
    (syntax-pos->index (syntax-position stx)))

  ;; Accessors for the end position/index of an syntax object.
  (define (syntax-end-position stx)
    (+ (syntax-position stx)
       (syntax-span stx)))
  
  (define (syntax-end-index stx)
    (syntax-pos->index (syntax-end-position stx)))
  
  (define pos->index syntax-pos->index)
  (define index->pos index->syntax-pos)

  (define syntax-position->mred-position syntax-pos->index)
  (define mred-position->syntax-position index->syntax-pos)

  

  ;; Functions manipulating ropes.
  (provide insert-rope delete-rope replace-rope get-subrope/pos+len get-subrope/stx)
  
  ;; insert-rope : rope index rope -> rope
  (define (insert-rope a-rope index tyt)
    (rope-append* (subrope a-rope 0 index)
                  tyt
                  (subrope a-rope index)))
  
  
  ;; delete-rope : rope index int -> rope
  (define (delete-rope a-rope index len)
    (cond
      [( = len 0) a-rope]
      [(< len 0) (delete-rope a-rope (- index len) (- len))]
      [else 
       (rope-append (subrope a-rope 0 index) (subrope a-rope (+ index len)))]))
  
  
  ;; replace-rope : rope index rope int -> rope
  (define (replace-rope a-rope index tyt len)
    (print-mem*
     'replace-text
     (if (< len 0)
         (replace-rope a-rope (+ index len) tyt (- len))
         (rope-append* (subrope a-rope 0 index)
                       tyt
                       (subrope a-rope (+ index len))))))
  
  
  ;; get-subrope/stx : rope syntax -> rope
  (define (get-subrope/stx a-rope stx)
    (get-subrope/pos+len a-rope (syntax-position stx) (syntax-span stx)))
  
  
  ;; get-subrope/pos+len : rope pos integer -> rope
  (define (get-subrope/pos+len a-rope pos len)
    (if (<= 0 len)
        (subrope a-rope
                 (syntax-pos->index pos)
                 (syntax-pos->index (+ pos len)))
        (get-subrope/pos+len a-rope (+ pos len) (- len))))
  
  
  ;; get-mzcsheme-mapped-symbols: -> (listof symbol)
  ;; Returns the base symbols exposed by mzscheme.
  (provide/contract [get-mzscheme-mapped-symbols
                     (-> (listof symbol?))])
  (define (get-mzscheme-mapped-symbols)
    (namespace-mapped-symbols (make-namespace)))
  
  (provide/contract [string-convert-non-control-chars
                     (string? char? . -> . string?)])
  (define (string-convert-non-control-chars a-str a-char)
    (build-string
     (string-length a-str)
     (lambda (i)
       (let ([ch (string-ref a-str i)])
         (cond [(< (char->integer ch) 32)
                ch]
               [else a-char])))))
  
  (provide timef)
  (define (timef label thunk)
    (let-values ([(results cpu real gc)
                  (time-apply thunk empty)])
      (printf "timef ~a: cpu ~a   real ~a   gc ~a~n" label cpu real gc)
      (apply values results))))