(define Listu
  (unit/sig
    (collect reduce filter set-minus subset?)
    (import)
    (define collect
      (lambda (base combine)
	(local ((define C 
		  (lambda (l)
		    (cond
		      ((null? l) base)
		      (else (combine l (car l) (C (cdr l))))))))
	  C)))

    (define reduce
      (lambda (base combine)
	(local ((define C 
		  (lambda (l)
		    (cond
		      ((null? l) base)
		      (else (combine (car l) (C (cdr l))))))))
	  C)))

    (define filter
      (lambda (p? l)
	[(collect null (lambda (_ x rest) (if (p? x) (cons x rest) rest))) l]))

    ;; set library
    (define set-minus
      (lambda (set1 set2)
	[(collect null (lambda (_ e1 rest) (if (member e1 set2) rest (cons e1 rest))))
	 set1]))

    (define subset?
      (lambda (state1 state2)
	(cond
	  ((null? state1) #t)
	  (else (and (member (car state1) state2)
		  (subset? (cdr state1) state2))))))
    ))

(let* ([mred:one-line-canvas%
	(class mred:editor-canvas%
	  (parent [x -1] [y -1] [w -1] [h -1] 
		  [name ""] [style 0] [spp 100] [m ()])
          (inherit get-media user-min-height
                   get-size min-height)
          (rename [super-set-media set-media])
          (private
            [update-size
             (lambda (media)
               (unless (null? media)
                 (let* ([top (send media line-location 0 #t)]
                        [bottom (send media line-location 0 #f)]
                        [height (- bottom top)])
                   (let* ([ch (box 0)]
                          [h (box 0)])
		     (send (send media get-admin) 
			   get-view null null null ch)
                     (get-size (box 0) h)
                     (let ([new-min-height (+ height (- (unbox h) (unbox ch)))])
                       (set! min-height new-min-height)
                       (user-min-height new-min-height))))))])
          (public
	    [style-flags (bitwise-ior wx:const-mcanvas-hide-h-scroll
				      wx:const-mcanvas-hide-v-scroll)]
            [default-y-stretch #f]
            [set-media
             (lambda (media)
               (super-set-media media)
               (update-size media))])
          (sequence
            (super-init parent x y w h name style spp m)
            (update-size (get-media))))]
       [vp% (class-asi mred:vertical-panel%
	      (public
	       [default-spacing-width 0]
	       [default-border-width 0]))]
       [hp% (class-asi mred:horizontal-panel%
	      (public
	       [default-spacing-width 0]
	       [default-border-width 0]))]
       [graderr
	(lambda (remember-grade lookup-grade)
	  (let ([arity-ok
		 (lambda (n f)
		   (let ([t1 (procedure? lookup-grade)])
		     (and t1
			  (let ([a (arity f)])
			    (and (#%number? a)
				 (= n a))))))])
	    (unless (and (arity-ok 2 remember-grade)
			 (arity-ok 1 lookup-grade))
	      (raise (format "a: ~a b: ~a ~a ~a" (arity remember-grade) (arity lookup-grade)
			     (arity-ok 2 remember-grade) (arity-ok 1 lookup-grade)))
	      (raise (format "grader: expected two procedures of arities two and one, got: ~a ~a"
			     remember-grade lookup-grade))))
	  (letrec* ([f (make-object mred:empty-frame% '() "Grader")]
		    [main (ivar f panel)]
		    
		    [name-panel (make-object hp% main)]
		    [name-msg (make-object mred:message% name-panel "Name:")]
		    [name-field (make-object mred:one-line-canvas% name-panel)]
		    [name-edit (make-object mred:edit%)]
		    [get-name (lambda () (string->symbol (send name-edit get-text)))]
		    [_ (send name-field set-media name-edit)]
		    
		    [grade-panel (make-object hp% main)]
		    [grade-msg (make-object mred:message% grade-panel "Grade:")]
		    [grades (list "A" "B" "C" "D" "F")]
		    [grade-radio (make-object mred:radio-box% grade-panel
					      void "" -1 -1 -1 -1
					      grades 0 wx:const-horizontal)]
		    
		    [interaction-panel (make-object hp% main)]
		    [average-button
		     (make-object mred:button% interaction-panel 
				  (lambda x
				    (let* ([pregrade (lookup-grade (get-name))]
					   [grade (if (#%number? pregrade)
						      (number->string pregrade)
						      "no grades available")])
				      (send interaction-panel
					    change-children 
					    (lambda (l)
					      (list average-button
						    (make-object mred:message% interaction-panel grade)
						    space
						    enter-new-grade)))))
				  "Average:")]
		    [space (make-object hp% interaction-panel)]
		    [new-grade
		     (lambda x
		       (let ([name (get-name)]
			     [grade (string->symbol (list-ref grades (send grade-radio get-selection)))])
			 (remember-grade name grade)))]
		    [enter-new-grade (make-object mred:button% interaction-panel new-grade "Submit Grade")]
		    [close-panel (make-object hp% main)]
		    [close-space (make-object hp% close-panel)]
		    [close-button (make-object mred:button% close-panel (lambda x (send f show #f)) "Close")])
	    (send f show #t)))])
  '(unit/sig (grader filter)
    (import plt:userspace^)
    (define grader graderr)
    (define collect
      (lambda (base combine)
	(local ((define C 
		  (lambda (l)
		    (cond
		      ((null? l) base)
		      (else (combine l (car l) (C (cdr l))))))))
	  C)))

    (define reduce
      (lambda (base combine)
	(local ((define C 
		  (lambda (l)
		    (cond
		      ((null? l) base)
		      (else (combine (car l) (C (cdr l))))))))
	  C)))

    (define filter
      (lambda (p? l)
	[(collect null (lambda (_ x rest) (if (p? x) (cons x rest) rest))) l]))

    )
  (compound-unit/sig
     (import plt:userspace^)
     (link
       (DIALOGU : (grader) ((unit/sig (grader) (import) (define grader graderr))))
       (LISTU : (filter) (Listu)))
     (export (open LISTU) (open DIALOGU))))