#lang scheme

(provide (all-defined-out))

;[:title Common Scheme Utilities]

;: This module provides some useful functions and forms
;: that are common to most of the files of this package
;: and other future packages.

;[:add-convention re pregexp?]
;[:add-convention path path?]


(define-syntax-rule (++ var) ;: Increments $var.
  (set! var (add1 var)))

(define-syntax-rule (-- var) ;: Decrements $var.
  (set! var (sub1 var)))

(define (box-me b ;: box?
                val) ;:-> (one-of/c val)
  ;: Puts $val in the box $b and returns $val.
  ;: Useful to return a value and box it as a side effect.
  (set-box! b val) val)

;(define (identity x . r) ;:-> (one-of/c x)
(define (identity x . r) ;:-> (one-of/c x)
  ;: Returns only the first of the parameters.
  x)

(define (symetric fxy) ;:-> procedure?
  ;: [fxy procedure?]
  ;: Returns the symetric function of $fxy.
  (λ(x y)(fxy y x)))

(define (to-proc x) ;:-> procedure?
  ;: Returns a procedure that accepts any number of arguments and returns $x.
  ;: If $x was already a procedure, returns $x without change.
  (if (procedure? x) x (λ args x)))

(define (get-type x) ;:-> (listof procedure?)
  ;: Returns (some of) the types that $x matches.
  (map proc->string
       (filter (λ(t)(t x))
               (list symbol? boolean? string? number? list? procedure? parameter?))))
;  we could also use a tree with subtypes, like exact? integer? etc.
;[:examples]
; (get-type '(a b c))
; (get-type 101)
; (get-type get-type)
;[:end-examples]

;;;;;;;;;;;;;;;;;
;;;   Lists   ;;;
;;;;;;;;;;;;;;;;;
;[:section Lists]


(define (transpose ll) ;:-> (listof list?)
  ;: Transposes a list of lists.
  (apply map list ll))
;[:examples]
;(transpose '((a b c) (0 1 2)))
;[:end-examples]

(define (list-choose l) 
  ;: Chooses one element from $l.
  (list-ref l (random (length l))))
;[:examples]
; (list-choose '(a b c d e f g h i j))
; (list-choose '(a b c d e f g h i j))
; (list-choose '(a b c d e f g h i j))
;[:end-examples]

(define (mean . n) ;:-> number?
  ;: Returns the average value of the $n.
  (/ (apply + n) (length n)))

(define (list-set l n v) ;:-> list?
  ;: Returns the same list $l where element at position $n
  ;: is replaced by $v.
  (let-values ( [(t d) (split-at l n)] )
    (append t (list v) (rest d))))
;[:examples]
; (list-set '(a b c d e) 3 'huh?)
;[:end-examples]

(define (list->lines l sep) ;:-> (listof? list?)
  ;: Splits a list into "lines" (list of lists).
  (foldr (λ(x acc)(if (equal? x sep)
                      (cons '() acc)
                      (cons (cons x (first acc)) (rest acc))))
         '(())
         l))
;[:examples]
;(list->lines '(a b c x d e x x f g h x o) 'x)
;[:end-examples]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   Functions and Applications   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;[:section Functions and Applications]

(define (argbest proc lst) 
  ;: Returns the best element of $lst.
  ;: Each challenger is compared to the best value with $proc.
  ;: If $proc returns $#t, the best wins.
  (foldl (λ(chall best)(if (proc best chall) best chall))
         (first lst)
         (rest lst)))
;[:examples]
;(argbest < '(5 2 5 7 8 1 5))
;(argbest > '(5 2 5 7 8 1 5))
;(argbest (λ(best chall)
;           (and (<= (first best) (first chall))
;                (< (second best) (second chall))))
;         '((3 6)(7 2)(8 3)(3 5)(3 7)))
;[:end-examples]

(define (map/apply proc . ll) ;:-> list?
  ;: Applies $proc to each list element of $ll.
  (map (λ(l)(apply proc l)) ll))
;> (map/apply + '(1 2 3) '(4 5 6))
;(6 15)

(define (for-each/apply proc . ll) ;:-> void?
  ;: Like $map/apply but with $for-each.
  (for-each (λ(l)(apply proc l)) ll))


(define (ntimes n proc) ;:-> void?
  ;: Does $proc $n times.
  (for-each proc (build-list n values)))

(define-syntax-rule (times n val-max body ...)
  ;: Binds $n to the values from 0 to $val-max while doing $body ...
  (let loop ([n 0])
    (when (< n val-max)
      body ...
      (loop (+ n 1)))))

;;;;;;;;;;;;;;;;;;;
;;;   Vectors   ;;;
;;;;;;;;;;;;;;;;;;;
;[:section Vectors]
 
(define-syntax-rule (with-vector lst-id body ...)
  ;: Temporarily turns $lst-id into a vector, does $body ...
  ;: then turns it back to a list
  (begin
    (set! lst-id (list->vector lst-id))
    (begin0 (begin body ...)
            (set! lst-id (vector->list lst-id)))))

(define (vector-clone v)
  (build-vector (vector-length v) (λ(i)(vector-ref v i))))


;;;;;;;;;;;;;;;;;;;
;;;   Strings   ;;;
;;;;;;;;;;;;;;;;;;;
;[:section Strings]

(define (to-string x) ;:-> string?
  ;: Turns any value into a string.
  (format "~a" x))

(define (protect-string x) ;:-> string?
  ;: Turns any value into a string.
  ;: If $x is already a string, quotes its quotes.
  (with-output-to-string (λ()(write x))))
;[:examples]
; (protect-string "the string \"plop\" is a string.")
;[:end-examples]

(define (trim s [left 0] [right left]) ;:-> string?
  ;: [left number?]
  ;: [right number?]
  ;: Removes left and right characters from $s.
  (substring s left (- (string-length s) right)))
;[:examples]
; (trim "abcdefghij" 3 1)
;[:end-examples]

(define (string-reverse str) ;:-> string?
  ;: Reverses $str.
  (list->string (reverse (string->list str))))
;[:examples]
; (string-reverse "emordnilap a ton ma I")
;[:end-examples]

(define (string->lines str [sep "\n"]) ;:-> (listof string?)
  ;: [sep string?]
  ;: Splits $str at $sep.
  (regexp-split sep str))
;[:examples]
; (string->lines "One\nTwo Three\nFour")
;[:end-examples]

;[:convention re (or/c string? pregexp? regpexp?)]
(define (regexp-matcher re) ;:-> procedure?
  ;: Returns a procedure that matches $re.
  (λ(s)(regexp-match re s)))
;[:examples]
; (map (regexp-matcher "pl(.)p") '("aplipa" "youp" "coplop"))
;[:end-examples]

;[:convention text string?]
(define (comment-section text 
                         #:pre [pre ";;;   "] 
                         #:post [post (string-reverse pre)]) ;:-> void?
  ;: [pre string?]
  ;: [post string?]
  ;: Displays a comment string that can be copied into the source file.
  ;: The width of the result depends on the with of $text.
  (let* ( [w (string-length text)]
          [pre-w (string-length pre)]
          [post-w (string-length post)]
          [total-w (+ w pre-w post-w)] )
    (display
     (string-append (make-string total-w #\;) "\n"
                    pre text post "\n"
                    (make-string total-w #\;) "\n"))))
;[:examples]
;(comment-section "And now for something completely different")
;[:end-examples]

(define (comment-chapter text [pre "   "] [post (string-reverse pre)]
                         #:width [width 80]) ;:-> void?
  ;: [pre string?]
  ;: [post string?]
  ;: [width number?]
  ;: Similar to $comment-section but the width of the result
  ;: does not depend on the width of $text.
  (let* ( [w (string-length text)]
          [pre-w (string-length pre)]
          [post-w (string-length post)]
          [w-left (inexact->exact (floor (/ (- width w pre-w post-w) 2)))]
          [w-right (inexact->exact (ceiling (/ (- width w pre-w post-w) 2)))]
          )
    (display
     (string-append (make-string width #\;) "\n"
                    (make-string width #\;) "\n"
                    (make-string w-left #\;) 
                    pre text post (make-string w-right #\;) "\n"
                    (make-string width #\;) "\n"
                    (make-string width #\;) "\n"))))
;;[:remove-convention text]

;[:examples]
;(comment-chapter "The Show Sets Sales"
;  #:width 60)
;[:end-examples]

(define (proc->string proc) ;:-> string?
  (trim (to-string proc) (string-length "#<procedure:") 1))
;[:examples]
;(proc->string proc->symbol)
;[:end-examples]

(define (proc->symbol proc) ;:-> symbol?
  (string->symbol (proc->string proc)))
;[:examples]
;(proc->symbol proc->symbol)
;[:end-examples]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   Files and Directories   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;[:section Files and Directories]

;[:convention files (listof (or/c string? path?))]

(define (directory-list-rec [path (current-directory)]) ;:-> files
  ;: Returns the list of files and directory contained in $path,
  ;: recursively including sub-directories.
  ;: The files are returned with their full path.
;  (printf "dir: ~a~n" path)
  (let ([dir-list (map (λ(f)(build-path path f)) (directory-list path))])
;    (printf "files: ~a~n" dir-list)
    (foldl (λ(f acc)(if (directory-exists? f)
                        (append acc (directory-list-rec f))
                        acc))
           dir-list
           dir-list)))

(define (filter-file-list re [files (directory-list)]) ;:-> files
  ;: Filters the list of files $files with the regexp $re.
  (filter (λ(f)(regexp-match re (to-string f))) files))
;[:examples]
;(filter-file-list "parser\\.ss$" (directory-list))
;[:end-examples]

(define (file->lines/latin-1 file) ;:-> (listof string?)
  ; Like $file->lines but text is read in latin-1 character set.
  (map bytes->string/latin-1
       (with-input-from-file file
         (λ()(port->bytes-lines)))))

(define (file->name-ext file) 
  ;: Returns two values: the name part of the file and the extension part, without the dot.
  (apply values (rest (regexp-match "(.*)\\.([^\\.]+)" file))))
;[:examples]
;(file->name-ext "common.scm.ss")
;[:end-examples]


(define (path->quote-string path) ;:-> string?
  ;: Returns the path as a string, and surround it with double-quotes
  ;: if it contains spaces.
  (let ([path (if (path? path) (path->string path) path)])
    (if (regexp-match " " path)
        (string-append "\"" path "\"")
        path)))
;[:examples]
; (path->quote-string "C:\\Program Files\\PLT")
; (path->quote-string "~/scheme/cabbages")
;[:end-examples]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   Classes and Objects   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;[:section Classes and Objects]

(define-syntax map/send ; not yet parsed by defs-parser...
  ; BFN grammar ?
  (syntax-rules ()
    [(_ (args ...) lst) 
     (map (lambda(x)(send x args ...)) lst)]
    [(_ arg lst)
     (map (lambda(x)(send x arg)) lst)]))

;: @defform/subs[(map/send message obj ...)
;:               ([message method (method arg ...)])
;: ]{
;: Sends $method along with its arguments
;: to each object and returns the list of results.
;: }
;:
;: For example
;: @schemeblock[(map/send my-method (list obj1 obj2 obj3))]
;: is equivalent to
;: @schemeblock[(map (λ(x)(send x my-method)) (list obj1 obj2 obj3))]
;: and
;: @schemeblock[(map/send (my-method 3 5) (list obj1 obj2 obj3))]
;: is equivalent to
;: @schemeblock[(map (λ(x)(send x my-method 3 5)) (list obj1 obj2 obj3))]

(define-syntax for-each/send
  (syntax-rules ()
    [(_ (args ...) lst) 
     (for-each (lambda(x)(send x args ...)) lst)]
    [(_ arg lst)
     (for-each (lambda(x)(send x arg)) lst)]))

;: @defform[(for-each/send method obj ...)]{
;: Like $map/send but returns @scheme[(void)].
;: }