home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 1999 April / VPR9904A.BIN / Vpr_data / Special / Yoolw101 / Yoolw101.lzh / BENT.YO < prev    next >
Lisp/Scheme  |  1998-03-21  |  2KB  |  100 lines
  1. ;
  2. ;    ベンチマークテスト
  3. ;
  4. (de 'wa '(lambda(x)(cond
  5.     ((zerop x)0)
  6.     (t (plus x (wa (sub1 x))))
  7. )))
  8. (de 'wa2 '(lambda(x)(prog(y)
  9.     (set 'y 0)
  10.     loop1
  11.     (set 'y (plus x y))
  12.     (set 'x (sub1 x))
  13.     (if (zerop x)(return y)(go loop1))
  14. )))
  15. (de 'tarai '(lambda(x y z)(cond
  16.     ((greaterp x y)(tarai (tarai (sub1 x) y z)(tarai (sub1 y) z x)(tarai (sub1 z) x y)))
  17.     (t y)
  18. )))
  19. (de 'fibn '(lambda(x)(cond
  20.     ((zerop x) 1)
  21.     ((eq x 1) 1)
  22.     (t (plus (fibn (sub1 x)) (fibn (difference x 2))))
  23. )))
  24. (de 'fact '(lambda(x)(cond
  25.     ((lessp x 0) 'error)
  26.     ((zerop x) 1)
  27.     (t (times x (fact (sub1 x))))
  28. )))
  29.  
  30. (de 'nqueen '(lambda(m)(queen m nil m)))
  31. (de 'queen '(lambda(n b l)(cond
  32.     ((zerop n) nil)
  33.     ((member n b) (queen (sub1 n) b l))
  34.     ((qp 1 b) (queen (sub1 n) b l))
  35.     (t (nconc
  36.         (cond
  37.             ((eq (length b) (sub1 l)) (cons (cons n b) nil))
  38.             (t (queen l (cons n b) l))
  39.         )
  40.         (queen (sub1 n) b l)
  41.     ))
  42. )))
  43. (de 'qp '(lambda(k m)(cond
  44.     ((null m) nil)
  45.     ((eq (abs (difference n (car m))) k) t)
  46.     (t (qp (add1 k) (cdr m)))
  47. )))
  48.  
  49. (df 'test '(lambda(x)(loop(st en val)
  50.     (cond
  51.         ((null x)(return t))
  52.     )
  53.     (print (car x))
  54.     (setq st (ontime))
  55.     (setq val (eval (car x)))
  56.     (setq en (ontime))
  57.     (print val)
  58.     (princ "time --- ")
  59.     (print (/ (difference en st) 100))
  60.     (setq x (cdr x))
  61. )))
  62.  
  63. (df 'gctest '(lambda(x)(prog(c val val2)
  64.   (if (not(numberp (cadr x)))
  65.       (return "Usage:(gctest (test-function) number)")
  66.   )
  67.   (setq c (cadr x))
  68.   (setq val (eval (car x)))
  69.   label
  70.   (print c)
  71.   (setq val2 (eval (car x)))
  72.   (cond
  73.     ((equal val val2) t)
  74.     (t (return (prog()
  75.          (print "Result is wrong !")
  76.          (princ "First result is ")
  77.          (print val)
  78.          (princ "Wrong result is ")
  79.          (print val2)
  80.     )))
  81.   )
  82.   (setq c (-- c))
  83.   (cond
  84.     ((zerop c) (return t))
  85.     (t (go label))
  86.   )
  87. )))
  88. "                各種ベンチマークテスト"
  89. "(wa 正の数)及び(wa2 正の数)：1から入力された数までの総和を求める"
  90. "(tarai 正の数 正の数 正の数)：たらい回し関数(ただのベンチマークテスト)"
  91. "(fibn 正の数)：フィボナッチ数列の値を求める。"
  92. "(fact 正の数)：1から入力された数までの総和を求める。"
  93. "(nqueen 正の数)：入力された数を縦横のマスの数にしてクイーン問題の回答を"
  94. "                 求める。"
  95. "(test (関数 引数 ...))：関数の実行に要した時間を1/100秒単位で求める。"
  96. "                        PC-98シリーズでは1秒単位になります。"
  97. "(gctest (関数 引数 ...) 回数)：同じ関数を設定回数実行し結果が同じか"
  98. "                               どうかテストする。"
  99.  
  100.