#lang scheme
;; utils.ss
;; Various utilities for VisualScheme

(provide identity
         assert
         case*
         display*
         princ-to-string
         ensure-list
         unfold
         curry
         vector-map

         log)

(define (identity x)
  x)


(require [rename-in [only-in rnrs/base-6 assert]
                    [assert r6:assert]])

(define-syntax assert
  (syntax-rules ()
    [(assert datum ...)
     (r6:assert (and datum ...))]))


(define-syntax case* ;; A rose, by any other name would smell as sweet... :D
  (syntax-rules ()
    [(case* expr clauses ...)
     (let ((val expr))
       (case*-aux val clauses ...))]))

(define-syntax case*-aux
  (syntax-rules (=> else)
    [(case*-aux val (else => f))
     (f val)]
    [(case*-aux val (else stmt ...))
     (begin stmt ...)]
    [(case*-aux val (f => f2))
     (if (f val)
         (f2 val)
         #f)]
    [(case*-aux val (f stmt ...))
     (if (f val)
         (begin stmt ...)
         #f)]
    [(case*-aux val (f => f2) clauses ...)
     (if (f val)
         (f2 val)
         (case*-aux val clauses ...))]
    [(case*-aux val (f stmt ...) clauses ...)
     (if (f val)
         (begin stmt ...)
         (case*-aux val clauses ...))]))


(define (display* . args)
  (for-each display args)
  (newline))


(define (princ-to-string object)
  (let ([o (open-output-string)])
    (fprintf o "~a" object)
    (get-output-string o)))


(define (ensure-list l)
  (if (list? l)
      l
      (list l)))


(define-syntax log
  (syntax-rules ()
    [(_ test arg ...)
     (when test
       ((lambda ()
          (display* arg ...))))]))

(define (unfold p f g seed . rest)
  (let ([tail-gen (if (null? rest)
                      (lambda (x) '())
                      (first rest))])
    (if (p seed)
        (tail-gen seed)
        (cons (f seed)
              (unfold p f g (g seed))))))

(define (curry f . cargs)
  (lambda args
    (apply f (append cargs args))))

;; SRFI 43 didn't work...
(define (vector-map f v)
  (let ([res (make-vector (vector-length v))])
    (let loop
      ([i (sub1 (vector-length v))])
      (if (negative? i)
          res
          (begin (vector-set! res i (vector-ref v i))
                 (loop (sub1 i)))))))