#lang scheme

(require teachpack/htdp/image
         (only-in lang/htdp-advanced image? posn?))

(define (make-fake-random . nums)
  (let ([nums (box nums)]
        [ndx (box 0)])
    (λ (m)
      (cond [(null? (unbox nums)) 
             (error 'make-fake-random "out of numbers after consuming ~s numbers" (unbox ndx))]
            [(>= (car (unbox nums)) m)
             (error 'make-fake-random "expected number less than ~s but got ~s" 
                    m (car (unbox nums)))]
            [else 
             (begin0
               (car (unbox nums))
               (set-box! nums (cdr (unbox nums)))
               (set-box! ndx (add1 (unbox ndx))))]))))

(define (find-image/00 image subimage)
  (find-image (put-pinhole image 0 0) (put-pinhole subimage 0 0)))

(define-syntax (check-property stx)
  (syntax-case stx ()
    [(_ times pred arg-list)
     (begin
       (unless (memq (syntax-local-context) '(top-level module module-begin))
         (raise-syntax-error 'check-property "must be at the top-level" #'stx))
       (unless (let ([t (syntax-e #'times)])
                 (and (number? t) (integer? t) (positive? t)))
         (raise-syntax-error 'check-property "expected natural number" #'stx #'times))
       (with-syntax ([loc (syntax-line stx)])
         (syntax
          (let ([p pred])
            (unless (procedure? p)
              (error 'check-property "expects type <procedure> as 2nd argument, given ~s" p))
            (let loop ([remain times])
              (when (zero? (modulo remain 25)) (collect-garbage))
              (if (zero? remain)
                  (printf "line ~a: ~a attempts and no failures yet.\n" loc times)
                  (let ([args arg-list])
                    (if (apply p args)
                        (loop (sub1 remain))
                        (begin
                          (printf "line ~e: found a failure! Expression that fails: \n(~a" 
                                  loc (if (object-name pred) 
                                          (object-name pred)
                                          'unnamed))
                          (for-each (λ (a) (printf "\n ") (print a)) args)
                          (printf ")\n"))))))))))]))

(provide check-property)

(provide/contract (find-image/00 (-> image? image? posn?))
                  (make-fake-random (->* () () #:rest (listof natural-number/c) 
                                    (-> natural-number/c natural-number/c))))