#lang racket/base

(provide let/assert
         make-assert
         a-eq? a-!eq?
         a->? a-<=?
         a->=? a-<?
         a-=? a-!=?
         a-<0? a->=0?
         a-<=0? a->0?
         a-=0? a-!=0?
         a-true? a-false?
         a-nullptr? a-!nullptr?
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; let/assert
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define-syntax make-assert
  (syntax-rules ()
    ((_ name not-name pred)
     (begin
       (define-syntax name
         (syntax-rules ()
           ((_ const)
            (λ (x) (pred x const)))))
       (define-syntax not-name
         (syntax-rules ()
           ((_ const)
            (λ (x) (not (pred x const))))))
       )
     )
    )
  )

(make-assert a-eq? a-!eq? eq?)

(define a-nullptr? (a-eq? #f))
(define a-!nullptr? (a-!eq? #f))

(make-assert a->? a-<=? >)
(make-assert a->=? a-<? >=)
(make-assert a-=? a-!=? =)

(define (a-=0? x) (= x 0))
(define (a-!=0? x) (not (= x 0)))
(define (a->0? x) (> x 0))
(define (a->=0? x) (>= x 0))
(define (a-<0? x) (< x 0))
(define (a-<=0? x) (<= x 0))


(define a-true? (a-eq? #t))
(define a-false? (a-eq? #f))


(define-syntax let/assert*
  (syntax-rules ()
    ((_ ((v1 e1)) (b1 ...))
     (let ((v1 e1))
       b1 ...))
    ((_ ((v1 e1 assert1 ret1)) (b1 ...))
     (let ((v1 e1))
       (cond ((assert1 v1)
              b1 ...)
             (else ret1))))
    ((_ ((v1 e1) r ...) (b1 ...))
     (let ((v1 e1))
       (let/assert* (r ...) (b1 ...))))
    ((_ ((v1 e1 assert1 ret1) r ...) (b1 ...))
     (let ((v1 e1))
       (cond ((assert1 v1)
              (let/assert* (r ...) (b1 ...)))
             (else ret1))))
    )
  )

(define-syntax let/assert
  (syntax-rules ()
    ((_ (a1 ...) b1 ...)
     (let/assert* (a1 ...) (b1 ...))
     )
    )
  )