projecteuler22

projecteuler22

 projecteuler問題22 は、names.txt にある名前をアルファベット順に並べ、全ての名前の順位と名前のアルファベットの値和と積を求め、その総量を求める問題。アルファベットの値は A, B, C,… が 1, 2, 3,… に相当。 
 url にあるデータは get-url で取り出し、sort でソートすれば、後は計算するだけ。繰り返しには dolist でも使いましょうか。文字列の分解には explode が使えます。
 さて、コードは、

(silent)
(setq names (replace "," (parse (get-url "https://projecteuler.net/project/resources/p022_names.txt"))))
(sort names)
(let (res 0)
  (dolist (n names)
    (++ res (* (+ $idx 1) (apply + (map (fn (x) (- x 0x40)) (map char (explode n)))))))
  (println res))

 こんな感じ。これを実行すれば、

871198282

 という答えが得られます。
 silent 文を外せば、names.txt にある名前がすべて表示されます。お好みでどうぞ。
 以上、如何でしょうか?

projecteuler21

 projecteuler問題21 は、10000 未満の友愛数の和を求める問題。
 この問題を解いていると聞いたこともない種類の数の名前が出てきます。友愛数もその一つ。
 友愛数は親和数とも呼ばれ、約数から自身を除いた和が相手の数値になり、その相手の数値の約数の和が自分と同じになる組だそうです。
 つまり、突き詰めれば全ての約数を求める問題。約数を求めるのは 問題12でやっているので、コード自体は、

(define-macro (memoize mem-func func) 
  (set (sym mem-func mem-func) 
    (letex (f func  c mem-func) 
      (lambda () 
        (or (context c (string (args))) 
            (context c (string (args)) (apply f (args))))))))
(define (make-sublist lst)
  (clean nil? (map (fn(x) (if x $idx)) lst))
)
(memoize combination2 (lambda (n)
  (if (= n 0) '()
    (let (res (combination2 (-- n)))
      (push (list n) res -1)
      (dolist (x res (= (x 0) n))
         (push (append x (list n)) res -1))
      res))))
