;;; chicanery extras --- extra stuff from ur old pal acdw

(export list-map list-for-each list-append
        map for-each append)

;;; Generalized map, for-each, ...
;; List versions are renamed `list-<function>'.  Un-prefixed versions work
;; with any (default) datatype.  TODO: generalize?
(define list-map map)
(define list-for-each for-each)
(define list-append append)

(define (map proc . collections)
  (let ((first (car collections)))    ; we only need to check the first one
    (cond
     ((list? first)
      (apply list-map proc collections))
     ((vector? first)
      (apply vector-map proc collections))
     ((string? first)
      (apply string-map proc collections))
     (else (error "Bad datatype" first)))))

(define (for-each proc . collections)
  (let ((first (car collections)))    ; we only need to check the first one
    (cond
     ((list? first)
      (apply list-for-each proc collections))
     ((vector? first)
      (apply vector-for-each proc collections))
     ((string? first)
      (apply string-for-each proc collections))
     (else (error "Bad datatype" first)))))

(define (append . collections)
  (let ((first (car collections)))    ; we only need to check the first one
    (cond
     ((list? first)
      (apply list-append collections))
     ((vector? first)
      (apply vector-append collections))
     ((string? first)
      (apply string-append collections))
     ((bytevector? first)
      (apply bytevector-append collections))
     (else (error "Bad datatype" first)))))

(export ref
        copy)

;;; Extended generic functions.
;; These functions already have a list- version defined, but no non-prefixed
;; one.  So I'm fixing that.
(define (ref collection k)
  (cond
   ((list? collection)
    (list-ref collection k))
   ((vector? collection)
    (vector-ref collection k))
   ((string? collection)
    (string-ref collection k))
   ((bytevector? collection)
    (bytevector-u8-ref collection k))
   (else (error "Bad datatype" collection))))

;; I'm not going to generalize -copy! because I don't think it's a great idea,
;; really.
(define (copy collection)
  (cond
   ((list? collection)
    (list-copy collection))
   ((vector? collection)
    (vector-copy collection))
   ((string? collection)
    (string-copy collection))
   ((bytevector? collection)
    (bytevector-copy collection))
   (else (error "Bad datatype" collection))))

;;; Functions that should be in scheme
;; This sections should be as small as possible

(export read-port
        read-port-chunk-size)

(define read-port-chunk-size
  (make-parameter 512))

(define (%read-port port)
  (let ((chunk-size (read-port-chunk-size)))
    (let loop ((next (read-string chunk-size port))
               (blank? #f)
               (acc '()))
      (cond
       ((or (eof-object? next)
            (and blank? (equal? next "")))
        (apply string-append (reverse acc)))
       ((equal? next "")
        (loop (read-string chunk-size port)
              #t
              (cons next acc)))
       (else
        (loop (read-string chunk-size port)
              blank?
              (cons next acc)))))))

(define read-port
  (case-lambda
    (() (%read-port (current-input-port)))
    ((p) (%read-port p))))

(export atom? defined?)

(define (atom? x)
  (not (or (null? x)
           (pair? x))))

(define (defined? sym)
  (call-with-current-continuation
   (lambda (k)
     (with-exception-handler
         (lambda (e) (k #f))
       (lambda ()
         (eval sym (interaction-environment))
         #t)))))

(export with-output-to-string
        with-input-from-string)

(define (with-output-to-string thunk)
  (call-with-port (open-output-string)
    (lambda (port)
      (parameterize ((current-output-port port))
        (thunk))
      (get-output-string port))))

(define (with-input-from-string s thunk)
  (call-with-port (open-input-string s)
    (lambda (port)
      (parameterize ((current-input-port port))
        (thunk)))))

(export displayed ->string written print)

(define (displayed x)
  (with-output-to-string
    (lambda () (display x))))

(define (written x)
  (with-output-to-string
    (lambda () (write x))))

(define (print . xs)
  (for-each display xs)
  (newline))

(define ->string displayed)