
; (require-library "errortrace.ss" "errortrace")
(require (lib "list.ss")
	 (lib "etc.ss")
	 (lib "class100.ss")
	 (lib "defmacro.ss"))

(define example-list%
  (class100 object% (-name-in -parents [-filter (lambda (x) (not (void? x)))])
    (private-field
       [name-in -name-in]
       [parents -parents]
       [filter -filter]
       [name name-in]
       [items '()]
       [num-items 0]
       [baddies null]
       
       [parents-count 
	(if parents
	    (map (lambda (parent)
		   (send parent get-count))
		 parents)
	    '())]
       [parents-choose
	(if parents
	    (map (lambda (parent)
		   (send parent get-choose-example))
		 parents)
	    '())])
      (public
       [get-count (lambda () (lambda () (count)))]
       [get-name (lambda () name)]
       [get-choose-example (lambda () (opt-lambda ([which #f]) (choose-example which)))]
       [choose-parent-example
	(lambda (which)
	  (let loop ([pos which][counts parents-count][chooses parents-choose])
	    (if (null? counts)
		(void)
		(let ([c ((car counts))])
		  (if (< pos c)
		      ((car chooses) pos)
		      (loop (- pos c) (cdr counts) (cdr chooses)))))))]

       [count 
	(lambda () (+ num-items (apply + (map (lambda (x) (x)) parents-count))))]
       [set-filter
	(lambda (f)
	  (set! filter f))])
      (private-field
       [prepare values])
      (public
       [set-prepare
	(lambda (f)
	  (set! prepare f))]
       [add
	(lambda (x)
	  (if (filter x)
	      (begin
		(set! num-items (add1 num-items))
		(set! items (cons x items)))
	      (error 'add "rejected: ~a in: ~a" x name)))]
       [all-examples
	(lambda ()
	  (apply append items (map (lambda (p) (send p all-examples)) parents)))]
       [choose-example
	(opt-lambda ([which #f])
	  (let ([n (if which 
		       which
		       (let ([c (count)])
			 (if (zero? c)
			     0
			     (random c))))])
	    (if (< n num-items)
		(prepare (list-ref items n))
		(choose-parent-example (- n num-items)))))]
       [add-bad
	(lambda (i)
	  (set! baddies (cons i baddies)))]
       [bad-examples
	(lambda () baddies)])
      (sequence (super-init))))

(define boxed-example-list%
  (class100 object% (-parent)
    (private-field [parent -parent])
    (public
     [get-name (lambda () `(boxed ,(send parent get-name)))]
     [all-examples
      (lambda ()
	(let ([l (map box (send parent all-examples))])
	  l))]
     [choose-example
      (opt-lambda ([which #f])
	(let ([ex (send parent choose-example)])
	  (if (void? ex)
	      (void)
	      (box ex))))]
     [bad-examples
      (lambda () (cons 5 (map box (send parent bad-examples))))])
    (sequence (super-init))))

(define listed-example-list%
  (class100 object% (-parent)
    (private-field [parent -parent])
    (public
     [get-name (lambda () `(listed ,(send parent get-name)))]
     [all-examples
      (lambda ()
	(let ([l (map list (send parent all-examples))])
	  l))]
     [add
      (lambda (v)
	(unless (list? v)
	  (error 'add "rejected: ~a in: ~a" v name))
	(for-each
	 (lambda (i)
	   (send parent add i))
	 v))]
     [choose-example
      (opt-lambda ([which #f])
	(let ([ex (send parent choose-example)])
	  (if (void? ex)
	      (void)
	      (list ex))))]
     [bad-examples
      (lambda ()
	(cons 5 (map list (send parent bad-examples))))])
    (sequence (super-init))))

(define optional-example-list%
  (class100 object% (-parent -val)
    (private-field [parent -parent][val -val])
    (public
     [get-name (lambda () `(optional ,(send parent get-name)))]
     [all-examples
      (lambda ()
	(let ([l (map box (send parent all-examples))])
	  (cons val l)))]
     [add
      (lambda (x)
	(and x (send parent add x)))]
     [choose-example
      (opt-lambda ([which #f])
	(if (zero? (random 2))
	    val
	    (send parent choose-example)))]
     [bad-examples
      (lambda () (cons #t (send parent bad-examples)))])
    (sequence (super-init))))

(define choose-example-list%
  (class100 object% (-parents)
    (private-field [parents -parents])
    (public
     [get-name (lambda () `(choose ,(map (lambda (p) (send p get-name)) parents)))]
     [all-examples
      (lambda ()
	(apply append (map (lambda (p) (send p all-examples)) parents)))]
     [add (lambda (x) (void))]
     [choose-example
      (opt-lambda ([which #f])
	(send (list-ref parents (random (length parents)))
	      choose-example which))]
     [bad-examples
      (lambda () null)])
    (sequence (super-init))))

(define unknown-example-list%
  (class100 object% (-who)
    (private-field [who -who])
    (public
     [get-name (lambda () `(unknown ,who))]
     [all-examples (lambda () null)]
     [add (lambda (x) (void))]
     [choose-example
      (opt-lambda ([which #f])
	(format "[dummy for ~a]" (get-name)))]
     [bad-examples
      (lambda () null)])
    (sequence (super-init))))

(define discrete-example-list%
  (class100 object% (-vals)
    (private-field [vals -vals])
    (public
     [get-name (lambda () `(one-of ,@vals))]
     [all-examples (lambda () vals)]
     [add (lambda (x) (unless (member x vals)
			(error '|add in discrete-example-list|
				 "no good: ~a" x)))]
     [choose-example
      (opt-lambda ([which #f])
	(list-ref vals (random (length vals))))]
     [bad-examples
      (lambda ()
	(if (member 'bad-example-symbol vals)
	    null
	    (list 'bad-example-symbol)))])
    (sequence (super-init))))

(define number-example-list%
  (class100 object% (-parent -start -end)
    (private-field [parent -parent]
		   [start -start]
		   [end -end])
    (public
      [get-name (lambda () `(number in ,start ,end))]
      [all-examples
       (lambda ()
	 (filter (lambda (x) (ok x)) (send parent all-examples)))]
      [ok (lambda (v) (<= start v end))]
      [add (lambda (v)
	     (send parent add v)
	     (unless (ok v)
	       (error 'add "rejected (late): ~a in: ~a" v name)))]
      [choose-example
       (opt-lambda ([which #f])
	 (let loop ()
	   (let ([v (send parent choose-example which)])
	     (if (ok v)
		 v
		 (loop)))))]
      [bad-examples
       (lambda ()
	 (list* (sub1 start)
		(if (= (add1 end) end)
		    (- start 2)
		    (add1 end))
		(send parent bad-examples)))])
    (sequence (super-init))))


(define maker-example-list%
  (class100 object% (-maker)
    (private-field [maker -maker])
    (public
     [get-name (lambda () `(make ,maker))]
     [all-examples
      (lambda ()
	(list (maker)))]
     [add (lambda (x) (void))]
     [choose-example
      (opt-lambda ([which #f])
	(maker))]
     [bad-examples
      (lambda () null)])
    (sequence (super-init))))

(define-struct (fatal-exn exn) ())

(define (fatal-error name str . args)
  (raise (make-fatal-exn (apply format (string-append "~a: " str) name args)
			 ((debug-info-handler)))))

(define trying-class #f)
(define trying-method #f)

(define null-results null)

(define-macro define-main 
  (lambda list
    (let loop ([l list][rest '()])
      (if (null? l)
	  (cons 'begin rest)
	  (loop (cdr l)
		(let* ([first (car l)]
		       [name (if (symbol? first)
				 first
				 (car first))]
		       [strname (symbol->string name)]
		       [bases (if (symbol? first)
				  ()
				  (cdr first))]
		       [el-name (lambda (s)
				  (if s
				      (string->symbol
				       (string-append
					(symbol->string s)
					"-example-list"))
				      #f))])
		  (append
		   `((define ,(el-name name)
		       (make-object example-list% 
				    ',name
				    (list ,@(map el-name bases))
				    (lambda (v) (when (null? v)
						  (set! null-results (cons (list trying-class trying-method ',name)
									   null-results))
						  (error ',name "got null"))))))
		   (if (or (regexp-match "%$" strname) (regexp-match "<%>$" strname))
		       `((send ,(el-name name) set-filter (lambda (x) (is-a? x ,name)))
			 (send ,(el-name name) add-bad 5))
		       null)
		   rest)))))))

(define-main
  void
  (value char real string-list subarea<%>)
  char
  ubyte
  integer
  integer-list
  symbol
  real
  real-list
  string
  string-list
  mutable-string
  bytes
  path
  labelstring
  labelstring-list
  boolean
  procedure
  eventspace
  container-alignment

  (area<%> window<%> subarea<%> area-container<%>)

  (subarea<%> subwindow<%> pane%)

  (window<%> subwindow<%> area-container-window<%>)

  (area-container<%> area-container-window<%> pane%)

  (subwindow<%> control<%> canvas<%> panel%)

  (area-container-window<%> top-level-window<%> panel%)

  (control<%> message% button% check-box% slider% gauge% text-field% combo-field% radio-box% list-control<%>)

  (list-control<%> choice% list-box%)

  (top-level-window<%> frame% dialog%)

  (pane% horizontal-pane% vertical-pane% grow-box-spacer-pane%)
  
  (panel% horizontal-panel% vertical-panel%)

  (canvas<%> canvas% editor-canvas%)

  message%
  button%
  check-box%
  slider%
  gauge%
  text-field%
  combo-field%
  radio-box%

  choice%
  list-box%

  canvas%
  editor-canvas%

  horizontal-pane%
  vertical-pane%
  grow-box-spacer-pane%

  horizontal-panel%
  (vertical-panel% tab-panel% group-box-panel%)
  tab-panel%
  group-box-panel%

  frame%
  dialog%

  point%

  ps-setup%
  gl-config%
  gl-context<%>

  color%
  font%
  brush%
  pen%
  region%
  dc-path%

  font-list%
  pen-list%
  brush-list%
  color-database<%>
  font-name-directory<%>

  cursor%
  bitmap%

  (event% control-event% scroll-event% mouse-event% key-event%)
  control-event%
  scroll-event%
  mouse-event%
  key-event%

  (dc<%> bitmap-dc% post-script-dc% printer-dc%)
  bitmap-dc%
  post-script-dc%
  printer-dc%
  
  (menu-item-container<%> menu% menu-bar% popup-menu%)

  popup-menu%
  menu-bar%
  
  (menu-item<%> separator-menu-item%  labelled-menu-item<%>)
  (labelled-menu-item<%> selectable-menu-item<%> menu%)
  (selectable-menu-item<%> menu-item% checkable-menu-item%)
  separator-menu-item%
  menu-item%
  checkable-menu-item%

  menu%

  timer%

  add-color<%>
  mult-color<%>
  style-delta%
  style<%>
  style-list%

  (editor-admin%  editor-snip-editor-admin<%>)
  editor-snip-editor-admin<%>
  snip-admin%
  
  (editor<%> text% pasteboard%)
  text%
  pasteboard%

  (snip% string-snip% image-snip% editor-snip% readable-snip<%>)
  (string-snip% tab-snip%)
  tab-snip%
  image-snip%
  editor-snip%
  readable-snip<%>

  snip-class%
  snip-class-list<%>

  editor-data%
  editor-data-class%
  editor-data-class-list<%>

  keymap%
  editor-wordbreak-map%

  (editor-stream-in-base% editor-stream-in-bytes-base%)
  (editor-stream-out-base% editor-stream-out-bytes-base%)

  editor-stream-in-bytes-base%
  editor-stream-out-bytes-base%

  editor-stream-in%
  editor-stream-out%
  
  clipboard<%>
  clipboard-client%)

(send bitmap%-example-list set-filter (lambda (bm) (send bm ok?)))

; Avoid stuck states in random testing:
(send frame%-example-list set-prepare (lambda (w) (send w enable #t) w))
(send dialog%-example-list set-prepare (lambda (w) (send w enable #t) w))

(send boolean-example-list set-filter boolean?)
(send char-example-list set-filter char?)
(send string-example-list set-filter string?)
(send bytes-example-list set-filter bytes?)
(send mutable-string-example-list set-filter (lambda (x) (and (string? x) (not (immutable? x)))))
(send labelstring-example-list set-filter (lambda (x) (and (string? x) ((string-length x) . <= . 200))))
(send path-example-list set-filter path?)
(send symbol-example-list set-filter symbol?)
(send real-example-list set-filter real?)
(send integer-example-list set-filter (lambda (x) (and (number? x) (exact? x) (integer? x))))
(send integer-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (exact? x) (integer? x))) x))))
(send real-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (real? x))) x))))

(define false-example-list (make-object example-list% 'false '()))
(send false-example-list add #f)
(send false-example-list add-bad #t)

(send char-example-list add-bad 'not-a-char)
(send string-example-list add-bad 'not-a-string)
(send mutable-string-example-list add-bad 'not-a-string)
(send bytes-example-list add-bad 'not-a-bytes)
(send path-example-list add-bad 'not-a-path)
(send labelstring-example-list add-bad 'not-a-string)
(send labelstring-example-list add-bad (make-string 255 #\x))
(send symbol-example-list add-bad "not a symbol")
(send real-example-list add-bad 4+5i) 
(send integer-example-list add-bad 5.0)
(send integer-list-example-list add-bad 7)
(send real-list-example-list add-bad 7.0)

(for-each (lambda (h)
	    (for-each (lambda (v)
			(send container-alignment-example-list add (list h v)))
		      '(top center bottom)))
	  '(left center right))

(define input-port-example-list (make-object maker-example-list%
					     (lambda () 
					       (open-input-string (send string-example-list choose-example)))))

(define empty-list-example-list (make-object example-list% 'empty-list '()))
(send empty-list-example-list add null)
(send empty-list-example-list add-bad #f)

(send* boolean-example-list
       (add #t)
       (add #f))

(send* integer-example-list
       (add 0) (add 0) (add 0) (add 0)
       (add 0) (add 0) (add 0) (add 0)
       (add 0) (add 0) (add 0) (add 0)
       (add 0) (add 0) (add 0) (add 0)
       (add -1)
       (add -2)
       (add -3)
       (add -1000)
       (add 1)
       (add 2)
       (add 3)
       (add 4)
       (add 5)
       (add 6)
       (add 7)
       (add 8)
       (add 9)
       (add 10)
       (add 16)
       (add 32)
       (add 64)
       (add 128)
       (add 256)
       (add 255)
       (add 1023)
       (add 1000))

(send* real-example-list
       (add 0.0) (add 0.0)
       (add -1.0)
       (add -2.0)
       (add -1000.0)
       (add 1.0)
       (add 2.0)
       (add 256.0)
       (add +inf.0)
       (add -inf.0)
       (add 2/3)
       (add -100/9))

(define non-negative-integer-example-list (make-object number-example-list% integer-example-list 0 +inf.0))
(define positive-integer-example-list (make-object number-example-list% integer-example-list 1 +inf.0))

(define non-negative-real-example-list (make-object number-example-list% real-example-list 0 +inf.0))
(define positive-integer-example-list (make-object number-example-list% real-example-list 1e-200 +inf.0))

(define (range-integer-example-list s e)
  (make-object number-example-list% integer-example-list s e))

(define (range-real-example-list s e)
  (make-object number-example-list% real-example-list s e))

(send* symbol-example-list
       (add 'ok) (add 'change-family))

(send* string-list-example-list
       (add '("apple" "banana" "coconut")))

(send* labelstring-list-example-list
       (add '("apple" "banana" "coconut")))

(send* char-example-list
       (add #\nul)
       (add #\a)
       (add #\1)
       (add #\newline)
       (add #\tab)
       (add #\z)
       (add #\C))

(send* real-example-list
       (add 0.)
       (add 0.)
       (add 0.)
       (add -1.)
       (add -2.)
       (add -3.)
       (add -1000.)
       (add 1.)
       (add 2.)
       (add 3.)
       (add 1000.)
       (add 5))

(send* string-example-list
       (add "")
       (add "hello")
       (add "random/mred.xbm")
       (add "random/mred.bmp")
       (add "mred.gif")
       (add "goodbye adious see you later zai jian seeya bye-bye"))

(send* mutable-string-example-list
       (add (make-string 10 #\x))
       (add (make-string 10 #\nul)))

(send* bytes-example-list
       (add #"")
       (add #"hello")
       (add #"random/mred.xbm")
       (add #"random/mred.bmp")
       (add #"mred.gif")
       (add #"goodbye adious see you later zai jian seeya bye-bye"))

(send* labelstring-example-list
       (add "")
       (add "hello")
       (add "goodbye adious see you later zai jian seeya bye-bye"))

(send* path-example-list
       (add (string->path "hello"))
       (add (string->path "random/mred.xbm"))
       (add (string->path "random/mred.bmp"))
       (add (string->path "mred.gif")))


(send procedure-example-list add void)

(define classinfo (make-hash-table))

(define (add-all-combinations example-list items)
  (for-each
   (lambda (i) (send example-list add i))
   (let loop ([items items])
     (cond
      [(null? (cdr items)) items]
      [else (let ([l (loop (cdr items))])
	      (append
	       (map (lambda (x) (bitwise-ior (car items) x)) l)
	       l))]))))

(define (optional v l) (make-object optional-example-list% l v))
(define (boxed l) (make-object boxed-example-list% l))
(define (unknown s) (make-object unknown-example-list% s))
(define (choice . l) (make-object choose-example-list% l))
(define (style-list . l) (make-object listed-example-list% (make-object discrete-example-list% l)))
(define (symbol-in l) (make-object discrete-example-list% l))

(define message-label-example-list (choice labelstring-example-list bitmap%-example-list (symbol-in '(app caution stop))))

(load-relative "windowing-classes.ss")
(load-relative "drawing-classes.ss")
(load-relative "editor-classes.ss")

(define (get-args l)
  (let/ec bad
    (let loop ([l l])
      (if (null? l)
	  '()
	  (let* ([source (car l)]
		 [value (send source choose-example #f)])
	    (if (void? value)
		(bad (format "no examples: ~a" (send source get-name)))
		(cons value (loop (cdr l)))))))))

(define (get-all-args l)
  (let loop ([l l])
    (if (null? l)
	'()
	(let* ([source (car l)]
	       [values (send source all-examples)]
	       [rest (loop (cdr l))])
	  (if (null? (cdr l))
	      (list values)
	      (apply append
		     (map (lambda (other)
			    (map (lambda (v) (cons v other)) values))
			  rest)))))))

(define-struct posargs (good bads))

(define (get-bad-args l)
  (let/ec bad
    (let loop ([l l])
      (if (null? l)
	  '()
	  (let* ([source (car l)]
		 [good (send source choose-example #f)]
		 [bads (send source bad-examples)])
	    (if (void? good)
		(bad (format "no examples: ~a" (send source get-name)))
		(cons (make-posargs good bads) (loop (cdr l)))))))))

(define thread-output-port current-output-port)

(define print-only? #f)

(define (apply-args v dest name k)
  (if (list? v)
      (begin
	(fprintf (thread-output-port) "~a: ~s" name v)
	(flush-output (thread-output-port))
	(if print-only?
	    (newline)
	    (with-handlers (((lambda (x) (not (fatal-exn? x)))
			     (lambda (x)
			       (fprintf (thread-output-port)
					": error: ~a~n"
					(exn-message x)))))
	      (if (eq? dest 'values)
		  (k v)
		  (send dest add (k v)))
	      (flush-display)
	      (fprintf (thread-output-port) ": success~n"))))
      (fprintf (thread-output-port) "~a: failure: ~a~n" name v)))

(define (try-args arg-types dest name k)
  (apply-args (get-args arg-types) dest name k))

(define (try-all-args arg-types dest name k)
  (let ([vs (get-all-args arg-types)])
    (for-each (lambda (v)
		(apply-args v dest name k))
	      vs)))

(define (apply-bad-args v dest name k bad)
  (fprintf (thread-output-port) "~a: ~s" name v)
  (flush-output (thread-output-port))
  (with-handlers ([exn:fail:contract?
		   (lambda (x)
		     (fprintf (thread-output-port) ": exn: ~a~n"
			      (exn-message x))
		     ;; Check that exn is from the right place:
		     (let ([class (if (list? name) 
				      (let ([n (car name)])
					(if (symbol? n)
					    n
					    '|.|))
				      name)]
			   [method (if (list? name) (cadr name) 'initialization)])
		       (when (eq? method 'initialization)
			 ; init is never inherited, so class name really should be present
			 (unless (regexp-match (symbol->string class) (exn-message x))
			   (fprintf (thread-output-port) 
				    "  NO OCCURRENCE of class name ~a in the error message~n"
				    class)))
		       (unless (regexp-match (symbol->string method) (exn-message x))
			 (fprintf (thread-output-port) 
				  "  NO OCCURRENCE of method ~a in the error message~n"
				  method))))]
		  [exn:fail:contract:arity?
		   (lambda (x)
		     (fprintf (thread-output-port)
			      ": UNEXPECTED ARITY MISMATCH: ~a~n"
			      (exn-message x)))]
		  [(lambda (x) (not (fatal-exn? x)))
		   (lambda (x)
		     (fprintf (thread-output-port)
			      ": WRONG EXN TYPE: ~a~n"
			      (exn-message x)))])
    (k v)
    (flush-display)
    (fprintf (thread-output-port) ": NO EXN RAISED~n")))

(define (try-bad-args arg-types dest name k)
  (let ([args (get-bad-args arg-types)])
    (cond
     [(not (list? args)) (fprintf (thread-output-port) "~a: failure in bad-testing: ~a~n" name args)]
     [else
      (let loop ([pres null][posts args])
	(unless (null? posts)
	  (for-each
	   (lambda (bad)
	     (apply-bad-args (append
			      (map posargs-good pres)
			      (list bad)
			      (map posargs-good (cdr posts)))
			     dest name k bad))
	   (posargs-bads (car posts)))
	  (loop (append pres (list (car posts))) (cdr posts))))])))

(define (create-some cls try)
  (when (class? cls)
	(let* ([v (hash-table-get classinfo cls)]
	       [dest (car v)]
	       [name (cadr v)]
	       [creators (caddr v)])
	  (let loop ([l creators])
	    (unless (null? l)
		    (try (car l) dest name
			 (lambda (v)
			   (apply make-object cls v)))
		    (loop (cdr l)))))))

(define (create-all-random)
  (fprintf (thread-output-port) "creating all randomly...~n")
  (hash-table-for-each classinfo (lambda (k v)
				   (create-some k try-args))))
(define (create-all-exhaust)
  (fprintf (thread-output-port) "creating all exhaustively...~n")
  (hash-table-for-each classinfo (lambda (k v)
				   (create-some k try-all-args))))

(define (create-all-bad)
  (fprintf (thread-output-port) "creating all with bad arguments...~n")
  (hash-table-for-each classinfo (lambda (k v)
				   (create-some k try-bad-args))))

(define (try-methods cls try)
  (let* ([v (hash-table-get classinfo cls)]
	 [source (car v)]
	 [use (if source (send source choose-example) #f)]
	 [name (cadr v)]
	 [methods (cdddr v)])
    (if (void? use)
	(fprintf (thread-output-port) "~s: no examples~n" name)
	(let loop ([l methods])
	  (unless (null? l)
	    (unless (symbol? (car l))
	      (let* ([method (car l)]
		     [iv (car method)]
		     [resulttype (caddr method)]
		     [argtypes (cdddr method)])
		(set! trying-class (and source (send source get-name)))
		(set! trying-method iv)
		(try argtypes resulttype (list name iv use)
		     (lambda (args)
		       (if use
			   (begin

			     ;; Avoid showing a disabled dialog
			     (when (and (is-a? use dialog%)
					(eq? iv 'show)
					(equal? args '(#t)))
				 (send use enable #t))

			     ;; Avoid excessive scaling
			     (when (eq? iv 'set-scale)
			       (set! args (map (lambda (x) (min x 10)) args)))

			     (send-generic use (make-generic (object-interface use) iv) . args))

			   (apply (namespace-variable-value iv) args))))))
	    (loop (cdr l)))))))

(define (call-random except)
  (fprintf (thread-output-port) "calling all except ~a randomly...~n" except)
  (hash-table-for-each classinfo (lambda (k v)
				   (unless (member k except)
				     (try-methods k try-args)))))

(define (call-all-random)
  (call-random null))

(define (call-all-bad)
  (fprintf (thread-output-port) "calling all with bad arguments...~n")
  (hash-table-for-each classinfo (lambda (k v) (try-methods k try-bad-args))))

(define (call-all-non-editor)
  (call-random (list :editor-buffer% :editor-edit% :editor-snip% :editor-pasteboard% 'EditorGlobal)))

(define (init)
  (create-all-random)
  (create-all-random)
  (create-all-random)
  (create-all-random))

(printf " Creating Example Instances~n")  

(define f (make-object frame% "Example Frame 1"))
(send frame%-example-list add f)

(define d (make-object dialog% "Example Dialog 1"))
(send dialog%-example-list add d)

(define hpl (make-object horizontal-panel% f))
(send horizontal-panel%-example-list add hpl)
(define vpl (make-object vertical-panel% d))
(send vertical-panel%-example-list add vpl)
(define gbpl (make-object group-box-panel% "ok" d))
(send group-box-panel%-example-list add gbpl)
(define tpl (make-object tab-panel% '("Apple" "Banana" "Coconut") d void))
(send tab-panel%-example-list add tpl)
(define hp (make-object horizontal-pane% d))
(send horizontal-pane%-example-list add hp)
(define vp (make-object vertical-pane% f))
(send vertical-pane%-example-list add vp)
(define sp (make-object grow-box-spacer-pane% f))
(send grow-box-spacer-pane%-example-list add sp)

(send message%-example-list add (make-object message% "Message 1" hpl))
(send button%-example-list add (make-object button% "Button 1" vpl void))
(send check-box%-example-list add (make-object check-box% "Check Box 1" hp void))
(send slider%-example-list add (make-object slider% "Slider 1" -10 10 vp void))
(send gauge%-example-list add (make-object gauge% "Gauge 1" 100 hpl))
(send text-field%-example-list add (make-object text-field% "Text Field 1" vpl void))
(send combo-field%-example-list add (make-object combo-field% "Combo Field 1" '("A" "B") vpl void))
(send radio-box%-example-list add (make-object radio-box% "Radio Box 1" '("Radio Button 1.1" "Radio Button 1.2") hp void))
(send choice%-example-list add (make-object choice% "Choice 1" '("Choice 1.1" "Choice 1.2" "Choice 1.3") vp void))
(send list-box%-example-list add (make-object list-box% "List Box 1" '("List Box 1.1" "List Box 1.2" "List Box 1.3") hpl void))

(send canvas%-example-list add (make-object canvas% f))
(define c (make-object editor-canvas% d))
(send editor-canvas%-example-list add c)

(send point%-example-list add (make-object point% 50 60))

(send ps-setup%-example-list add (make-object ps-setup%))

(send color%-example-list add (make-object color% "RED"))
(send font%-example-list add (make-object font% 12 'roman 'normal 'normal))
(send brush%-example-list add (make-object brush% "GREEN" 'solid))
(send pen%-example-list add (make-object pen% "BLUE" 1 'solid))
(send region%-example-list add (make-object region% (send c get-dc)))
(send dc-path%-example-list add (make-object dc-path%))
(send gl-config%-example-list add (make-object gl-config%))
(send gl-context<%>-example-list add (send (send c get-dc) get-gl-context))

(send font-list%-example-list add the-font-list)
(send pen-list%-example-list add the-pen-list)
(send brush-list%-example-list add the-brush-list)
(send color-database<%>-example-list add the-color-database)
(send font-name-directory<%>-example-list add the-font-name-directory)

(send cursor%-example-list add (make-object cursor% 'watch))
(send bitmap%-example-list add (make-object bitmap% (build-path (collection-path "icons") "bb.gif")))

(send control-event%-example-list add (make-object control-event% 'list-box))
(send scroll-event%-example-list add (make-object scroll-event%))
(send mouse-event%-example-list add (make-object mouse-event% 'left-down))
(send key-event%-example-list add (make-object key-event%))

(send bitmap-dc%-example-list add (make-object bitmap-dc%))
(send post-script-dc%-example-list add (make-object post-script-dc% #f))

(with-handlers ([void void])
  (send printer-dc%-example-list add (make-object printer-dc%)))

(define mb (make-object menu-bar% f))
(send menu-bar%-example-list add mb)
(define m (make-object menu% "Menu1" mb))
(send menu%-example-list add m)
(send popup-menu%-example-list add (make-object popup-menu% "Popup Menu 1"))
  
(send separator-menu-item%-example-list add (make-object separator-menu-item% m))
(send menu-item%-example-list add (make-object menu-item% "Menu Item 1" m void))
(send checkable-menu-item%-example-list add (make-object checkable-menu-item% "Checkable Menu Item 1" m void))

(send timer%-example-list add (make-object timer%))

(define sd (make-object style-delta%))
(send add-color<%>-example-list add (send sd get-background-add))
(send mult-color<%>-example-list add (send sd get-background-mult))
(send style-delta%-example-list add sd)
(define sl (make-object style-list%))
(send style-list%-example-list add sl)
(send style<%>-example-list add (send sl basic-style))

(define e (make-object text%))
(send c set-editor e)
(send text%-example-list add e)
(send pasteboard%-example-list add (make-object pasteboard%))

(define s (make-object editor-snip%))
(send e insert s)
(send editor-snip-editor-admin<%>-example-list add (send (send s get-editor) get-admin))
(send snip-admin%-example-list add (make-object snip-admin%))

(send tab-snip%-example-list add (make-object tab-snip%))
(send image-snip%-example-list add (make-object image-snip%))
(send editor-snip%-example-list add (make-object editor-snip%))

(require (prefix graph: (lib "graph.ss" "mrdemo")))
(send readable-snip<%>-example-list add (make-object graph:graph-snip% '(lambda (x) x)))

(send snip-class%-example-list add (make-object snip-class%))
(send snip-class-list<%>-example-list add (get-the-snip-class-list))

(send editor-data%-example-list add (make-object editor-data%))
(send editor-data-class%-example-list add (make-object editor-data-class%))
(send editor-data-class-list<%>-example-list add (get-the-editor-data-class-list))

(send keymap%-example-list add (make-object keymap%))
(send editor-wordbreak-map%-example-list add the-editor-wordbreak-map)

(define sib (make-object editor-stream-in-bytes-base% #"Hello"))
(send editor-stream-in-bytes-base%-example-list add sib)
(define sob (make-object editor-stream-out-bytes-base%))
(send editor-stream-out-bytes-base%-example-list add sob)

(send editor-stream-in%-example-list add (make-object editor-stream-in% sib))
(send editor-stream-out%-example-list add (make-object editor-stream-out% sob))
  
(send clipboard<%>-example-list add the-clipboard)
(send clipboard-client%-example-list add (make-object clipboard-client%))

(printf " Done Creating Example Instances~n")  

(printf " Checking all methods~n")
(define in-top-level null)
(hash-table-for-each classinfo 
		     (lambda (key v)
		       (let* ([methods (cdddr v)]
			      [names (map (lambda (x) (if (pair? x) (car x) x)) methods)])
			 (if (string? key)
			     ;; Check global procs/values
			     (for-each
			      (lambda (name method)
				(if (void? (with-handlers ([void void])
					     (namespace-variable-value name)))
				    ;; Not there
				    (printf "No such procedure/value: ~a~n" name)
				    
				    (let ([v (namespace-variable-value name)])
				      (when (procedure? v)
					;; check arity
					(unless (or (equal? (procedure-arity v) (cadr method))
						    (let ([a (procedure-arity v)]
							  [b (cadr method)])
						      (and (list? a)
							   (list? b)
							   (andmap integer? a)
							   (andmap integer? b)
							   (equal? (quicksort a <) (quicksort b <)))))
					  (printf "Arity mismatch for ~a, real: ~a documented: ~a~n" 
						  name (procedure-arity v) (cadr method))))))
				
				(set! in-top-level (cons name in-top-level)))
			      names methods)
			     ;; Check intf/class methods
			     (begin
			       (set! in-top-level (cons (cadr v) in-top-level))
			       
			       ; Check printed form:
			       (let ([p (open-output-string)])
				 (display key p)
				 (let ([sp (get-output-string p)]
				       [ss (let ([s (symbol->string (cadr v))])
					     (format "#<struct:~a:~a>"
						     (if (interface? key) "interface" "class")
						     s))])
				   (unless (string=? sp ss)
				     (printf "bad printed form: ~a != ~a~n" sp ss))))
			       
			       ; Check documented methods are right
			       (let ([ex (send (car v) choose-example)])
				 (unless (is-a? ex key)
				   (printf "Bad example: ~a for ~a~n" ex key))
				 (for-each
				  (lambda (name method)
				    (if (or (and (interface? key)
						 (method-in-interface? name key))
					    (and (class? key)
						 (method-in-interface? name (class->interface key))))
					
					;; Method is there, check arity
					'(when (is-a? ex key)
					  (let ([m (make-generic ex name)])
					    (unless (equal? (arity m) (cadr method))
					      (printf "Warning: arity mismatch for ~a in ~a, real: ~a documented: ~a~n" 
						      name key
						      (arity m) (cadr method)))))
					
					;; Not there
					(printf "No such method: ~a in ~a~n" name key)))
				  names methods))
			       
			       ; Check everything is documented
			       (for-each
				(lambda (n)
				  (unless (memq n names)
				    (printf "Undocumented method: ~a in ~a~n" n key)))
				(interface->method-names (if (interface? key) key (class->interface key)))))))))
(printf " Method-checking done~n")

(let* ([get-all (lambda (n)
		  (parameterize ([current-namespace n])
		    (namespace-mapped-symbols)))]
       [expect-n (list* 'mred@ 'mred^ 
			(append (get-all (let ([n (make-namespace)])
					   (parameterize ([current-namespace n])
					     (namespace-require '(lib "class.ss")))
					   n))
				in-top-level))]
       [actual-n (get-all (make-namespace-with-mred))])
  (for-each
   (lambda (i)
     (unless (memq i expect-n)
       (printf "Undocumented global: ~a~n" i)))
   actual-n))

(unless (and (>= (vector-length argv) 1)
	     (string=? (vector-ref argv 0) "-r"))
  (exit 0))

;; Disallow writes outside of random/...
(unless (directory-exists? "random")
  (make-directory "random"))
(current-security-guard (make-security-guard (current-security-guard)
					     (lambda (who what why)
					       (when (memq why '(write delete))
						 (unless (regexp-match "/random/" what)
						   (error who
							  "not allowed to write file: ~e"
							  what))))
					     (lambda args 'ok)))

;; Remove some things:
(for-each (lambda (p)
	    (let ([k (ormap (lambda (k)
			      (and (equal? k (car p))
				   k))
			    (hash-table-map classinfo (lambda (k v) k)))])
	      (hash-table-put! 
	       classinfo k
	       (let ([l (hash-table-get classinfo k)])
		 (let loop ([l l])
		   (cond
		    [(null? l) null]
		    [(and (pair? (car l))
			  (eq? (cadr p) (caar l)))
		     (cdr l)]
		    [else (cons (car l) (loop (cdr l)))]))))))
	  '(("Eventspaces" sleep/yield)))

(random-seed 179)

(create-all-bad)
(call-all-bad)

(create-all-random)
(call-all-random)
