#| A sample teachpack, which contains some useful macros.
   See "how to use scheme" -- htus.org -- for further info
   on topics like macros, reading from files, xml, etc.
 |#
(module util-macros (lib "plt-pretty-big.ss" "lang")
  (provide 

   define/opt ; A macro, allowing optional (default) arguments.  Contract below.
   warn       ; Like "error", but non-fatal.  Contract below.
   assert     ; Print message if the assumption is untrue.  Contract below.

   ; Some numeric functions
   round-to      ; num, int --> num
   practically=? ; num, num, [num] --> boolean
   )

  ;; round-to: num int --> num
  ;; Round x to the nearest place'th decimal.
  ;; (round-to 3.1415926 4) = 3.1416
  ;; (round-to 5678.9 -2)   = 5700
  ;; If place is 0, this is the same as round.
  ;; Note: answer is always INEXACT.
  ;;
  (define (round-to x place)
    (let* {[shift-factor (expt 10 place)]}
      (/ (round (* x shift-factor)) shift-factor)))
      ;
      ; You can look up "let*" in help-desk.
      ; It's reminiscent of "local", except that it
      ; lets you omit the word "define".

  

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; 
  ;; A macro -- it evaluates *before* any regular law-of-scheme evaluation.
  ;; This example is *not* meant to be sufficient for you to write your own macros.

  ;; define/opt: like define, but allow optional arguments.
  ;; This is essentially provided by opt-lambda (see helpdesk);
  ;; the macro simply translates a "define/opt" into "opt-lambda".
  ;;
  (define-syntax (define/opt the-defn)
    (syntax-case the-defn ()
      [(define/opt (func-name . formals) body ...)
       (syntax (define func-name (opt-lambda formals body ...)))]))

  ; Example:
  ; ;; my-log: num, [num] --> num
  ; ;; Return log of x, base b (default base: 10).
  ; ;;
  ; (define/opt (my-log x [b 10]) (/ (log x) (log b)))
  ;
  ; While you can have several optional arguments,
  ; you can't have a non-optional-argument *after* an optional one.
  ; (Again, see opt-lambda in helpdesk).
  ;


  ;; practically=?: number, number -> boolean
  ;;                number, number, number -> boolean
  ;; Are a and b numerically equal, up to tolerance (the optional third argument)?
  ;; The tolerance is a relative fraction of b.
  ;; Note that +inf.0 is practically=? to itself (but nothing else is),
  ;; and +nan.0 and -nan.0 are practically=? (?!) (since they are eqv?).
  ;;
  (define/opt (practically=? a b [tolerance 0.0005])
    (begin
      (unless (and (real? tolerance) (not (negative? tolerance)))
              (raise-type-error 'practically=? "non-negative real" tolerance))
      (or (< (abs (- a b)) (abs (* tolerance b)))
          (eqv? a b)             ; This eqv? handles inf and nan correctly. 
          (= a b)                ; This =    handles tolerance of 0 correctly.
          )))
          ; We use < and not <=, because we never want 4 and +inf.0 practially equal.
          ; Note that as one would hope, a tolerance of 0 to collapse to =.
          ; Although the < branch will fail when tolerace 0,
          ; the = branch will succeed.


  ;; false?: ANY --> boolean
  ;; Is x the boolean false?
  ;; A handy helper.
  ;;
  (define (false? x) (and (boolean? x) (not x)))


  ;; warn: print a message to stderr.  (Like error, but non-fatal.)
  ;; proc-name: symbol, or false (meaning print nothing)
  ;; msg: string
  ;; msg-info: ANY...
  ;;
  ;; Example: (warn 'some-func "Potential problem with ~v and ~v." x y)
  ;;
  (define/opt (warn proc-name [msg "[No details provided.]"] . msg-info)
    (begin
      (fprintf (current-error-port) "Warning: ")
      (unless (false? proc-name) (fprintf (current-error-port) "~v: " proc-name))
      (fprintf (current-error-port) (apply format msg msg-info))
      (newline (current-error-port))))


  ;; assert: expr --> (void)
  ;; assert: expr string expr.. --> (void)
  ;;
  ;; Assert that some boolean expression holds.
  ;; If it doesn't, we print a diagnostic message, but continue.
  ;; The second form uses a format string and values (like printf).
  ;;
  ;; Example:
  ;; (define (length=1? lst)
  ;;   (begin
  ;;     (assert (list? lst) "Uhoh -- length=1? called on the non-list ~v." lst)
  ;;     (and (cons? lst) (empty? (rest lst)))))
  ;;
  (define-syntax (assert prop)
    (syntax-case prop ()
      [(_ expr)
       (syntax (unless expr (warn false "assert failed: ~v [line ~v]"
                                  (quote expr)
                                  (syntax-line (syntax expr)))))]
      [(_ expr msg args ...)
       (syntax (unless expr (warn false (string-append "assert failed: " msg " [line vs: ~v]")
                                  args ... 
                                  (syntax-line (syntax expr))
                                  (quote expr))))]
      ))

  )