mul

MUL.rkt

#lang lazy

(require "Lambda.rkt")
; (provide (all-defined-out))

; note to self: remember to replace this with an actual constant
; (define basic-cutoff (NAT (sub1 (expt 2 (quotient 64 2)))))
(define basic-cutoff (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True (Cons True Empty)))))))))))))))))))))))))))))))))

(define (adv-co co)
  (If (Empty? co) Empty
  (If (Car co) (Cons False (Cdr co))
               (Cdr co))))

(define (longer-than number co-gen)
 ; (co-gen) is a slightly modified church numeral, used exclusively for counting.
 ; it is zero when empty, and we subtract one by either replacing its first value with false
 ; or cutting it off.
 (If (Empty? co-gen) True
   (If (Empty? number) False
     (longer-than (Cdr number) (adv-co co-gen)))))

(define (mul-slow-accum total a b)
  (If (Empty? b) total
    (mul-slow-accum (If (Car b) (ADD total a) total) (Cons False a) (Cdr b))))

(define (mul-slow a b)
;(begin (printf "~a slow* ~a\n" (TAN a) (TAN b))
   (mul-slow-accum Z a b)
;)
)

(define (proper-Z? a)
  (If (Empty? a) True
    (If (Car a) False
      (proper-Z? (Cdr a)))))

(define (SUB1 x)
; (If (proper-Z? x) (error "negative")
    (If (Empty? (Cdr x)) Z
      (If (Car x) (Cons False (Cdr x))
        (Cons True (SUB1 (Cdr x)))))
; )
)

(define (SUB a b)
  (If (proper-Z? b) a
;   (If (proper-Z? a) (error "negative")
      (If (Not (Car b)) (Cons (Car a) (SUB (Cdr a) (Cdr b)))
        (If (Car a)     (Cons (Not (Car b)) (SUB (Cdr a) (Cdr b)))
          (Cons True (SUB1 (SUB (Cdr a) (Cdr b))))))
;   )
))

(define (fix-Z a)
  (If (proper-Z? a) Z a))

(define (revappend a b)
  (If (Empty? a) b
    (revappend (Cdr a) (Cons (Car a) b))))

; (define (GTR a b))

(define (split-in-half-accum ptra ptrb ptrla ptrlb lowera lowerb)
  (If (Or (Empty? ptra) (Or (Empty? ptrb) (Or (Empty? (Cdr ptra)) (Empty? (Cdr ptrb)))))
    (Cons (Cons ptrla ptrlb) (Cons (revappend lowera Empty) (revappend lowerb Empty)))
    (split-in-half-accum (Cdr (Cdr ptra)) (Cdr (Cdr ptrb)) (Cdr ptrla) (Cdr ptrlb)
                         (Cons (Car ptrla) lowera) (Cons (Car ptrlb) lowerb))))

(define (split-in-half a b)
  (split-in-half-accum a b a b Empty Empty))

(define (scale-by-length a b)
  (If (Empty? b) a
    (scale-by-length (Cons False a) (Cdr b))))

(define (mul-fast-3 a b splitbuf z0 z1 z2)
  (ADD (ADD (scale-by-length (scale-by-length z2 (Car (Cdr splitbuf))) (Car (Cdr splitbuf)))
    (scale-by-length (SUB (SUB z1 z2) z0) (Car (Cdr splitbuf)))) z0)) 

(define (mul-fast-2 a b splitbuf)
 (mul-fast-3 a b splitbuf
   (MUL (Car (Cdr splitbuf)) (Cdr (Cdr splitbuf)))
   (MUL (ADD (Car (Car splitbuf)) (Car (Cdr splitbuf))) (ADD (Cdr (Car splitbuf)) (Cdr (Cdr splitbuf))))
   (MUL (Car (Car splitbuf)) (Cdr (Car splitbuf)))))

(define (mul-fast a b)
; (begin (printf "~a fast* ~a\n" (TAN a) (TAN b))
    (mul-fast-2 a b (split-in-half a b))
; )
)

(define (MUL a b)
; (begin (printf "~a times ~a\n" (TAN a) (TAN b))
 (If (Or (proper-Z? a) (proper-Z? b)) Z
 (If (And (longer-than a basic-cutoff) (longer-than b basic-cutoff))
    (fix-Z (mul-fast a b))
    (If (longer-than a basic-cutoff) (mul-slow a b)
    (mul-slow b a))))
; )
)

; (display (TAN (MUL (NAT 1237123612723598017684312398416723489034578123094167284091347856123094137684410923546781234690243789) (NAT 123716583912371232487151239041237416234781324980124095823547183246123481498065239085513254679))))