calculator

calc-main.scm

; test calc
; https://gist.github.com/yamasushi/c956ae30eb20adef2c7c7afd0b70311a

(load "./lex")
(import lex)

(load "./calc")
(import calc)

(use gauche.generator)
(use math.const)

  (define op-symmap
  `(
    (+ . ,+)
    (- . ,-)
    (* . ,*)
    (/ . ,/)
    (% . ,modulo)
    (^ . ,expt)
  )
)

(define fn-symmap
  `(
    (-   . ,- )
    (sin . ,(^d (sin (* pi/180 d) ) ) )
    (cos . ,(^d (cos (* pi/180 d) ) ) )
    (tan . ,(^d (tan (* pi/180 d) ) ) )
    (ln  . ,log)
    (log . ,(cut log <> 10) )
  )
)

(define vars
  `(
    ( pi . ,pi )
    ( e  . ,e )
  )
)

(define (op opsym x y)
  (if-let1 kv (assv opsym op-symmap)
      ((cdr kv) x y)
      (undefined) ) )

(define (fn fnsym x)
  (if-let1 kv (assv fnsym fn-symmap)
      ((cdr kv) x)
      (undefined) ) )

(define (var varsym)
  (if-let1 kv (assv varsym vars)
      (cdr kv)
      (undefined) ) )

(define calc-emitter
  (case-lambda
    [(varsym)     (var varsym)]
    [(fnsym x)    (fn  fnsym x)]
    [(opsym x y)  (op  opsym x y)]))

(define (calc str)
  (let-values(
      [(syn _)
        (expr
          (make-calc-context
            ($ generator->lseq $ lexer $ string->list str)
            calc-emitter ) ) ] ) syn) )

(define sexp-emitter
  (case-lambda
    [(varsym)     varsym]
    [(fnsym x)    `(,fnsym ,x)]
    [(opsym x y)  `(,opsym ,x ,y)]))

(define (sexp str)
  (let-values(
      [(syn _)
        (expr
          (make-calc-context
            ($ generator->lseq $ lexer $ string->list str)
            sexp-emitter ) ) ] ) syn) )

calc.scm

;
; desk calculator
; https://gist.github.com/yamasushi/c956ae30eb20adef2c7c7afd0b70311a

(define-module calc
  (export expr make-calc-context)
  (use gauche.record)
  )
(select-module calc)

(define-record-type <calc-context> make-calc-context calc-context?
  (xs       calc-context-xs)
  (emitter  calc-context-emitter))

(define (emit context sym . arg)
  (let1 emitter (calc-context-emitter context)
    (apply (pa$ emitter sym) arg ) ) )

(define (set-xs context xs)
  (make-calc-context xs (calc-context-emitter context) ) )

; expr -> term {rest.inh = term.syn} rest {expr.syn = rest.syn}
; rest -> + term {rest_1.inh = rest.inh + term.syn } rest_1 {rest.syn = rest_1.syn}
;      |  - term {rest_1.inh = rest.inh - term.syn } rest_1 {rest.syn = rest_1.syn}
;      | ε {rest.syn = rest.inh}
; term -> factor {rest2.inh = factor.syn} rest2 {term.syn = rest2.syn}
; rest2 -> * factor {rest2_1.inh = rest2.inh * factor.syn} rest2_1 {rest2.syn = rest2_1.syn}
;      |   / factor {rest2_1.inh = rest2.inh / factor.syn} rest2_1 {rest2.syn = rest2_1.syn}
;      | ε {rest2.syn = rest2.inh}
; factor -> <integer> {factor.syn = <integer>.syn }
;      | ( expr ) {factor.syn = expr.syn}
;      | <func> ( expr ) {factor.syn = <func>(expr.syn) }

(define (restx syms termx inh context)
  (define (_restx_ inh context)
    (let1 xs (calc-context-xs context)
      (if (null? xs)
        (values inh context) ; ε
        (let ( [ttype (caar xs)] [tval (cdar xs)] )
          (cond
            {(and (eq? ttype 'op) (find (pa$ eqv? tval) syms) )
              (let-values ([(syn_ context_)
                              (termx (set-xs context (cdr xs) ))])
                (_restx_ (emit context_ tval inh syn_) context_) ) }
            {else (values inh context)}  ; ε
          ) ) ) ) )
  ;	(format #t "restx syms=~s inh=~s xs=~s~%" syms inh xs)
  (_restx_ inh context) )

; expr -> term {rest.inh = term.syn} rest {expr.syn = rest.syn}
(define (expr context)
  ;(format #t "expr: inh=~s xs=~s~%" inh xs)
  ( [.$ rest1 term1] context) )

; term1 -> term2 {rest2.inh = term2.syn} rest2 {term.syn = rest2.syn}
(define (term1 context)
  ;(format #t "term1: inh=~s xs=~s~%" inh xs)
  ( [.$ rest2 term2] context) )

; rest1 -> + term1 {rest1_1.inh = rest1.inh + term1.syn } rest1_1 {rest.syn = rest_1.syn}
;      |  - term1 {rest1_1.inh = rest1.inh - term1.syn } rest1_1 {rest.syn = rest_1.syn}
;      | ε {rest.syn = rest.inh}
(define rest1 (pa$ restx '(+ -) term1) )

(define (term2 context) ( [.$ rest3 term3] context ) )

; rest2 -> * term2 {rest2_1.inh = rest2.inh * term2.syn} rest2_1 {rest2.syn = rest2_1.syn}
;      |   / term2 {rest2_1.inh = rest2.inh / term2.syn} rest2_1 {rest2.syn = rest2_1.syn}
;      | ε {rest2.syn = rest2.inh}
(define rest2 (pa$ restx '(* / %) term2 ))

(define (term3 context) (factor context))

(define rest3 (pa$ restx '(^) term3 ) )

; factor -> <integer> {factor.syn = <integer>.syn }
;      | ( expr ) {factor.syn = expr.syn}
;      | -factor1 {factor.syn = -factor1.syn}
;      | <function> ( expr ) { <function> ( expr.syn) }
(define (factor context)
  ;(format #t "factor inh=~s xs=~s~%" inh xs)
  (let1 xs (calc-context-xs context)
    (if (null? xs)
      (error "factor:error xs=~s" xs)
      (let* [ (hd (car xs)) (ttype (car hd)) (tval (cdr hd))
              (tl (cdr xs)) (context-tl (set-xs context tl) ) ]
        (cond
          {(negation? hd) ; negation
            (let-values ([(syn_ context_) (factor context-tl) ])
              (values (emit context_ '- syn_ ) context_) ) }
          {(lparen? hd) ; left parenthesis
            (let-values ([(syn_ context_) (expr context-tl)])
              (values syn_ (match-rparen context_ ) ) ) }
          {(eqv? ttype 'id_func ) ; function
              ;(format #t "function tval=~s~%" tval)
              (let1 context_ (match-lparen context-tl )
                (let-values ([(syn_ context_) (expr context_)])
                  (let1 context_ (match-rparen context_ )
                    (values (emit context_ tval syn_) context_ ) ) ) ) }
          {(eqv? ttype 'id) ; constant or variable
              (values (emit context tval) context-tl ) }
          {(eqv? ttype 'number ) ; number
              (values tval context-tl ) }
          {else
            (error "factor: xs=" xs) } ) ) ) ) )

(define (negation?  token) (equal? token '( op . - ) ) )
(define (lparen?    token) (equal? token '( paren . |(| ) ) )
(define (rparen?    token) (equal? token '( paren . |)| ) ) )

(define (match-lparen context) (match-term '( paren . |(| ) context) )
(define (match-rparen context) (match-term '( paren . |)| ) context) )

(define (match-term token context)
  ;	(format #t "match-term t=~s xs=~s~%" t xs)
  (let1 xs (calc-context-xs context)
    (if (and ($ not $ null? xs) (equal? (car xs) token) )
        (set-xs context (cdr xs))
        (errorf "syntax error token=~s xs=~s" token xs) ) ) )

gistfile1.txt

gosh$ (calc "2 * cos(30) + sin(60)")
2.598076211353316

gosh$ (sexp "(1+sin(2))*3^--4")
(* (+ 1 (sin 2)) (^ 3 (- (- 4))))

lex.scm

; lexical analysis
; https://gist.github.com/yamasushi/c956ae30eb20adef2c7c7afd0b70311a

(define-module lex
  (export lexer test-lexer)
  (use gauche.generator)
  (use scheme.list) )
(select-module lex)

(define base      10)
(define inv-base  (/. 1 base))
(define digit?    #[0-9] )
(define digit->i  digit->integer)

(define id_head?     #[a-z] )
(define id_body?     #[a-z0-9] )
(define parentheses? #[()] )
(define op?          #[+\-*/%^] )

(define (token_number  v) `(number   . ,v) )

