newlispfanclub.alh.net

Code: Select all

(context 'Q)

;; '(2) means 2/1, '(1 2) means 1/2, and (2 2 3) means 2 2/3
;; all functions below will work with the above types
;; (Q:neg '(1 2) => (-1 2) 
;; (Q:reciprical '(-2 3) => (-3 2)
;; (Q:+ '(1 2) '(1 3)) => (5 6)
;; (Q:- '(1 2) '(1 3)) => (1 6)
;; (Q:* '(1 2) '(1 3)) => (1 6)
;; (Q:/ '(1 2) '(1 3)) => (3 2)


(define (gcd_ a b)
;; used to reduce fractions
  (let (r (% b a)) (if (= r 0) a (gcd_ r a))))
	
(define (frac-form a b)
;; reduce and fix negatives so that -a/-b => a/b, a/-b => -a/b
	(if 
		(= a 0)
			'(0 1)
		(= b 0)
			(throw "rational-number-error")
		(let (dd (gcd_ a b))
			(let (a (/ a dd) b (/ b dd))
				(if 
					(and (< a 0) (< b 0))
						(map abs (list a b))
					(and (>= a 0) (< b 0))
						(list (- 0 a) (abs b))
					(list a b))))))

(define (improper L)
;; convert a -> a/1 and  a b/c -> (c*a+b)/c
	(map set '(n d)
	  (if 
			(= (length L) 1)
				(list (first L) 1)
			(= (length L) 2)
				L
			(= (length L) 3) 
				(list (+ (nth 1 L)  (* (first L) (last L)))  (last L))))
	(frac-form n d))
	
(define (neg A)
	(map set '(n d) (improper A))
	(frac-form (- 0 n) d))
	
(define (add_q A B)
	(map set '(n0 d0 n1 d1) (append (improper A) (improper B)))
  (let (n (+ (* n0 d1) (* n1 d0))  d (* d0 d1))
		(if (frac-form n d))))
		
(define (sub_q A B)
	(add_q A (neg B)))
	
(define (mul_q A B)
	(map set '(n0 d0 n1 d1) (append (improper A) (improper B)))
	(frac-form (* n0 n1) (* d0 d1)))
	
(define (reciprical A)
	(frac-form (last A) (first A)))

(define (div_q A B)
	(mul_q A (reciprical B)))
	
(define (->string A)
	(if (= (last A) 1)
		(string (first A))
		(string (first A) "/" (last A))))

(constant 'Q:+ add_q)
(constant 'Q:- sub_q)
(constant 'Q:* mul_q)
(constant 'Q:/ div_q)

(context 'MAIN)

Code: Select all

(define-macro (qadd) (apply add_q (args) 2))

Code: Select all

list expected : (if (= (length Q:L) 1) 

 (list (first Q:L) 1) 

 (= (length Q:L) 2) Q:L 

 (= (length Q:L) 3) 

 (list (+ (nth 1 Q:L) (* (first Q:L) (last Q:L))) (last Q:L)))

called from user defined function improper

Code: Select all

(context 'Q)

(constant 'Q:+)   ; create local version of +
 ...

(define (add_q)
   ...
   ...
   )

...
...

(constant '+ add_q)    ; can ommit the Q prefix because '+' refers to  local '+'

(context 'MAIN)

Code: Select all

;; demonstrate overloading of operators inside a context
;;
;; (Q:foo 4 4) => 6

(context 'Q)

(constant 'Q:+)  ; create local version of +

(define (greedy-add x y)
   (add x (div y 2)))

(define (foo x y)
   (+ x y))

(constant '+ greedy-add)

(context 'MAIN)

Code: Select all

(context 'Q)

(constant 'Q:+ 
	(lambda (x y)   (add x (div y 2))))

(define (foo x y)
   (+ x y))

(context 'MAIN)

Code: Select all

(define-macro (qadd)
 (apply add_q (args) 2))

Code: Select all

(Q:add_q '(1 2) '(3 4))

Code: Select all

(Q:+ 2 (1 2) (1 3) (1 1 2)) => (13 3)