(define-syntax trace
  (syntax-rules ()
    ((trace x)
     (begin
       (write (quote x))
       (display " => ")
       (write x)
       (newline)
       x))))

(define (super-cons x res)
  (if (null? x)
      (reverse res)
      (super-cons (cdr x) (cons (car x) res))))

(define-syntax define-data
  (syntax-rules ()
    ((_ type (arg . args))
     (begin
       (for-each (lambda (i)
                   (begin
                     (eval `(define (,(car i) x . xx)
                              (list->vector (cons 'type (cons ',(car i) (cons x (super-cons xx '())))))) (interaction-environment)))) (cons 'arg 'args))
       (eval `(define (,(string->symbol (string-append (symbol->string 'type) (symbol->string '?))) x)
                (and (vector? x) (equal? 'type (vector-ref x 0)) (> (vector-length x) 2))) (interaction-environment))
       ))))

(define (search true list)
  (let ((cur (caar list)))
    (if (and (list? cur) (equal? (car cur) (vector-ref true 1)) (= (length cur) (- (vector-length true) 1)))
        (let ((val (cddr (vector->list true)))
              (def (cdr cur))
              (expr (cadr (car list))))
          (apply (lambda def expr) val))
        (search true (cdr list)))))

(define-syntax match
  (syntax-rules ()
    ((_ true arg . args)
     (search true (cons 'arg 'args)))))

(begin
  (define-data figure ((square a)
                       (rectangle a b)
                       (triangle a b c)
                       (circle r)))

  (define s (square 10))
  (define r (rectangle 10 20))
  (define t (triangle 10 20 30))
  (define c (circle 10))

  (define test-1 (and (figure? s)
                      (figure? r)
                      (figure? t)
                      (figure? c)))

  (define a '(circle 0 0 1))
  (define b #f)

  (define test-2 (and (figure? a)
                      (figure? b)))

  (define pi (acos -1))

  (define (perim f)
    (match f
      ((square a)       (* 4 a))
      ((rectangle a b)  (* 2 (+ a b)))
      ((triangle a b c) (+ a b c))
      ((circle r)       (* 2 pi r))))

  (list test-1
        test-2
        (perim s)
        (perim r)
        (perim t)
        (round (perim c)))
  ) ; end