(define (token_op      char) `(op       . ,($ string->symbol $ string char) ) )
(define (token_paren   char) `(paren    . ,($ string->symbol $ string char) ) )

(define (token_id      str) `(id       . ,(string->symbol str) ) )
(define (token_id_func str) `(id_func  . ,(string->symbol str) ) )

(define (token_eq t s)
  (and (eqv?   (car t) (car s))
       (equal? (cdr t) (cdr t)) ) )

(define (test-lexer str)
    ($ generator->lseq $ lexer $ string->list str) )

(define (lexer st)
  (generate (^[yield]
    (let loop ( [s st] )
      (if (null? s)
        (eof-object)
        (let1 hd (car s)
          ;(format #t "lexer hd=~s~%" hd)
          (cond
            { (char-set:whitespace hd ) ($ loop $ cdr s) }
            { (op? hd)          ($ yield $ token_op    hd) ($ loop $ cdr s) }
            { (parentheses? hd) ($ yield $ token_paren hd) ($ loop $ cdr s) }
            { (or (digit? hd) (eqv? #\. hd) )
              ;(format #t "lexer digit hd=~s~%" hd)
              (let-values ( [ (val rest) (num s) ] )
                  ($ yield $ token_number val) (loop rest) ) }
            { (id_head? hd)
              ;(format #t "lexer id hd=~s~%" hd)
              (let-values ( [ (val rest) (ident s) ] )
                (cond
                  {(nextchar rest) => (^[rest_]
                    (case (car rest_)
                      { ( #\( ) ($ yield $ token_id_func val) (loop rest_) }
                      { else    ($ yield $ token_id      val) (loop rest_) } ) ) }
                  { else ($ yield $ token_id val) (loop rest) }
                ) ) }
            { else (error "lexer s=~s" s) } ) ) ) ) ) ) )

(define (nextchar st)
    (let1 st (drop-while char-set:whitespace st)
        (if (null? st)
            #f
            st ) );let1
);define

(define (ident st)
  ;(format #t "ident: st=~s~%" st)
  (if (null? st)
    (error "ident: st=" st)
    (let1 hd (car st)
      (if (id_body? hd)
        (let-values ([(i rest) (span id_body? st) ])
          (values (list->string i) rest ) )
        (error "ident: st=" st) ) ) ) )

(define (test-num str) ($ values->list $ num $ string->list str) )
(define (num st)
  (define (_num_ k acc st)
    ;(format #t "_num_: k=~s acc=~s st=~s~%" k acc st)
    (if (null? st)
      (values k acc st)
      (let1 hd (car st)
        (cond
          { (digit? hd) ; head is digit
            (_num_ (+ k 1) (+ (* base acc) (digit->i hd) ) (cdr st) ) }
          { (equal? hd #\. ) ; decimal
            (let-values ( { (kdec dec st_) (_num_ 0 0 (cdr st)) } )
              ;(format #t "kdec=~s dec=~s st_=~s~%" kdec dec st_)
              (values
                  (+ k kdec 1)
                  (+ acc (/. dec (expt base kdec) ) )
                  st_ ) ) }
          { else ; head is not digit
              (values k acc st) }
        );cond
      );let
    );if
  );define
    
  ;(format #t "num: st=~s~%" st)
  (if (null? st)
    (error "num: st=~s" st)
    (let1 hd (car st)
      (cond
        {(equal? hd #\-)
            (let-values ( {(_ acc st_) (_num_ 0 0 (cdr st) ) } )
                (values (- acc) st_ ) ) }
        {(or (equal? #\. hd) (digit? hd))
            (let-values ( {( _ acc st_) (_num_ 0 0 st) } )
                (values acc st_) ) }
        { else (error "num: st=~s" st) }
      );cond
    );let
  );if
);define