;; -*-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 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 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 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-set0! 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))))
