#!/var/lib/install/usr/bin/guile -s
!#
(use-modules (gnome-0))
(use-modules (gnome gtk)
	     (gnome hildon))

(define prog (make <hildon-app> #:app-title "Counting Agent"))
(connect prog 'destroy (lambda (w) (gtk-main-quit)))

(define view (make <hildon-app-view>))
(set-appview prog view)

(define nb (make <gtk-notebook>))
(add view nb)

(define v1 (make <gtk-vbox>))
(append-page nb
	     v1
	     (make <gtk-label> #:label "Summary"))

(define-class <party-list> (<guile-gtk-tree-model>)
  (data #:init-value '()))

(define-method (on-get-flags (pl <party-list>))
  #f)

(define-method (on-get-iter (pl <party-list>) path)
  (let ((data (slot-ref pl 'data))
	(i (car path)))
    (and (< i (length data)) (list-ref data i))))

(define-method (on-get-path (pl <party-list>) iter)
  (list (list-index (slot-ref pl 'data) iter)))

(define-method (on-iter-next (pl <party-list>) iter)
  (let ((path (on-get-path pl iter)))
    (set-car! path (+ (car path) 1))
    (on-get-iter pl path)))

(define-method (on-iter-children (pl <party-list>) parent)
  (cond (parent
	 #f)
	((null? (slot-ref pl 'data))
	 #f)
	(else
	 (car (slot-ref pl 'data)))))

(define-method (on-iter-has-child (pl <party-list>) parent)
  #f)

(define-method (on-iter-n-children (pl <party-list>) parent)
  (and (not parent)
       (length (slot-ref pl 'data))))

(define-method (on-iter-nth-child (pl <party-list>) parent n)
  (and (not parent)
       (on-get-iter pl (list n))))

(define-method (on-iter-parent (pl <party-list>) child)
  #f)

(define-method (on-get-n-columns (pl <party-list>))
  2)

(define-method (on-get-column-type (pl <party-list>) index)
  (list-ref (list gtype:gchararray gtype:gchararray) index))

(define-method (on-get-value (pl <party-list>) iter index)
  (list-ref iter index))

(define-method (add-party (pl <party-list>) name)
  (let* ((data (slot-ref pl 'data))
	 (datalen (length data))
	 (new-entry (list name "0")))
    (slot-set! pl 'data (append data (list new-entry)))
    (row-inserted pl (list datalen) (get-iter pl (list datalen)))))

(define pl (make <party-list>))
(for-each (lambda (p)
	    (add-party pl p))
	  '("Liberal Democrat"
	    "Labour"
	    "Conservative"
	    "Green"
	    "IWCA"
	    "Independent"))

(define tv (make <gtk-tree-view>
	     #:model pl
	     #:headers-visible #t))
(let ((cr1 (make <gtk-cell-renderer-text>))
      (cr2 (make <gtk-cell-renderer-text>))
      (tvc1 (make <gtk-tree-view-column> #:title "Party"))
      (tvc2 (make <gtk-tree-view-column> #:title "Votes")))
  (pack-start tvc1 cr1 #t)
  (add-attribute tvc1 cr1 "text" 0)
  (append-column tv tvc1)
  (pack-start tvc2 cr2 #t)
  (add-attribute tvc2 cr2 "text" 1)
  (append-column tv tvc2))
(pack-start v1 tv #t)

(define h11 (make <gtk-hbox>))
(pack-start h11 (make <gtk-label> #:label "New party:") #f)
(define pe (make <gtk-entry>))
(pack-start h11 pe #t)
(define pb (make <gtk-button> #:label "Add"))
(pack-end h11 pb #f)
(connect pb 'clicked
	 (lambda (w)
	   (add-party pl (get-text pe))
	   (set-text pe "")))
(pack-start v1 h11 #f)

(define h12 (make <gtk-hbox>))
(pack-start h12 (make <gtk-label> #:label "New count:") #f)
(define ce (make <gtk-entry>))
(pack-start h12 ce #t)
(define cb (make <gtk-button> #:label "Add"))
(pack-end h12 cb #f)
(connect cb 'clicked
	 (lambda (w)
	   (let ((box-name (get-text ce)))
	     (append-page nb
	  	          (make-count-page
			    (make-result-store box-name))
 			  (make <gtk-label> #:label box-name)))
           (show-all nb)
	   (set-text ce "")
	   (maybe-save)))
(pack-end v1 h12 #f)

(define (make-result-store box-name)
  (set! results
	(cons (cons* box-name
		     0
	             (make-vector (length (slot-ref pl 'data)) 0))
	      results))
  (cdar results))

(define results '())

(define (save-results fn)
  (with-output-to-file fn
    (lambda ()
      (for-each (lambda (result)
		  (write result)
		  (newline))
		results))))

(define maybe-save
  (let ((count 0))
    (lambda ()
      (set! count (+ count 1))
      (if (zero? (remainder count 20))
	  (save-results "#results#")))))

(connect nb 'switch-page
  (lambda _
    (let loop ((data (slot-ref pl 'data)) (i 0))
      (or (null? data)
	  (begin
	    (set-car! (cdar data)
	      (number->string (inexact->exact
		(floor
		  (apply +
		    (map (lambda (store)
			   (let ((st (sampled-total store)))
			     (if (zero? st)
				 st
			   	 (/ (* (car store)
				       (vector-ref (cdr store) i))
			      	    st))))
			 (map cdr results)))))))
	    (row-changed pl (list i) (get-iter pl (list i)))
	    (loop (cdr data) (+ i 1)))))))

(define (sampled-total store)
  (apply + (vector->list (cdr store))))

(define (make-count-page store)
  (let* ((parties (map car (slot-ref pl 'data)))
	 (h (make <gtk-hbox>))
	 (v1 (make <gtk-vbox>))
	 (v2 (make <gtk-vbox>))
    	 (svt (make <gtk-label> #:label "0"))
    	 (ps (make <gtk-label> #:label "--")))
    (let loop ((parties parties) (i 0))
      (or (null? parties)
	  (let ((b (make <gtk-button> #:label (car parties))))
	    (connect b 'clicked
	      (lambda _
		(let ((votes (+ (vector-ref (cdr store) i) 1)))
		  (vector-set! (cdr store) i votes)
		  (set-label svt (format #f "~a"
				         (sampled-total store)))
		  (or (zero? (car store))
	  	    (set-label ps
		     (format #f "~a%"
			     (quotient (* 100 (sampled-total store))
				       (car store)))))
		  (maybe-save)
		  (set-label b (format #f "~a: ~a"
				       (car parties)
				       votes)))))
	    (pack-start v1 b #t)
	    (loop (cdr parties) (+ i 1)))))
    (pack-start h v1 #t)
    (pack-start v2 (make <gtk-label> #:label "Actual votes") #f)
    (let ((e (make <gtk-entry>)))
      (pack-start v2 e #f)
      (connect e 'changed
	(lambda _
	  (set-car! store
		    (inexact->exact
		     (floor (or (string->number (get-text e)) 0))))
	  (set-label ps
		     (if (zero? (car store))
			 "--"
		     	 (format #f "~a%"
			     (quotient (* 100 (sampled-total store))
				       (car store))))))))
    (pack-start v2 (make <gtk-label> #:label "Sampled votes") #f)
    (pack-start v2 svt #f)
    (pack-start v2 (make <gtk-label> #:label "% sampled") #f)
    (pack-start v2 ps #f)
    (pack-end h v2 #f)
    h))

(show-all prog)
(gtk-main)