#lang racket
(require (planet "main.rkt" ("samsergey" "rewrite.plt" 1 0))
         rackunit)
;;;====================================================
;;; Simple examples
;;;====================================================

;; singlefold rewriting
(check-equal?  ((/. 'a --> 'b 
                    'b --> 'c
                    'c --> 'd) '(a b c d)) 
               '(b c d d))

(check-equal?  ((/. 'a --> 'b 
                    'b --> 'c
                    'c --> 'a) '(a b c d)) 
               '(b c a d))

;; using multiary rules
(check-equal?  ((/. 'a --> 'b 
                    'b 1 --> 'c
                    'c 1 2 --> 'a) 'a) 
               'b)

(check-equal?  ((/. 'a --> 'b 
                    'b 1 --> 'c
                    'c 1 2 --> 'a) 'b 1) 
               'c)

(check-equal?  ((/. 'a --> 'b 
                    'b 1 --> 'c
                    'c 1 2 --> 'a) 'x 'y 'z 't) 
               '(x y z t))

;; repetitive rewriting
(check-equal?  ((//. 'a --> 'b 
                     'b --> 'c
                     'c --> 'd) '(a b c d)) 
               '(d d d d))

(check-equal?  ((//. 'a -->. 'b ; terminal rule
                     'b --> 'a
                     'c --> 'a) '(a b c d)) 
               '(b b b d))

;;====================================================
;; Definition of recursive funtions
;;====================================================

(define/. length
  ; length of the list
  (cons _ t) --> (+ 1 (length t))
  '() --> 0)

(define/. depth
  ; depth of the nested list structure
  (? list? x) --> (+ 1 (apply max (map depth x)))
  _ --> 0)

(define fib
  ; n -th Fibonacci number
  (replace
   1 --> 0
   2 --> 1
   n --> (fib 0 1 n)
   a b 3 --> (+ a b)
   a b i --> (fib b (+ a b) (- i 1))))

(define/. palindrom?
  ; palindrom test
  (or '() (list _)) --> #t 
  (list x y ___ x)  --> (palindrom? y))

(check-true   (palindrom? '()))
(check-true   (palindrom? '(a a)))
(check-true   (palindrom? '(a b a)))
(check-equal? (palindrom? '(r e v o l v e r)) '(o l))

;;====================================================
;; Symbolic expansion for the logarythmic function
;;====================================================
(define ln-expand
  (replace-all-repeated
   `(ln (,x __1 * ,y __1)) --> `((ln ,x) + (ln ,y)) 
   `(ln (,x __1 / ,y __1)) --> `((ln ,x) - (ln ,y)) 
   `(ln (,x ^ ,n))         --> `(,n * (ln ,x)) 
   `(ln (,x))              --> `(ln ,x)))

(check-equal? (ln-expand '(ln(x * y)))           '((ln x) + (ln y)))
(check-equal? (ln-expand '(ln(x / y)))           '((ln x) - (ln y)))
(check-equal? (ln-expand '(ln(x * y / z)))       '((ln x) + ((ln y) - (ln z))))
(check-equal? (ln-expand '(ln(x / (y * z))))     '((ln x) - ((ln y) + (ln z))))
(check-equal? (ln-expand '(ln(x ^ 2 / (y * z)))) '((2 * (ln x)) - ((ln y) + (ln z))))
(check-equal? (ln-expand '(ln(x + y)))           '(ln (x + y)))
(check-equal? (ln-expand '(ln(8 * (x + y))))     '((ln 8) + (ln (x + y))))
(check-equal? (ln-expand '(ln(ln(x ^ n))))       '((ln n) + (ln(ln x))))

;;====================================================
;; Hoare's quicksort
;;====================================================

(define (split x l)
  (foldl (/. y `(,l ,r) --> (? (< y x)) `(,(cons y l) ,r)
             y `(,l ,r) -->             `(,l ,(cons y r))) 
         '(() ()) l))

(define qsort
  (replace-repeated
   (cons x y) --> (values x (split x y))
   x `(,l ,r) -->. (append (qsort l) `(,x) (qsort r))))

(check-equal? (qsort '()) '())
(check-equal? (qsort '(1 1)) '(1 1))
(check-equal? (qsort '(2 4 1 3 2 6 9 2)) '(1 2 2 2 3 4 6 9))

;;====================================================
;; The bisection method for solving algebraic equations
;;====================================================
(define (bisection f)
  (replace-repeated
   ; start iterations
   a b --> (values a b (f a) (f b))
   ; no roots
   _ _ fa fb -->. (? (> (* fa fb) 0)) #f
   ; stop iterations when needed accuracy is achieved
   a b _ _   -->. (? (almost-equal? a b)) a
   ; general case
   a b fa fb -->. (let* ([c (/ (+ a b) 2.)]
                         [fc (f c)])
                    (or ((bisection f) a c fa fc)
                        ((bisection f) c b fc fb)))))


(check almost-equal? ((bisection (λ(x)(- x 2))) 1 3) 2)
(check almost-equal? ((bisection (λ(x)(- (sin x) .4))) 0 2) (asin 0.4))