;; -*-theme-d-*-

;; Copyright (C) 2015, 2020-2023 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.

;; This file is part of Theme-D-Intr.

;; You can redistribute and/or modify this file under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation, either version 3 of the License, or (at your option) any
;; later version.

;; This file is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see https://www.gnu.org/licenses/.


(define-proper-program (intr-gtk3-examples calc main)

  (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)
	  (intr-gtk3-examples calc _intr-imports))

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

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

  ;; Allow debug printing in pure procedures, too.
  (define-simple-method 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-method 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-method 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-method 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-method 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-method 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-method make-calculator
      (((app <gtk-application>) (lst-panels (:uniform-list <panel>)))
       <none>
       nonpure)
    (let* ((window (cast <gtk-window> (gtk-application-window-new app)))
	   (box (cast <gtk-vbox> (gtk-vbox-new #f 0)))
	   (scrolled-win (cast <gtk-scrolled-window>
			       (gtk-scrolled-window-new #f #f)))
	   (text-buffer (cast <gtk-text-buffer> (gtk-text-buffer-new #f)))
	   (text-view (cast <gtk-text-view>
			    (gtk-text-view-new-with-buffer text-buffer)))
	   (entry (cast <gtk-entry> (gtk-entry-new)))
	   (tag-just (gtk-text-tag-new "right-justification"))
	   (tag-table (gtk-text-buffer-get-tag-table text-buffer))
	   ;;	   (attrlist (pango-attr-list-create))
	   ;;	   (attr-background (pango-attr-background-new 65535 0 0))
	   (label-echo (cast <gtk-label> (gtk-label-new ""))))
      (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 "" -1)
		  (debug-print "redisplay/1")
		  (let ((iter (get-start-iter text-buffer)))
		    (debug-print "redisplay/2")
		    (do ((i <integer> 1 (+ i 1))
			 (lst <object> lst-stack
			      (cdr (cast (:pair <object> <object>) lst))))
			((null? lst))
		      (debug-print "redisplay/3")
		      (debug-print (car (cast (:pair <object> <object>) lst)))
		      (insert text-buffer iter
			      (string-append
			       (integer->string i)
			       ":\n"))
		      (let ((mark (create-mark
				   text-buffer "current"
				   iter
				   #t)))
			(insert
			 text-buffer iter
			 (string-append
			  (object->string
			   (car (cast (:pair <object> <object>) lst)))
			  "\n"))
			(let ((iter2 (get-iter-at-mark text-buffer mark)))
			  (apply-tag text-buffer tag-just
				     iter2
				     (gtk-text-buffer-get-end-iter
				      text-buffer))))))
		  (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)
		  (debug-print "construct-error-message")
		  (match-type exc
		    ((exc1 <condition>)
		     (if (rte-exception? exc1)
			 (case (get-rte-exception-kind exc1)
			   ((numerical-overflow) "Numerical overflow")
			   ((too-few-arguments) "Too few arguments")
			   ((invalid-real-number) "Invalid real number")
			   (else "Error"))
			 "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
			     (match-type exc
			       ((exc1 <condition>)
				(debug-print "raised")
				(debug-print (rte-exception? exc1))
				(debug-print exc1)
				(if (rte-exception? exc1)
				    (set-echo (construct-error-message exc1))
				    (raise exc))
				(set! lst-stack lst-saved-stack)
				(redisplay))
			       (else
				(raise exc)))))
			   (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)
			     null)))))
		  (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 (cast <gtk-hbox> (gtk-hbox-new #t 2))))
		    (for-each1
		     (lambda (((op-spec <op-spec>)) <none> nonpure)
		       (let ((button (cast <gtk-button>
					   (gtk-button-new-with-label
					    (car op-spec)))))
			 (gtype-instance-signal-connect
			  button 'clicked
			  (lambda (((args (rest <object>))) <object> nonpure)
			    (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)

	  (slot-set! tag-just 'justification 'right)
	  (gtk-text-tag-table-add tag-table tag-just)

	  (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-new) #f #f 1))
	   lst-panels)
	  
	  (pack-end box label-echo #f #f 0)

	  (gtype-instance-signal-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))

	  (gtype-instance-signal-connect
	   window 'destroy
	   (lambda (((args (rest <object>))) <object> nonpure)
	     (g-application-quit app)
	     null))

	  (show-all window)))))

  (define-simple-method 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-method binary-op
      (((str-name <string>)
	(proc (:procedure (<number> <number>) <number> pure)))
       <op-spec>
       pure)
    (let ((proc0 (lambda (((lst-args (rest <object>))) <object> pure)
		   ;; (guard
		   ;;  (exc (else (debug-print "exception HEP")
		   ;; 	       (raise exc)
		   ;; 	       #f))
		   (begin
		    (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)))
			   (tmp1 (begin
				   (debug-print "applying binary operator/1")
				   #f))
			   (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-method do-nothing (((args (rest <object>))) <object> pure)
    null)

  (define-simple-method 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-method 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-simple-method ins
      (((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-method 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-main-proc (() <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))

	   (str-app-name "org.tohoyn.calc")
	   (app (gtk-application-new str-app-name null))

	   (activate-my-app
	    (lambda (((args (rest <object>))) <object> nonpure)
	      (make-calculator app lst-panels1)
	      #f)))

      (g-set-prgname str-app-name)
      
      (gtype-instance-signal-connect
       app 'activate activate-my-app)
      
      (let ((status (g-application-run app null)))
	status))))
