PasteRack.org
Paste # 30875
2017-06-06 13:45:26

Fork as a new paste.

Paste viewed 251 times.


Embed:

  1. #lang racket
  2.  
  3. (define n 3)
  4.  
  5. ;; If @term contains at least n r's in the front,
  6. ;; return (#f . rest-of-term).
  7. ;; If @term does not contain that many r's in the front,
  8. ;; return (#t . (r-part . rest-of-term)).
  9. (define (seperate-adjacent-r term)
  10.   (define (helper count r-list term)
  11.     (if (null? term)
  12.         (cons #t (cons r-list term))
  13.         (if (eq? (car term) 'r)
  14.             (if (= count (- n 1))
  15.                 (cons #f (cdr term))
  16.                 (helper (+ count 1) (cons 'r r-list) (cdr term)))
  17.             (cons #t (cons r-list term)))))
  18.   (helper 0 '() term))
  19.  
  20. (define (term-changed? term)
  21.   (car term))
  22. (define (get-term term)
  23.   (cdr term))
  24.  
  25. (define (reduce-term term)
  26.   (if (null? term)
  27.       (cons #f '())
  28.       ;; Term is not null
  29.       (if (eq? (car term) 's)
  30.           ;; First element is s
  31.           (if (null? (cdr term))
  32.               ;; Only element is s
  33.               (cons #f term)
  34.               ;; There is more to reduce after the s
  35.               (if (eq? (cadr term) 's)
  36.                   ;; First two elements are s's, cancel them
  37.                   (cons #t (get-term (reduce-term (cddr term))))
  38.                   ;; There is an s followed by an r
  39.                   (let ([rest-reduced (reduce-term (cdr term))])
  40.                     (if (term-changed? rest-reduced)
  41.                         ;; If the following code after the s has changed, reduce some more
  42.                         (cons #t (get-term (reduce-term (cons 's (get-term rest-reduced)))))
  43.                         ;; Nothing changed, return result
  44.                         (cons #f term)))))
  45.           ;; First element is not s
  46.           (let ([result (seperate-adjacent-r term)])
  47.             (if (car result)
  48.                 ;; Not enough r's are present to cancel, look ahead of them
  49.                 (let ([rest-reduced (reduce-term (cddr result))])
  50.                   (if (null? (get-term rest-reduced))
  51.                       ;; Nothing is after the r's, return the result
  52.                       (cons #f (cadr result))
  53.                       (if (eq? (car (get-term rest-reduced)) 's)
  54.                           ;; There is an s after the r, perform the sr transformation
  55.                           (cons #t
  56.                                 (get-term (reduce-term (append (reverse (cdr (reverse (cadr result))))
  57.                                                                (cons 's (build-list (- n 1) (lambda (x) 'r)))
  58.                                                                (cdr (get-term rest-reduced))))))
  59.                           ;; Only r's after the r, reduce some more
  60.                           (cons (term-changed? rest-reduced)
  61.                                 (get-term
  62.                                  (reduce-term
  63.                                   (append (cadr result)
  64.                                           (get-term rest-reduced))))))))
  65.                 ;; We cancelled n r's, reduce the rest of the term
  66.                 (cons #t (get-term (reduce-term (cdr result)))))))))
  67.  
  68. (define (make-term x y)
  69.   (define (helper x y result)
  70.     (if (= y 0)
  71.         (if (= x 0)
  72.             result
  73.             (helper (- x 1) y (cons 's result)))
  74.         (helper x (- y 1) (cons 'r result))))
  75.   (helper x y '()))
  76.  
  77. ;; Given an @n encoding a sum of terms, generate the actual list of terms in the sum
  78. (define (number->term-sum num)
  79.   (define (helper num result shift-count)
  80.     (if (= num 0)
  81.         result
  82.         (if (= (modulo num 2) 1)
  83.             (helper (/ (- num 1) 2)
  84.                     (cons (let ([x (if (< shift-count n)
  85.                                        0
  86.                                        1)]
  87.                                 [y (if (< shift-count n)
  88.                                        shift-count
  89.                                        (- shift-count n))])
  90.                             (get-term (reduce-term (make-term x y))))
  91.                           result)
  92.                     (+ shift-count 1))
  93.             (helper (/ num 2) result (+ shift-count 1)))))
  94.   (helper num '() 0))
  95.  
  96. ;; Given two number @x and @y that encode two sums of terms,
  97. ;; multiply the sums together
  98. (define (multiply-sums-of-terms x y)
  99.   (let ([sumA (number->term-sum x)]
  100.         [sumB (number->term-sum y)])
  101.     (define (helper sum0 sum1 result)
  102.       (if (null? sum0)
  103.           result
  104.           (if (null? sum1)
  105.               (helper (cdr sum0) sumB result)
  106.               (helper sum0
  107.                       (cdr sum1)
  108.                       (cons (get-term
  109.                              (reduce-term
  110.                               (append (car sum0)
  111.                                       (car sum1))))
  112.                             result)))))
  113.     (helper sumA sumB '())))
  114.  
  115. ;; Given a @sum, encode the elements into numbers for easy use
  116. (define (encode-sum sum)
  117.   (define (encode-element e result)
  118.     (if (null? e)
  119.         result
  120.         (if (eq? (car e) 's)
  121.             (encode-element (cdr e) (+ result n))
  122.             (encode-element (cdr e) (+ result 1)))))
  123.   (define (helper sum result)
  124.     (if (null? sum)
  125.         result
  126.         (helper (cdr sum)
  127.                 (cons (encode-element (car sum) 0)
  128.                       result))))
  129.   (helper sum '()))
  130.  
  131. ;; Given an encoded sum of terms, tally up the terms
  132. (define (tally-sum-terms sum)
  133.   (define (helper result-table sum)
  134.     (if (null? sum)
  135.         result-table
  136.         (let ([num (car sum)])
  137.           (vector-set! result-table
  138.                        num
  139.                        (+ (vector-ref result-table num) 1))
  140.           (helper result-table (cdr sum)))))
  141.   (helper (make-vector (* 2 n) 0) sum))
  142.  
  143. ;; Given a tally table, reduce that table
  144. (define (reduce-tally-table table)
  145.   (for ([i (in-range 0 (* 2 n))])
  146.     (vector-set! table
  147.                  i
  148.                  (modulo (vector-ref table i)
  149.                          2)))
  150.   table)
  151.  
  152. (define (product-equals-1? x y)
  153.   (let ([product (multiply-sums-of-terms x y)])
  154.     (let ([encoded-product (encode-sum product)])
  155.       (let ([tally-table (tally-sum-terms encoded-product)])
  156.         (let ([reduced-table (reduce-tally-table tally-table)])
  157.           (define (scan-table table index)
  158.             (if (= index (* 2 n))
  159.                 (if (= (vector-ref table 0) 1)
  160.                     #t
  161.                     #f)
  162.                 (if (= (vector-ref table index) 1)
  163.                     #f
  164.                     (scan-table table (+ index 1)))))
  165.           (scan-table reduced-table 1))))))
  166.  
  167. ;(read)
  168. ;(product-equals-1? #b1011100 #b111)
  169.  
  170. (define count 0)
  171. (for ([x (in-range 0 (expt 2 (* 2 n)))])
  172.   (for ([y (in-range 0 (expt 2 (* 2 n)))])
  173.     (if (product-equals-1? x y)
  174.         (begin (printf "~x, ~x~n"
  175.                        x
  176.                        y)
  177.                (set! count (+ count 1)))
  178.         (void))))
  179. (display count)

=>