;; -*-theme-d-*-

;; Copyright (C) 2015-2018 Tommi Höynälänmaa

;; Based on the file gtk/examples/calc.scm by Marius Vollmer and
;; Patrick Bernaud in package guile-gnome-platform-2.16.2.

(define-proper-program (gnome-examples calc)

  (import (standard-library core)
	  (standard-library list-utilities)
	  (standard-library string-utilities)
	  (standard-library text-file-io)
	  (standard-library object-string-conversion)
	  (standard-library math)
	  (standard-library text-file-io)
	  (standard-library console-io)
	  (gnome gtk)
	  (gnome gobject))

  (define gl-debug? <boolean> #f)

  (define-mutable gl-counter1 <integer> 0)

  ;; Allow debug printing in pure procedures, too.
  (define-simple-proc debug-print (((obj <object>)) <none> force-pure)
    (if gl-debug? (console-display-line obj)))

  (define <op-proc> (:procedure ((rest <object>)) <object> nonpure))

  (define <op-spec> (:tuple <string> <op-proc> (:union <integer> <symbol>)
			    <symbol>))

  (define <panel> (:uniform-list (:uniform-list <op-spec>)))

  (define-simple-proc simplify-number (((nr <number>)) <number> pure)
    (match-type-strong nr
      ((i <integer>) i)
      ((rat <rational>) 
       (if (rat-integer-valued? rat) (rational->integer rat) rat))
      ((r <real>) r)
      ((cx <complex>)
       (if (= (imag-part cx) 0.0) (real-part cx) cx))))

  (define-simple-proc convert-to-real-number (((nr <number>)) <real-number>
					      pure)
    (match-type-strong nr
      ((i <integer>) i)
      ((rat <rational>) rat) 
      ((r <real>) r)
      ((cx <complex>)
       (raise-simple 'invalid-real-number))))

  (define-simple-proc my-complex (((nr1 <number>) (nr2 <number>)) <complex>
				  pure)
    (if (and (real-valued? nr1) (real-valued? nr2))
	(complex (convert-to-real-number nr1) (convert-to-real-number nr2))
	(raise-simple 'invalid-real-number)))

  (define-simple-proc my-real-part (((nr <number>)) <real-number> pure)
    (match-type-strong nr
      ((i <integer>) i)
      ((rat <rational>) rat)
      ((r <real>) r)
      ((cx <complex>) (real-part cx))))

  (define-simple-proc my-imag-part (((nr <number>)) <real-number> pure)
    (match-type nr
      ((i <integer>) 0)
      ((rat <rational>) (rational 0 1))
      ((r <real>) 0.0)
      ((cx <complex>) (imag-part cx))))

  (define-simple-proc make-calculator
      (((lst-panels (:uniform-list <panel>)))
       <none>
       nonpure)
    (let* ((window (gtk-window-create 'toplevel))
	   (box (gtk-vbox-create #f 0))
	   (scrolled-win (gtk-scrolled-window-create #f #f))
	   (text-buffer (gtk-text-buffer-create #f))
	   (text-view (gtk-text-view-create-with-buffer text-buffer))
	   (entry (gtk-entry-create))
;;	   (attrlist (pango-attr-list-create))
;;	   (attr-background (pango-attr-background-new 65535 0 0))
	   (label-echo (gtk-label-create "")))
      (let-mutable ((lst-stack <list> null))
	(let* ((push (lambda (((obj-value <object>)) <none> nonpure)
		       (debug-print "push")
		       (set! lst-stack (cons obj-value lst-stack))))

	       (pop (lambda (() <object> nonpure)
		      (debug-print "pop")
		      (let* ((pr (cast (:pair <object> <object>) lst-stack))
			     (obj-value (car pr)))
			(set! lst-stack (cast <list> (cdr pr)))
			obj-value)))

	       (pop-n (lambda (((i-count <integer>)) <list> nonpure)
			(debug-print "pop-n")
			(if (< (length lst-stack) i-count)
			    (raise-simple 'too-few-arguments)
			    (do ((i <integer> i-count (- i 1))
				 (lst <list> null (cons (pop) lst)))
				((<= i 0) lst)))))

	       (redisplay
		(lambda (() <none> nonpure)
		  (debug-print "redisplay ENTER")
		  (set-text text-buffer "")
		  (let ((iter (get-start-iter text-buffer)))
		    (do ((i <integer> 1 (+ i 1))
			 (lst <object> lst-stack
			      (cdr (cast (:pair <object> <object>) lst))))
			((null? lst))
		      (debug-print "redisplay/1")
		      (debug-print (car (cast (:pair <object> <object>) lst)))
		      (insert text-buffer iter
			      (string-append
			       (integer->string i)
			       ":\n"))
		      (insert-with-tags-by-name
		       text-buffer iter
		       (string-append
			(object->string
			 (car (cast (:pair <object> <object>) lst)))
			"\n")
		       '("right-justify"))))
		  (debug-print "redisplay EXIT")))

	       (set-echo
		(let-mutable ((str-last-text <string> ""))
		  (lambda (((str-text <string>)) <none> nonpure)
		    (debug-print "set-echo ENTER")
		    (cond ((not (string=? str-last-text str-text))
			   (set! str-last-text str-text)
			   (gtk-label-set-text label-echo str-text)))
		    (debug-print "set-echo EXIT"))))
		    
	       (construct-error-message
		(lambda (((exc <object>)) <string> pure)
		  (match-type exc
		    ((exc1 <condition>)
		     (case (get-rte-exception-kind exc1)
		       ((numerical-overflow) "Numerical overflow")
		       ((too-few-arguments) "Too few arguments")
		       ((invalid-real-number) "Invalid real number")
		       (else "Error")))
		    (else "Error"))))

	       (activate-entry
		(lambda (((dup? <boolean>)) <none> nonpure)
		  (debug-print "activate-entry ENTER")
		  (let ((lst-vals (cast <list> (call-with-input-string
						(gtk-entry-get-text entry)
						read-all))))
		    (if (is-instance? lst-vals (:uniform-list <number>))
			(begin
			  (if (null? lst-vals)
			      (if (and dup? (not-null? lst-stack))
				  (push (car (cast (:pair <object> <object>)
						   lst-stack))))
			      (for-each1 push lst-vals))
			  (redisplay)
			  (gtk-entry-set-text entry "")
			  (set-echo ""))
			(raise-simple 'invalid-number)))
		  (debug-print "activate-entry EXIT")))

	       (perform-action
		(lambda (((obj-val <object>) (sym-action <symbol>))
			 <none> nonpure)
		  (debug-print "perform-action ENTER")
		  (cond
		   ((symbol=? sym-action 'push) (push obj-val))
		   ((symbol=? sym-action 'push-list)
		    (for-each1 push (cast <list> obj-val)))
		   ((symbol=? sym-action 'set-entry)
		    (set-text entry (cast <string> obj-val)))
		   (else (raise-simple 'bad-action)))
		  (debug-print "perform-action EXIT")))
		  
	       (make-op
		(lambda (((proc <op-proc>)
			  (obj-arg-count (:union <integer> <symbol>))
			  (sym-action <symbol>))
			 <none> nonpure)
		  (debug-print "make-op ENTER")
		  (debug-print gl-counter1)
		  (set! gl-counter1 (+ gl-counter1 1))
		  (let-mutable ((activate-failed? <boolean> #f))
		    (if (not (symbol=? sym-action 'set-entry))
			(guard-without-result
			 (exc
			  (else
			   (set-echo (if (equal? exc 'invalid-number)
					 "Invalid number"
					 "Error"))
			   (set! activate-failed? #t)))
			 (activate-entry #f)))
		    (if (not activate-failed?)
			(let ((lst-saved-stack lst-stack))
			  (guard-without-result
			   (exc
			    (else
			     (debug-print "raised")
			     (set-echo (construct-error-message exc))
			     (set! lst-stack lst-saved-stack)))
			   (debug-print "make-op normal")
			   (set-echo "")
			   (let ((lst-args
				  (cond
				   ((integer? obj-arg-count)
				    (debug-print "integer count")
				    (pop-n
				     (cast <integer> obj-arg-count)))
				   ((equal? obj-arg-count 'all)
				    (debug-print "count all")
				    (pop-n (length lst-stack)))
				   ((equal? obj-arg-count 'entry)
				    (debug-print "count entry")
				    (list (gtk-entry-get-text entry)))
				   (else
				    (debug-print "bad arg spec")
				    (raise-simple 'bad-arg-spec)))))
			     (perform-action (apply-nonpure
					      proc
					      (cast <list> lst-args))
					     sym-action))))))
		  (redisplay)
		  (debug-print "make-op EXIT")))

	       (make-button-row
		(lambda (((lst-specs (:uniform-list <op-spec>)))
			 <gtk-widget>
			 nonpure)
		  (debug-print "make-button-row")
		  (let ((box (gtk-hbox-create #t 2)))
		    (for-each1
		     (lambda (((op-spec <op-spec>)) <none> nonpure)
		       (let ((button (gtk-button-create-with-label
				      (car op-spec))))
			 (connect
			  button 'clicked
			  (lambda (((args (rest <object>))) <object> nonpure)
			    (guard-nonpure
			     (exc
			      (else
			       (console-display-line
				"unhandled exception")
			       null))
			     (debug-print "clicked ENTER")
			     (debug-print (car op-spec))
			     (apply-nonpure make-op (cdr op-spec))
			     (debug-print "clicked EXIT")
			     null)))
			 (pack-start box button #t #t 0)))
		     lst-specs)
		    box))))

	  (set-editable text-view #f)

	  (set-title window "Calc")

	  (set-policy scrolled-win 'automatic 'always)
	  (add-with-viewport scrolled-win text-view)
	  (set-alignment label-echo 0.0 0.5)
;;	  (pango-attr-list-insert attrlist attr-background)
;;	  (gtk-label-set-attributes label-echo attrlist)
	  (set-size-request scrolled-win 200 120)

	  (add window box)
	  (pack-start box scrolled-win #t #t 0)
	  (pack-start box entry #f #f 0)

	  (create-tag text-buffer 
		      "right-justify" 'justification 'right)

	  (for-each1
	   (lambda (((panel <panel>)) <none> nonpure)
	     (for-each1 
	      (lambda (((lst-op-specs (:uniform-list <op-spec>)))
		       <none> nonpure)
		(let ((widget-row (make-button-row lst-op-specs)))
		  (pack-start box widget-row #f #f 1)))
	      panel)
	     (pack-start box (gtk-hseparator-create) #f #f 1))
	     lst-panels)
	  
	  (pack-end box label-echo #f #f 0)

	  (connect
	   entry 'activate
	   (lambda (((args (rest <object>))) <object> nonpure)
	     (guard-without-result
	      (exc
	       (else
		(console-display-line
		 "unhandled exception (2)")
		null))
	      (activate-entry #t))
	     null))

	  (connect
	   window 'destroy
	   (lambda (((args (rest <object>))) <object> nonpure)
	     (gtk-main-quit)
	     null))

	  (show-all window)))))

  (define-simple-proc unary-op
      (((str-name <string>)
	(proc (:procedure (<number>) <number> pure)))
       <op-spec>
       pure)
    (let ((proc0 (lambda (((lst-args (rest <object>))) <object> pure)
		   (debug-print "applying unary operator ENTER")
		   (let* ((nr-arg
			  (car (cast (:pair <number> <object>) lst-args)))
			  (nr-result (simplify-number (proc nr-arg))))
		     (debug-print "applying unary operator EXIT")
		     nr-result))))
      (list str-name proc0 1 'push)))

  (define-simple-proc binary-op
      (((str-name <string>)
	(proc (:procedure (<number> <number>) <number> pure)))
       <op-spec>
       pure)
    (let ((proc0 (lambda (((lst-args (rest <object>))) <object> pure)
		   (debug-print "applying binary operator ENTER")
		   (let* ((obj-args1
			   (cast (:pair <number> (:pair <number> <object>))
				 lst-args))
			  (nr-arg1 <number> (car obj-args1))
			  (nr-arg2 <number> (car (cdr obj-args1)))
			  (nr-result (simplify-number (proc nr-arg1 nr-arg2))))
		     (debug-print "applying binary operator EXIT")
		     nr-result))))
      (list str-name proc0 2 'push)))

  (define-simple-proc do-nothing (((args (rest <object>))) <object> pure)
    null)

  (define-simple-proc do-swap (((args (rest <object>))) <object> pure)
    (debug-print "do-swap ENTER")
    (let* ((args1 (cast (:tuple <object> <object>) args))
	   (obj1 (car args1))
	   (obj2 (car (cdr args1))))
      (debug-print "do-swap EXIT")
      (list obj2 obj1)))

  (define-simple-proc do-dup (((args (rest <object>))) <object> pure)
    (let ((obj (car (cast (:tuple <object>) args))))
      (list obj obj)))

  (define panel-stack-ops <panel>
    (list
     (list
      (list "drop" do-nothing 1 'push-list)
      (list "swap" do-swap 2 'push-list)
      (list "dup" do-dup 1 'push-list)
      (list "clear" do-nothing 'all 'push-list))))

  (define ins
    (lambda (((str <string>)) (:procedure ((rest <object>)) <object> pure) pure)
      (lambda (((lst-args (rest <object>))) <object> pure)
	(string-append (car (cast (:pair <string> <object>) lst-args))
		       str))))

  (define-simple-proc del (((lst-args (rest <object>))) <object> pure)
    (let* ((str-entry (car (cast (:pair <string> <object>) lst-args)))
	   (i-len (string-length str-entry)))
      (if (> i-len 0)
	  (substring str-entry 0 (- i-len 1))
	  str-entry)))


  (define-simple-proc main (() <none> nonpure)

    (let* ((panel-arith-ops
	    <panel>
	    (list
	     (list
	      (unary-op "+-" -)
	      (binary-op "+" +)
	      (binary-op "-" -)
	      (binary-op "*" *)
	      (binary-op "/" /))))

	   (panel-trans-ops
	    <panel>
	    (list
	     (list
	      (unary-op "sin" sin)
	      (unary-op "cos" cos)
	      (unary-op "tan" tan)
	      (unary-op "exp" exp))
	     (list
	      (unary-op "asin" asin)
	      (unary-op "acos" acos)
	      (unary-op "atan" atan)
	      (unary-op "log" log))
	     (list
	      (unary-op "sinh" sin)
	      (unary-op "cosh" cos)
	      (unary-op "tanh" tan)
	      (binary-op "expt" expt))))

	   (panel-digit-pad
	    <panel>
	    (list
	     (list
	      (unary-op "+-" -)
	      (list "ENTER" do-nothing 0 'push-list)
	      (list "DEL" del 'entry 'set-entry)
	      (binary-op "complex" my-complex)
	      (unary-op "Re" my-real-part)
	      (unary-op "Im" my-imag-part))
	     (list
	      (list "7" (ins "7") 'entry 'set-entry)
	      (list "8" (ins "8") 'entry 'set-entry)
	      (list "9" (ins "9") 'entry 'set-entry)
	      (binary-op "/" /))
	     (list
	      (list "4" (ins "4") 'entry 'set-entry)
	      (list "5" (ins "5") 'entry 'set-entry)
	      (list "6" (ins "6") 'entry 'set-entry)
	      (binary-op "*" *))
	     (list
	      (list "1" (ins "1") 'entry 'set-entry)
	      (list "2" (ins "2") 'entry 'set-entry)
	      (list "3" (ins "3") 'entry 'set-entry)
	      (binary-op "-" -))
	     (list
	      (list "0" (ins "0") 'entry 'set-entry)
	      (list "." (ins ".") 'entry 'set-entry)
	      (list "SPC" (ins " ") 'entry 'set-entry)
	      (binary-op "+" +))))

	   (lst-panels1
	    (:uniform-list <panel>)
	    (list panel-stack-ops panel-trans-ops panel-digit-pad)))

      (make-calculator lst-panels1)
      (gtk-main))))
