home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 1999 April / VPR9904A.BIN / Vpr_data / Special / Yoolw101 / Yoolw101.lzh / AUTO.YO next >
Lisp/Scheme  |  1998-09-19  |  5KB  |  252 lines
  1. ;
  2. ;(defun string (arg1 arg2) (･････))
  3. ;    expr関数定義
  4. (df 'defun '(lambda(func_def)
  5.     (eval (list 'de (list 'quote (car func_def)) (list 'quote (append (list 'lambda (cadr func_def)) (cddr func_def)))))
  6. ))
  7. ;
  8. ;(strrep string org new)    string,org,new:string
  9. ;    文字列stringの中のorgをnewに置き換える。
  10. ;
  11. (de 'strrep '(lambda(x y z)(prog()
  12. ;無限ループにならないように
  13.     (if (not (null (strpos y z))) 
  14.         (return (prog()
  15.             (print "この組み合わせでは、置換出来ません！")
  16.             (return x)
  17.         ))
  18.     )
  19.     (loop(num)
  20.         (setq num (strpos x y))
  21.         (cond
  22.             ((null num)(return x))
  23.             ((eq num 1)
  24.                 (setq x (concat z (substr x (plus num (strlng y)) (strlng x))))
  25.             )
  26.             ((eq (plus (sub1 num) (strlng y)) (strlng x))
  27.                 (setq x (concat (substr x 1 (sub1 num)) z))
  28.             )
  29.             (t
  30.                 (setq x (concat (substr x 1 (sub1 num)) z (substr x (plus num (strlng y)) (strlng x))))
  31.             )
  32.         )
  33.     )
  34. )))
  35. ;
  36. ;(expand arg_list fn)    arg_list:list    fn:atom
  37. ;    マクロ関数で、２引数の関数を多引数にするのに使う。
  38. ;
  39. (de 'expand '(lambda(x y)(cond
  40.     ((null x) nil)
  41.     (t (list y (car x) (expand (cdr x) y)))
  42. )))
  43.  
  44. ;
  45. ;(allappend arg1 arg2 ･･･ argn)    argn:list
  46. ;    総てのリストをつなげる。(append)
  47. ;    
  48. (dm 'allappend '(lambda(x)(expand (cdr x) 'append)))
  49.  
  50. ;
  51. ;(allnconc arg1 arg2 ･･･ argn)    argn:list
  52. ;    総てのリストをつなげる。(nconc)
  53. ;    
  54. (dm 'allnconc '(lambda(x)(expand (cdr x) 'nconc)))
  55.  
  56. ;
  57. ;(sort x)    x:list
  58. ;    リストの数字を小さい物から順に並べ換える。（クイックソート）
  59. ;
  60. (de 'sort '(lambda(x)(prog(pre med post comp)
  61.     (cond
  62.         ((null x) (return x))
  63.         ((null (cdr x)) (return x))
  64.     )
  65.     (setq comp (car x))
  66.     (setq med (cons comp nil))
  67.     (setq x (cdr x))
  68.     (loop(w)
  69.         (setq w (car x))
  70.         (cond
  71.             ((lessp w comp)    (setq pre (cons w pre)))
  72.             ((eq w comp)    (setq med (cons w med)))
  73.             (t        (setq post (cons w post)))
  74.         )
  75.         (setq x (cdr x))
  76.         (cond
  77.             ((null x)(return t))
  78.         )
  79.     )
  80.     (return (allappend
  81.         (sort pre)
  82.         med
  83.         (sort post)
  84.     ))
  85. )))
  86. ;
  87. ;(strsort x)    x:list
  88. ;    リストの文字列を小さい物から順に並べ換える。
  89. ;
  90. (de 'strsort '(lambda(x)(prog(pre med post comp)
  91.     (cond
  92.         ((null x) (return x))
  93.         ((null (cdr x)) (return x))
  94.     )
  95.     (setq comp (car x))
  96.     (setq med (cons comp nil))
  97.     (setq x (cdr x))
  98.     (loop(w)
  99.         (setq w (car x))
  100.         (cond
  101.             ((strlessp w comp)    (setq pre (cons w pre)))
  102.             ((equal w comp)    (setq med (cons w med)))
  103.             (t        (setq post (cons w post)))
  104.         )
  105.         (setq x (cdr x))
  106.         (cond
  107.             ((null x)(return t))
  108.         )
  109.     )
  110.     (return (allappend
  111.         (strsort pre)
  112.         med
  113.         (strsort post)
  114.     ))
  115. )))
  116. (de 'strlessp '(lambda(x y)(prog()
  117.     (cond ((equal x y) (return nil)))
  118.     (loop()
  119.         (cond
  120.             ((lessp (ascii x) (ascii y)) (return t))
  121.             ((greaterp (ascii x) (ascii y)) (return nil))
  122.         )
  123.         (cond
  124.             ((eq (strlng x) 1) (return t))
  125.             ((eq (strlng y) 1) (return nil))
  126.         )
  127.         (setq x (substr x 2 (strlng x)))
  128.         (setq y (substr y 2 (strlng y)))
  129.     )
  130. )))
  131. (de 'strgreaterp '(lambda(x y)(prog()
  132.     (cond ((equal x y) (return nil)))
  133.     (loop()
  134.         (cond
  135.             ((lessp (ascii x) (ascii y)) (return nil))
  136.             ((greaterp (ascii x) (ascii y)) (return t))
  137.         )
  138.         (cond
  139.             ((eq (strlng x) 1) (return nil))
  140.             ((eq (strlng y) 1) (return t))
  141.         )
  142.         (setq x (substr x 2 (strlng x)))
  143.         (setq y (substr y 2 (strlng y)))
  144.     )
  145. )))
  146. ;
  147. ;(gcm num1 num2)    num1,num2:number
  148. ;    ２つの数字の最大公約数を求める。
  149. ;
  150. (de 'gcm '(lambda(num1 num2)(prog()
  151.     (cond
  152.         ((greaterp num2 num1)(prog(x)
  153.             (setq x num1)
  154.             (setq num1 num2)
  155.             (setq num2 x)
  156.         ))
  157.     )
  158.     (return (cond
  159.         ((zerop (remainder num1 num2)) num2)
  160.         (t (gcm num2 (remainder num1 num2)))
  161.     ))
  162. )))
  163. ;
  164. ;(lcm num1 num2)    num1,num2:number
  165. ;    ２つの数字の最小公倍数を求める。
  166. ;
  167. (de 'lcm '(lambda(num1 num2)(times num1 (car (divide num2 (gcm num1 num2))))))
  168.  
  169. ;
  170. ;(hex hex_string)    hex_string:string
  171. ;    １６進ー＞１０進変換
  172. ;
  173. (de 'hex '(lambda(x)(prog(first num)
  174.     (setq num 0)
  175.     (loop()
  176.         (setq first (ascii x))
  177.         (cond
  178.             (
  179.                 (and
  180.                     (lessp (sub1 (ascii "0")) first)
  181.                     (lessp first (add1 (ascii "9")))
  182.                 )
  183.                 (setq num (plus (times num 16) (difference first (ascii "0"))))
  184.             )
  185.             (
  186.                 (and
  187.                     (lessp (sub1 (ascii "A")) first)
  188.                     (lessp first (add1 (ascii "F")))
  189.                 )
  190.                 (setq num (plus (times num 16) (difference first (ascii "A")) 10))
  191.             )
  192.             (
  193.                 (and
  194.                     (lessp (sub1 (ascii "a")) first)
  195.                     (lessp first (add1 (ascii "f")))
  196.                 )
  197.                 (setq num (plus (times num 16) (difference first (ascii "a")) 10))
  198.             )
  199.             (t (return num))
  200.         )
  201.         (cond
  202.             ((eq (strlng x) 1) (return num))
  203.         )
  204.         (setq x (substr x 2 (strlng x)))
  205.     )
  206. )))
  207. ;
  208. ;(\dir)
  209. ;    ソートしてファイル名の一覧を表示する
  210. ;
  211. (de '\dir '(lambda()(mapc 'print (strsort (dir "*.*")))))
  212. ;(de '\dir '(lambda()(strsort (dir "*.*"))))
  213.  
  214. ;
  215. ;(\type str)    str:string(file name)
  216. ;    ファイルの内容を表示
  217. ;
  218. (de '\type '(lambda(x)(prog(fp)
  219.     (setq fp (openr x))
  220.     (loop(sdata)
  221.         (setq sdata (freads fp))
  222.         (cond
  223.             ((null sdata) (return nil))
  224.         )
  225.         (print sdata)
  226.     )
  227.     (close fp)
  228. )))
  229. ;
  230. ;(\copy str1 str2)    str1:string(org file) str2:string(new file)
  231. ;    ファイルのコピー（複写）
  232. ;    テキストファイルでもバイナリファイルでも可能
  233. ;
  234. (de '\copy '(lambda(x y)(prog(fp1 fp2)
  235.     (cond
  236.         ((not (stringp x)) (return nil))
  237.         ((not (stringp y)) (return nil))
  238.     )
  239.     (setq fp1 (openr x))
  240.     (setq fp2 (openw y))
  241.     (loop(sdata)
  242.         (setq sdata (freadc fp1))
  243.         (cond
  244.             ((null sdata) (return nil))
  245.         )
  246.         (fwritec fp2 sdata)
  247.     )
  248.     (close fp1)
  249.     (close fp2)
  250. )))
  251.  
  252.