;;; $Id: sutil.scm,v 1.1.1.1 2006/05/27 16:31:17 hoesterholt Exp $

(module sutil mzscheme
  (require (lib "pregexp.ss" "mzlib"))
  (require (lib "file.ss" "mzlib"))
  (require (lib "list.ss" "mzlib"))
  (require (lib "time.ss" "srfi" "19"))
  (provide glob
           basename
           basedir
           home
           mkdir-p
           
           meta-apply
           
           post++
           ++
           
           while
           
           date<?
           date>?
           date=?
           date<=?
           date>=?
           
           leap-year?
           valid-date?
           
           (all-from (lib "list.ss" "mzlib"))
           )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Documentation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;=pod

;=syn scm,8

;=wikiwikiwiki

;=Name

;=SUtils - Various Utility Functions

;=Synopsis

;
;  Welcome to MzScheme version 300, Copyright (c) 2004-2005 PLT Scheme Inc.
;  > (require (planet "sutil.scm" ("oesterholt"  "ho-utils.plt"  1 0)))
;  > (glob "d:/build/sutil/*.scm")
;  ("d:/build/sutil/scfg.scm" "d:/build/sutil/sprefs.scm" "d:/build/sutil/sutil.scm" "d:/build/sutil/units.scm")
;  > (glob "d:/build/sutil/*.pod")
;  ("d:/build/sutil/index.pod" "d:/build/sutil/index.pod~")
;  > (glob "d:/build/sutil/*.pod$")
;  ("d:/build/sutil/index.pod")
; 
;  > (basename "d:/build/sutil/index.pod")
;  "index.pod"
;  > (basedir (build-path "d:/build/sutil/index.pod"))
;  "d:/build/sutil/"
; 
; 
;  > (home)
;  "C:\\Documents and Settings\\hdijkema\\."
; 
;  > (home "local" "test")
;  "C:\\Documents and Settings\\hdijkema\\local\\test"
; 
;  > (mkdir-p (home "local" "test"))
;  <executes make-directory* if directory doesn't exist already>
;
;  > (define a 10)
;  > (post++ a)
;  10
;  > a
;  11
;  > (++ a)
;  12
;  a
;  12
; 
;  >(require (lib "time.ss" "srfi" "19"))
;  >(define a (current-date));
;  >(sleep 3)(define b (current-date));
;  >(date<? a b)
;  #t
;  >(date>? a b)
;  #f
;  ;; And we've also got 'date<=?', 'date>=?' and 'date=?'
;
;=API
;
;This API is not described. The Synopsis should suffice.

;=Info
;
;(c) 2005 Hans !Oesterholt-Dijkema. Distributed undef LGPL.
;Contact: send email to hans in domain elemental-programming.org.
;Homepage: [http://www.elemental-programming.org].
;

;=wikiwikiwiki

;=cut
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Some Date predicates to extend srfi 19
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (date<? dt1 dt2)
    (time<? (date->time-utc dt1) (date->time-utc dt2)))
  
  (define (date>=? dt1 dt2)
    (not (date<? dt1 dt2)))
  
  (define (date>? dt1 dt2)
    (time>? (date->time-utc dt1) (date->time-utc dt2)))
  
  (define (date<=? dt1 dt2)
    (not (date>? dt1 dt2)))

  (define (date=? dt1 dt2)
    (time=? (date->time-utc dt1) (date->time-utc dt2)))
  
  (define (leap-year? dt)
    (let ((year (if (number? dt) dt (date-year dt))))
      (if (= (remainder year 4) 0)
          (if (= (remainder year 100) 0)
              (if (= (remainder year 1000) 0)
                  #t
                  #f)
              #t)
          #f)))
  
  (define (valid-date? year month day)
    (let ((days (vector 0 31 (if (leap-year? year) 29 28) 31 30 31 30 31 31 30 31  30 31)))
      (if (or (< month 1) (> month 12))
          #f
          (if (or (< day 1) (> day (vector-ref days month)))
              #f
              #t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; glob on files using regular expressions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (do-normalize-path p)
  (let ((s (if (string? p) 
	       p 
	       (path->string p))))
    (let ((N (string-length s)))
      (do ((i 0 (+ i 1)))
	  ((>= i N) s)
	(if (char=? (string-ref s i) #\\)
	    (string-set! s i #\/)))
      s)))

(define (replaces p L)
  (if (null? L)
      p
      (let ((from (caar L))
	    (to   (cadar L)))
	(replaces (pregexp-replace* from p to)
		  (cdr L)))))

(define (glob-files closure path)
  (for-each (lambda (p)
	      (let ((pp (build-path path p)))
		(if (directory-exists? pp)
		    (closure pp 'dir)
		    (closure pp 'file))))
	    (directory-list path)))

(define (glob pattern)
  (let* ((patt  (do-normalize-path (normalize-path pattern)))
	 (bd    (basedir patt))
	 (p     (replaces patt (list '("^[.]"    "[.]")
				     '("([^[])[.]" "\\1[.]")
				     '("[*]"     ".*")
				     '("[?]"     "."))))
	 (exp   (pregexp p))
	 (found (list)))

    (glob-files (lambda (path type)
		  (if (eq? type 'file)
		      (let ((pp (do-normalize-path path)))
			(if (not (eq? (pregexp-match exp pp) #f))
			    (set! found (cons pp found))))))
		bd)
    (reverse found)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; basename/basedir on files using regular expressions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (basedir path)
  (if (directory-exists? path)
      (do-normalize-path path)
      (call-with-values
	  (lambda () (split-path path))
	(lambda (base name is-dir)
	  (if (eq? base 'relative)
	      "." 
	      (if (eq? base #f)
		  "/"
		  (do-normalize-path base)))))))

(define (basename path)
  (if (directory-exists? path)
      ""
      (call-with-values
	  (lambda () (split-path path))
	(lambda (base name is-dir)
	  (if (eq? name 'up)
	      "."
	      (if (eq? name 'down)
		  ".."
		  (do-normalize-path name)))))))


(define (home . path)
  (let ((p (if (null? path)
	       (list 'same)
	       path)))
    (path->string 
     (apply build-path (list (find-system-path 'home-dir) (apply build-path p))))))

(define (mkdir-p path)
  (if (not (directory-exists? path))
      (make-directory* path)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; meta-apply applies for functions with optional arguments to functions
;;; with optional arguments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (meta-apply f . args)
  (define (mklist args)
    (if (null? (cdr args))
	(if (list? (car args))
	    (car args)
	    args)
	(cons (car args) (mklist (cdr args)))))
  (apply f (mklist args)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Increment a variable while returning the original value
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax post++
  (syntax-rules ()
    ((_ n)
     (let ((r n))
       (set! n (+ n 1))
       r))))

(define-syntax ++
  (syntax-rules ()
    ((_ i)
     (begin
       (set! i (+ i 1))
       i))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Implement while
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax while
  (syntax-rules ()
    ((_ expression b1 ...)
     (do
	 ()
	 ((not expression)
	  #t)
       (begin b1 ...)))))


)