(define (divisors2 num , (res '(1)))
  (let (numbers (factor num))
    (if (= num 1) 1
        numbers
      (let (sublist (combination2 (length numbers)))
        (dolist (x sublist)
          (push (apply * (select numbers x)) res -1))
        (unique res)))))
(let (res)
  (for (a 2 9999)
    (let (b (apply + (chop (divisors2 a))))
      (if (and (> b 1) (!= a b) (= a (apply + (chop (divisors2 b)))))
        (push a res -1))))
  (println res)
  (apply + res))

 こんな感じ。これを実行すれば、

(220 284 1184 1210 2620 2924 5020 5564 6232 6368)
31626

 10000 未満の友愛数とその和 31626 が出てきます。

 以上、如何でしょうか?

projecteuler20

 projecteuler問題20 は、100 の階乗を求め、各桁を足した和を求めるという問題。
 桁数に制限のない大整数のある newLISP とって、得意とするところ。

> (apply * (map bigint (sequence 1 100)))
93326215443944152681699238856266700490715968264381621468592963895217599993229915
608941463976156518286253697920827223758251185210916864000000000000000000000000L
> (apply + (map int (explode (chop (string (apply * (map bigint (sequence 1 100))))))))
648
> 

 これでおしまい。答えは 648 。
 これでは、解説しようが無い(笑)

 以上、如何でしょうか?

projecteuler19

 projecteuler問題19 は、1901 年から 2000 年までで日曜日から始まる月の回数を数えるもの。
 条件として与えられるのが、

・1900/1/1 は月曜日
・4 月、6 月、9 月、11 月は 30 日あり、残りは 2 月を除いて 31 日。
 2月は 28 日とうるう年の 29 日がある
・うるう年は 4 で割り切れる年で、100 で割り切れる年は含まないが、400 で割り切れる年は含まれる

 ということ。だから、うるう年かどうかを判定する関数は

(define (leap y)
  (or (= 0 (% y 400)) (and (= 0 (% y 4)) (!= 0 (% y 100)))))

 こんなところ。
 上記条件から 1900 年はうるう年ではないので、1901/1/1 は火曜日となる。
 だから、答えを求めるスクリプトは

(setq mn '(31 28 31 30 31 30 31 31 30 31 30 31)
      ml '(31 29 31 30 31 30 31 31 30 31 30 31))
(let (res '() cnt 0 days 2)
  (for (y 1901 2000) (push (if (leap y) ml mn) res -1))
    (dolist (x (chop (flat res)))
      (++ days x)
      (if (= 0 (% days 7)) (++ cnt)))
  cnt)

 こんな感じ。
 最初の for 文で与えらえた期間の月ごとの日数のリストを作り、ひと月ずつ足していって、日曜日かどうかを判定して変数 cnt を増加させているだけ。
 先の関数 leap と併せて実行すれば、

171

 という結果が得られます。

 以上、如何でしょうか?

projecteuler67...または、URLファイルの読み込み

 projecteuler問題67 は、前回問題18 と同じで段数が100段なだけ。
 さすがに100段の数字ともなるとは別 URL になっています。そこで、100段の数字の読み込みに get-url を使います。
 あとは前回と同じで、スクリプトは

(silent)
(setq url "https://projecteuler.net/project/resources/p067_triangle.txt")
(setq triangle
      (map (fn (x) (parse x " "))
      (replace "" (parse (get-url url 1000) "\n"))))
(let (res (map list (map (fn(x) (int x 0 10)) (pop (reverse triangle)))))
  (dolist (r triangle)
    (let (tmp)
    (dolist (c (map (fn(x) (int x 0 10)) r))
      (push (if (> (apply + (res $idx)) (apply + (res (+ 1 $idx)))) 
        (cons c (res $idx)) (cons c (res (+ 1 $idx))))
        tmp -1))
    (setq res tmp)))
 (println (res 0))
 (println (apply + (res 0))))

 silent を使って余分な表示を抑え、必要なものだけ println で表示させるようにしました。
 これを実行すれば、

(59 73 52 53 87 57 92 81 81 79 81 32 86 82 97 55 97 36 62 65 90 93 95 54 71 77 68 
 71 94 8 89 54 42 90 84 91 31 71 93 94 53 69 73 99 89 47 80 96 81 52 98 38 91 78 
 90 70 61 17 11 75 74 55 81 87 89 99 73 88 95 68 37 87 73 77 60 82 87 64 96 65 47 
 94 85 51 87 65 65 66 91 83 72 24 98 89 53 82 57 99 98 95)
7273

 筋道と答えの 7273 が出てきます。

 以上、如何でしょうか?

projecteuler18...または、先読み問題?

 projecteuler問題18 は、三角形に並べられた数値を足して、最大になる道筋の和を求めるもの。
 例題は4段ですが、本番は15段で道筋は 16384214乗)通り。
 全ての道筋を計算してもいいですが、注記にもあるように問題67では100段ありますので、ここは一工夫要りそうです(汗)
 上から順に追って行くと回答が得られるまですべての道筋を通らざるを得ないので、発想を変えて下から追ってみます。
 例題でいえば、
 3段目の 2 が取れるのは 85 なので 84969 と一意に決まる。
 同様に、2段目の 74+9 の道筋、46+9 の道筋となる。
 最後の1段目は 7+4+9 を取るか 4+6+9 を取るかなので、おのずと決まる。
 これでいけそう。先読みならぬ逆読み(笑)
 スクリプトにすると、

(setq triangle
        (map (fn (x) (parse x " "))
          (replace "" (parse 
[text]
75
95 64
17 47 82
18 35 87 10
20 04 82 47 65
19 01 23 75 03 34
88 02 77 73 07 63 67
99 65 04 28 06 16 70 92
41 41 26 56 83 40 80 70 33
41 48 72 33 47 32 37 16 94 29
53 71 44 65 25 43 91 52 97 51 14
70 11 33 28 77 73 17 78 39 68 17 57
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
[/text]  "\n"))))
(let (res (map list (map (fn(x) (int x 0 10)) (pop (reverse triangle)))))
  (dolist (r triangle)
    (let (tmp)
      (dolist (c (map (fn(x) (int x 0 10)) r))
        (push (if (> (apply + (res $idx)) (apply + (res (+ 1 $idx)))) 
          (cons c (res $idx)) (cons c (res (+ 1 $idx))))
          tmp -1))
      (setq res tmp)))
  (println (res 0))
  (apply + (res 0)))

 こんな感じ。これを実行すれば、

(("75")
 ("95" "64")
 ("17" "47" "82")
 ("18" "35" "87" "10")
 ("20" "04" "82" "47" "65") 
 ("19" "01" "23" "75" "03" "34") 
 ("88" "02" "77" "73" "07" "63" "67") 
 ("99" "65" "04" "28" "06" "16" "70" "92") 
 ("41" "41" "26" "56" "83" "40" "80" "70" "33") 
 ("41" "48" "72" "33" "47" "32" "37" "16" "94" "29") 
 ("53" "71" "44" "65" "25" "43" "91" "52" "97" "51" "14") 
 ("70" "11" "33" "28" "77" "73" "17" "78" "39" "68" "17" "57") 
 ("91" "71" "52" "38" "17" "14" "91" "43" "58" "50" "27" "29" "48") 
 ("63" "66" "04" "68" "89" "53" "67" "30" "73" "16" "69" "87" "40" "31") 
 ("04" "62" "98" "27" "23" "09" "70" "98" "73" "93" "38" "53" "60" "04" "23"))
(75 64 82 87 82 75 73 28 83 32 91 78 58 73 93)
1074

 こんな風に答え 1074 が出てきます。
 さて、解説するまでもないですが、$idxシステム変数でここでは dolist のインデックス値が入っています。また、newLISP の reverseCommon Lispnreverse 相当で破壊的関数です。ご注意を。

 以上、如何でしょうか?

projecteuler17...または、英数字表記の問題

 日本人には.、あまりなじみのない問題なのが projecteuler問題17
 1 から 1000 の数値を英字に変えて、アルファベット文字数を数えるのですから。
 英語だと 20 までは固有名詞があるから

(setq c1 (map string  '(zero one two three four five six seven eight nine ten eleven twelve thirteen fourteen fifteen seventeen sixteen eighteen nineteen twenty)))

 と定義しておけば、

> (map 'c1 (sequence 1 20))
("one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" "eleven" "twelve" 
 "thirteen" "fourteen" "fifteen" "seventeen" "sixteen" "eighteen" "nineteen" "twenty")
> 

 こんな風に変換できます。だから、例題の〝1 から 5 まで〟なら

> (map 'c1 (sequence 1 5))
("one" "two" "three" "four" "five")
> (length (apply string (map 'c1 (sequence 1 5))))
19
> 

 これで十分だけど、ここからが問題。1000 までありますからね、、、
 20 以上の 10 の位とそれ以上の桁の単位を用意して、

(setq c2 (map string '(twenty thirty forty fifty sixty seventy eighty ninety)))
(setq c3 (map string '(hundred thousand million billion)))

 それぞれの桁に応じた変換スクリプトを用意する。

(define (before100 num)
  (if ( m 0) (string "-" (c1 m)) "")))
  ))
(define (before1000 num)
  (let (i (/ num 100) m (% num 100))
    (string (c1 i) " " (c3 0)  (if (> m 0) (string " and " (before100 m)) ""))
  ))
(define (num2words num)
  (if (< num 100) (before100 num)
      (< num 1000) (before1000 num)
      (string "one " (c3 1))
  ))

 これを使えば、20 より上は

> (map num2words '(22 33 44 55 66 77 88 99))
("twenty-two" "thirty-three" "forty-four" "fifty-five" "sixty-six" "seventy-seven" 
 "eighty-eight" "ninety-nine")
> (map num2words '(111 222 333 444 555 666 777 888 999))
("one hundred and eleven" "two hundred and twenty-two" "three hundred and thirty-three" 
 "four hundred and forty-four" "five hundred and fifty-five" "six hundred and sixty-six" 
 "seven hundred and seventy-seven" "eight hundred and eighty-eight" "nine hundred and ninety-nine")
> (num2words 1000)
"one thousand"
> 

 こんな感じ。1000 までですけど(汗)
 これで準備は完了、答え一発

> (length (replace "[ -]" (apply append (map num2words (sequence 1 1000))) "" 1))
21124
> 

 こんなところ。
 さて、解説はするまでもない(笑)

 以上、如何でしょうか?

projecteuler16...または、大整数の使い方

 projecteuler問題16 は、2 の 1000 乗を求め、桁ごとの数値を足した和を求める問題。
 ポイントは、300桁以上ある 2 の 1000 乗を桁落ち無しで求めること。
 64ビット整数では 21桁 が限度ですから、その桁数が大きさが問題となっている訳です。
 でも、newLISP には大整数がありますので、全く問題になりません(笑)
 答えは、

> (let (res (apply * (dup 2L 1000))) res)
10715086071862673209484250490600018105614048117055336074437503883703510511249361224931983788156958581275946729175531468251871452856923140435984577574698574803934567774824230985421074605062371141877954182153046474983581941267398767559165543946077062914571196477686542167660429831652624386837205668069376L
> (let (res (apply * (dup 2L 1000))) (apply + (map int (explode (chop (string res))))))
1366
> 

 ざっと、こんなもん。
 さて、解説ですが、数値の末尾に L を付けると大整数になります。
 string で 文字列にして、explode で各桁数に分解し、int で整数にもどして、足すだけ。
 chop は大整数の L を外すためのもの。
 int のオプションを使って

> (let (res (apply * (dup 2L 1000))) (apply + (map (fn (x) (int x 0)) (explode (string res)))))
1366
> 

 とすることもできます。

 以上、如何でしょうか?

newLISP マニュアル v.10.6.2 日本語訳公開

 久々の安定版のリリース。
 新規関数として collect が追加されています。
 また、 正規表現オプションが数値だけではなく、文字でも指定できるようになっています。
 もちろん、ウェブ・ブラウザ上の newLISP in a browser も v.10.6.2 です。
 ということで、newLISP の User Manual and ReferenceCode Patterns の全訳のリリースです。

newlisp_manual-10602
CodePatterns-10602
こちらからダウンロードしてください。

 目次も含め日本語併記にしてあります。
 Lutz氏のご好意によりこちらから見ることもできます。

 いつものように、間違いやおかしな点が有りましたら、こちらの blog までご一報ください。

 以上、如何でしょうか?

FOOP で DAG する、その2

 前回の FOOP で DAG する は如何だったでしょうか?
 今回は、DAG (Directed acyclic graph)a 地点から b 地点までの経路を検索するスクリプトを追加してみます。
 ということで、コードは、

(define (DAG:search a b (res '()))
  (let (connects (DAG:search-pre b))
    (if (= connects "start") nil
      (dolist (c connects)
        (let (tmp (append (list c) res))
          (if (= (c 0) a) (push tmp DAG:result -1)
            (DAG:search a (c 0) tmp)))))))
(define (DAG:search-a2b a b)
   (setq DAG:result '())
   (DAG:search a b)
   DAG:result)

 何と DAG データの引き渡しらしき箇所がない(笑)、、、FOOP ですから。
 これを前回のスクリプトに追加して実行します。
 使い方は、

> (setq mydag2 (DAG '((a b) (b c) (b d) (b e) (g d) (c e) (d e) (e f))))
(DAG ((a b) (b c) (b d) (b e) (g d) (c e) (d e) (e f)))
> (:search-a2b mydag2 'g 'f)
(((g d) (d e) (e f)))
> (:search-a2b mydag2 'a 'f)
(((a b) (b e) (e f)) ((a b) (b c) (c e) (e f)) ((a b) (b d) (d e) (e f)))
> 

 こんな感じ。

 以上、如何でしょうか?

フォロー

新しい投稿をメールで受信しましょう。