irrational rational

もう時効っぽいから晒してみよう。必殺仕事請負人で適当に作った課題作品。

循環小数(=> 有理数)の計算結果の小数ストリームから循環部分を探すスクリプト。除算の結果を先頭から適当な状態機械に食わせて循環部分とそれ以外の 2 値を返す。

コマンドラインから 2 つの数字が与えられた場合にはその除算結果を、与えられなかった場合には Gauche の (test) フレームワークで適当なテストを実行した結果を返している。

#!/usr/bin/env gosh
;;
;; Display cyclic part of real number and its length
;;
;; % gosh rational.scm 1 3
;; 0.(3)
;; 1
;;
;; % gosh rational.scm 5 7
;; 0.71(428571)
;; 6
;;

(use srfi-1)
(use srfi-43)

(define *division-limit* 50) ; limitation of divisor places

;; get the quotient of `num' by `dem' inexactly.
(define (quotient->list num dem)
  (cond [(zero? dem) (error "zero division error")] ; euclid
        [else
          (let loop ((n (remainder num dem)) ; numerator
                     (d dem)     ; denominator
                     (i 0)       ; loop counter
                     (r '()))    ; result
            (if (and (not (zero? n))
                     (< i *division-limit*))
              (loop (remainder (* n 10) d)
                    d
                    (+ i 1)
                    (cons (quotient (* n 10) d) r))
              (values (quotient num dem)
                      (reverse r))))]))

;; test if the vector `vec' is a multipler of `sub'
(define (cyclic-vector? vec sub)
  (cond [(vector-empty? vec) #t] ; n * 0 ==> 0
        [(vector-empty? sub) #f]
        [(equal? (vector-copy vec 0 (vector-length sub)) sub) ; test from prefix
         (cyclic-vector? (vector-copy vec (vector-length sub)) sub)]
        [else #f]))

;; separate list of `lis' into two lists of non-cycled numbers and cycled numbers.
(define (find-cycle lis)
  (if (not (<= 0 (apply min lis) (apply max lis) 9))
    (error "no proper list given"))

  (let ((vec (list->vector lis)) ; convert to vector for easy index accessing
        (len (length lis)))
    (let ind_loop ((ind 0)) ; test from first in the vector
      (if (< ind (- len 1)) ; til one before last one
        (let loop ((shift (+ ind 1)))
          (if (< shift len) ; search same value in vec@ind after ind
            (let* ((eir (vector-index (cut = (vector-ref vec ind) <>) ; relative value from shift
                                      (vector-copy vec shift)))
                   (eia (if eir (+ shift eir) eir)))                  ; absolute value from zero
              (if (and eia
                       (< eia len)
                       (<= (- (* eia 2) ind) len))
;; construct subset of the vector starts from `ind' and `eia'
;; the first value of them are the same. (was tested before)
                (let ((head (vector-copy vec ind eia))
                      (tail (vector-copy vec eia (- (* eia 2) ind))))
;; test if head and tail are equal.
;; if they are same, test the rest of vector if the multiple of `head'.
;; the rested vector will be rounded as the multipler of length of `head'.
                  (if (and (equal? head tail)
                           (cyclic-vector? (vector-copy vec eia
                                                            (- len (remainder (- len eia)
                                                                              (- eia ind))))
                                            head))
                    (values (vector->list (vector-copy vec 0 ind)) ; return results
                            (vector->list head)) ; head is cycled
                    (loop (+ eia 1)))) ; if head and tail are not proper, try vector-index again
                (ind_loop (+ ind 1))))
            (ind_loop (+ ind 1)))) ; if same value of the first one not found, increment the index
        (values lis '()))))) ; if no proper result found, return original list as non-cycled.

(define (main args)
  (if (< (length args) 3) ; run tests if arguments not reached to run calculation
    (begin
      (use gauche.test)

      (test-start (car args))

      (let test:quotient->list ((lis '(
(3 1   (3 ()))
(1 6   (0 (1 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6)))
(5 7   (0 (7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1)))
(1 250 (0 (0 0 4)))
                                    )))
        (if (pair? lis)
          (let ((n (caar   lis))
                (d (cadar  lis))
                (r (caddar lis)))
            (test* #`"(quotient->list ,n ,d)"
                   r
                   (receive (div lis)
                            (quotient->list n d)
                            (list div lis)))
            (test:quotient->list (cdr lis)))))

      (let test:cyclic-vector? ((lis '(
(#(0 0 0 0)     #()      #f)
(#(0 0 0 0)     #(0)     #t)
(#(0 1 0 1)     #(0 1)   #t)
(#(0 1 2 0 1 2) #(0 1 2) #t)
                                      )))
        (if (pair? lis)
          (let ((v (caar   lis))
                (s (cadar  lis))
                (r (caddar lis)))
            (test* #`"(cyclic-vector? ,v ,s)"
                   r
                   (cyclic-vector? v s))
            (test:cyclic-vector? (cdr lis)))))

      (let test:find-cycle ((lis '(
((0 0 0 0)         (()      (0)))
((0 1 0 1)         (()      (0 1)))
((0 1 0 1 0)       (()      (0 1)))
((0 1 1 1)         ((0)     (1)))
((0 1 1 1 1)       ((0)     (1)))
((0 1 2 0 1 2)     (()      (0 1 2)))
((0 1 2 0 1 2 0)   (()      (0 1 2)))
((0 1 2 0 1 2 0 1) (()      (0 1 2)))

((1 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6 6) ((1) (6)))
((7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1 4 2 8 5 7 1) (() (7 1 4 2 8 5)))
((0 0 4)           ((0 0 4) ()))
((0 0 5 0 0)       ((0 0 5) (0)))
((0 0 6 0 0 0)     ((0 0 6) (0)))
                                  )))
        (if (pair? lis)
          (let ((l (caar  lis))
                (r (cadar lis)))
            (test* #`"(find-cycle ,l)"
                   r
                   (receive (base cycle)
                            (find-cycle l)
                            (list base cycle)))

            (test:find-cycle (cdr lis)))))

      (test-end))
    (begin
;; for validation
;     (print (/. (string->number (list-ref args 1))
;                (string->number (list-ref args 2))))

      (display #`",(list-ref args 1) / ,(list-ref args 2) == ")
      (receive (div base cycle)
               (receive (div lis)
                        (quotient->list (string->number (list-ref args 1))
                                      (string->number (list-ref args 2)))
                        (if (null? lis) ; lis is null -> rational
                          (values div '(0) '(0))
                          (receive (base cycle)
                                   (find-cycle lis)
                                   (values div base cycle))))
;; display quotient and cycled value
               (format #t "~a.~a(~a)\n" div ; (not (null? cycle)) -> rational
                                        (list->string (map integer->digit base))
                                        (list->string (map integer->digit cycle)))
;; display length of cycled numbers
               (format #t "~a\n" (length cycle)))))
  0)

作り終わって一通りテストも通ってから、状態機械なんか作らなくても解ける問題だったらしいことを聞いてしまって自分の数学的センスのなさに軽くブルー。

べ、別に状態機械作ってみたくなっただけなんだからねっ…ってのは置いといて、Gauche の UnitTest フレームワークを実際に使ってみる良い機会になった。もっと勉強しないといけない。