プログラミングを上達させたい

情報学専攻の大学院→放送局でCMの営業など@大阪→舞台俳優＆IT営業@東京

Project Euler(with Scheme) Problem 58〜61(44のことが頭から離れない・・・)

ProjectEuler Scheme

Problem 44が解けていないまま、ガンガン進めている。
なぜなら人間の瞳は前にしか付いていないので。

Problem 58

(define (uzumaki4 i); 辺の長さがiのときの4つの角の数字のリストを返す
  (if (= i 1) '(1)
      (let* ((lasthen (- i 2))
             (lastnum (* lasthen lasthen))
             (migiue (+ lastnum (- i 1)))
             (hidariue (+ migiue (- i 1)))
             (hidarishita (+ hidariue (- i 1)))
             (migishita (+ hidarishita (- i 1))))
        (list migiue hidariue hidarishita migishita))))

(define (sosu? n)
  (define (sub i)
    (cond  ((> (* i i) n) #t)
           ((= (modulo n i) 0) #f)
           (#t (sub (+ i 1)))))
  (if (<= n 2) #f (sub 2)))

(define (countsosu list)
  (if (null? list) 0
      (+ (if (sosu? (car list)) 1 0) (countsosu (cdr list)))))

(define (solve targetratio)
  (define (sub nowhen sosu sousu);意味なく分かりにくい命名にした
    (if (and (> nowhen 1) (< (/ sosu sousu) targetratio)) nowhen
        (let ((nextnums (uzumaki4 (+ nowhen 2))))
          (sub (+ nowhen 2) (+ sosu (countsosu nextnums)) (+ sousu 4)))))
  (sub 1 0 1))

(display (solve (/ 1 10)))

愚直に調べる。ただ、いちいち素数を数え直さないようにして高速化(いちいち数え直すようにしてたらn^2になって全然計算終わらず)。

Problem 59

今回は","をなくす作業を、SublimeTextでやりました。cmd+fで","を入れ、「Find All」指定して一発。便利！
あと、終端としてもともとのラストの94の後に「 1000」を追加。

;> (number->string 5 2)
;"101"
(define (add0 str count)
  (define (sub i)
    (if (= i 0) ""
        (string-append "0" (sub (- i 1)))))
  (string-append (sub count) str))

(define (xor str1 str2)
  (let ((len1 (string-length str1))
        (len2 (string-length str2)))
    (cond ((and (= len1 0) (= len2 0)) "")
          ((> len1 len2) (xor str2 str1));可換より
          ((< len1 len2) (xor (add0 str1 (- len2 len1)) str2))
          (#t (string-append (if (char=? (string-ref str1 0) (string-ref str2 0)) "0" "1") (xor (substring str1 1 len1) (substring str2 1 len2)))))))

;終端は1000。これ読んだら終わりの合図。
(define (input)
  (let* ((num (read)))
    (if (= num 1000) '()
        (cons num (input)))))
;> (char->integer #\A)  65
;> (char->integer #\Z)  90
;> (char->integer #\a)  97
;> (char->integer #\z) 122
(define (gene-num start end)
  (if (> start end) '()
      (cons start (gene-num (+ start 1) end))))

(define (e-l ele lislis)
  (if (null? lislis) '()
      (cons (cons ele (car lislis)) (e-l ele (cdr lislis)))))
(define (multi-list listA listB)
  (if (null? listA) '()
      (append (e-l (car listA) listB) (multi-list (cdr listA) listB))))
(define (p-list count base ans)
  (if (= count 0) ans
      (p-list (- count 1) base (multi-list base ans))))
(define (p-generate count list)
  (p-list count list '(())))

(define (fukugo password angou);password、angouはそれぞれ数字のリスト、返すのは文字のリスト
  (define (sub count an)
    (if (null? an) '()
        (cons (integer->char (string->number (xor (number->string (list-ref password (modulo count (length password))) 2) (number->string (car an) 2)) 2)) (sub (+ count 1) (cdr an)))))
  (sub 0 angou))

(define (text? list)
  (cond ((null? list) #t)
        ((or (char>? (car list) #\z) (char>? #\Space (car list)) (char<? #\" (car list) #\')) #f)
        (#t (text? (cdr list)))))

(define (kaidoku passwordlist angou)
  (cond ((null? passwordlist) "Finish!!!!")
        ((text? (fukugo (car passwordlist) angou)) (begin (display (listsum (map char->integer (fukugo (car passwordlist) angou)))) (newline) (display (car passwordlist)) (newline) (display (list->string (fukugo (car passwordlist) angou))) (newline) (kaidoku (cdr passwordlist) angou)))
        (#t (kaidoku (cdr passwordlist) angou))))

(define (listsum list) (if (null? list) 0 (+ (car list) (listsum (cdr list)))))

(define (intlist->charlist list)
  (if (null? list) '() (cons (integer->char (car list)) (intlist->charlist (cdr list)))))
(define nowangou (input))
(kaidoku (p-generate 3 (gene-num 97 122)) nowangou)

無事解けたけど、上記プログラムでパスワード候補を探したら2個ヒットする形に。
そのうち片方のパスワードを使って戻した平文はまともな文ではないけど、なんだかなぁと。
条件が少なすぎる気が。もう少し「絶対に含まれない文字」とかヒント欲しい。それとも解き方まちがっているのか？
結構手こずってその場その場でコードを変えていったので汚いコードになっちゃった。

Problem 60

(define (ketasu n);n>0を仮定
  (if (= n 0) 0 (+ 1 (ketasu (quotient n 10)))))

(define (ruijo n m) (if (= m 0) 1 (* n (ruijo n (- m 1)))));n^m

(define (append-num num1 num2) (+ (* num1 (ruijo 10 (ketasu num2))) num2))

(define (num-gene start end) (if (> start end) '() (cons start (num-gene (+ start 1) end))))

(define (erat list)
  (define (remove ele lis)
    (if (null? lis) '()
        (if (= 0 (modulo (car lis) ele)) (remove ele (cdr lis))
            (cons (car lis) (remove ele (cdr lis))))))
  (if (null? list) '() (cons (car list) (erat (remove (car list) (cdr list))))))

(define (prime? n)
  (define (sub i)
    (cond ((> (* i i) n) #t)
          ((= 0 (modulo n i)) #f)
          (#t (sub (+ i 1)))))
  (if (< n 2) #f (sub 2)))

(define (binary-search n vec);vecにnが含まれているか探す、vecは降順であることに注意
  (define (sub left right center)
    (let ((center-val (vector-ref vec center)))
      (cond ((>= (+ left 1) right) (or (= (vector-ref vec left) n) (= (vector-ref vec right) n)))
            ((= n center-val) #t)
            ((> n center-val) (sub left center (quotient (+ left center) 2)))
            (#t (sub center right (quotient (+ center right) 2))))))
  (if (= 0 (vector-length vec)) #f (sub 0 (- (vector-length vec) 1) (quotient (vector-length vec) 2))))

(define (solve2 primelist)
  (define (all-in? list vec) (if (null? list) #t (and (binary-search (car list) vec) (all-in? (cdr list) vec))))
  (define (ok-list primenum primes)
    (if (null? primes) primes
        (if (and (prime? (append-num primenum (car primes))) (prime? (append-num (car primes) primenum))) (cons (car primes) (ok-list primenum (cdr primes)))
            (ok-list primenum (cdr primes)))))

  (define (add-prime pnum okvec glist)
    (if (null? glist) '()
        (if (all-in? (car glist) okvec) (cons (cons pnum (car glist)) (cons (car glist) (add-prime pnum okvec (cdr glist))))
            (cons (car glist) (add-prime pnum okvec (cdr glist))))))
  
  (define (sub plist checkedplist grouplist)
    (if (null? plist) grouplist
        (sub (cdr plist) (cons (car plist) checkedplist) (add-prime (car plist) (list->vector (ok-list (car plist) checkedplist)) (cons (cons (car plist) '()) grouplist)))))
  (sub primelist '() '()))

(define (list-up2 limitnum) (solve2 (erat (num-gene 2 limitnum)))) ;limitnum>2
(define (overn n listlist) (if (null? listlist) "Finish!"
                               (if (>= (length (car listlist)) n) (begin (display (car listlist)) (newline) (overn n (cdr listlist)))
                                   (overn n (cdr listlist)))))

久々に高速化が必要だった問題。
単純な全探索だと全然終わらず・・・
高速化したあと、一応1分前後くらいで解答が出るコードにはなった。ただ、出した解が最小であることを検証するには大分実行時間がかかった。
もっと高速化できるのか・・・？

Problem 61

(define (fold-right fn a ls . args)
  (if (null? args)
      (letrec ((recr
                 (lambda (a ls)
                   (if (null? ls)
                       a
                     (fn (car ls) (recr a (cdr ls)))))))
        (recr a ls))
    (letrec ((recr
               (lambda (a xs)
                 (if (member? '() xs)
                     a
                   (apply fn (append (map car xs)
                                     (list (recr a (map cdr xs)))))))))
      (recr a (cons ls args)))))

(define (permutations-list ls)
    (define (perm ls a b)
        (if (null? ls)
            (cons (reverse a) b)
            (fold-right
                (lambda (x y)
                    (perm (remove-item x ls) (cons x a) y))
                b
                ls)))
    (perm ls '() '()))

(define (remove-item x ls)
    (remove (lambda (a) (equal? a x)) ls))

(define (remove func list)
  (cond ((null? list) list)
        ((func (car list)) (remove func (cdr list)))
        (#t (cons (car list) (remove func (cdr list))))))

(define (cut-list kagen jougen list)
  (if (null? list) '()
      (let ((sentou (car list)))
        (cond ((> sentou jougen) '())
              ((< sentou kagen) (cut-list kagen jougen (cdr list)))
              (#t (cons sentou (cut-list kagen jougen (cdr list))))))))

(define (generate func startindex kagen jougen)
  (let ((nownum (func startindex)))
    (cond ((> nownum jougen) '())
          ((< nownum kagen) (generate func (+ startindex 1) kagen jougen))
          ((= 0 (modulo (quotient nownum 10) 10)) (generate func (+ startindex 1) kagen jougen))
          (#t (cons nownum (generate func (+ startindex 1) kagen jougen))))))

(define kaku3 (generate (lambda (n) (quotient (* n (+ n 1)) 2)) 1 1000 9999))
(define kaku4 (generate (lambda (n) (* n n)) 1 1000 9999))
(define kaku5 (generate (lambda (n) (quotient (* n (- (* 3 n) 1)) 2)) 1 1000 9999))
(define kaku6 (generate (lambda (n) (* n (- (* 2 n) 1))) 1 1000 9999))
(define kaku7 (generate (lambda (n) (quotient (* n (- (* 5 n) 3)) 2)) 1 1000 9999))
(define kaku8 (generate (lambda (n) (* n (- (* 3 n) 2))) 1 1000 9999))

(define (get-next fromlist tolist)
  (define (pick-last list) (list-ref list (- (length list) 1)))
  (define (connectable-nums? num1 num2) (= (modulo num1 100) (quotient num2 100)))
  (define (insert-last num list)
    (if (null? list) (cons num '()) (cons (car list) (insert-last num (cdr list)))))
  (define (not-in? num list)
    (if (null? list) #t (if (= num (car list)) #f (not-in? num (cdr list)))))
  (define (can-connect? list num)
    (and (not-in? num list) (connectable-nums? (pick-last list) num)))
  (if (null? tolist) '()
      (if (can-connect? fromlist (car tolist)) (append (insert-last (car tolist) fromlist) (get-next fromlist (cdr tolist)))
          (get-next fromlist (cdr tolist)))))

(define (update fromlistlist tolist);listlistとlistを受け、listlistを返す
  (if (null? fromlistlist) '()
      (let ((nextstep (get-next (car fromlistlist) tolist)))
        (if (null? nextstep) (update (cdr fromlistlist) tolist)
            (cons nextstep (update (cdr fromlistlist) tolist))))))

(define (connect fromlistlist tolistlist);listlistとlistlistを受けてlistlistを返す、fromlistlistを更新していく
  (if (null? tolistlist) fromlistlist
      (connect (update fromlistlist (car tolistlist)) (cdr tolistlist))))

(define (test listlist);listlistを受けて、最終的なゴール地点を出す関数、ゴールなければ'(())が出る
  (define (listen list)
    (if (null? list) '()
        (cons (cons (car list) '()) (listen (cdr list)))))
  (connect (listen (car listlist)) (cdr listlist)))

(define (last-first-check list)
  (= (modulo (list-ref list (- (length list) 1)) 100) (quotient (car list) 100)))

(define (display-only-ans listlist)
  (define (sum-list list)
    (if (null? list) 0 (+ (car list) (sum-list (cdr list)))))
  (if (null? listlist) 0
      (if (last-first-check (car listlist)) (begin (display (car listlist)) (newline) (display (sum-list (car listlist))) (newline) (display-only-ans (cdr listlist)))
          (display-only-ans (cdr listlist)))))

(define (through? permlists listlist)
  (define (naraberu permlist lists);listlistを返す
    (define (pick-up n list)
      (if (= n 1) (car list) (pick-up (- n 1) (cdr list))));先頭の添え字は1
    (if (null? permlist) '()
        (cons (pick-up (car permlist) lists) (naraberu (cdr permlist) lists))))
  (if (null? permlists) "FINISH!!!"
      (let ((testkekka (test (naraberu (car permlists) listlist))))
        (if (and (not (null? testkekka)) (> (length (car testkekka)) 0))
            (begin (display-only-ans testkekka) (through? (cdr permlists) listlist))
            (through? (cdr permlists) listlist)))))

(define KOUHOLIST (cons kaku3 (cons kaku4 (cons kaku5 (cons kaku6 (cons kaku7 (cons kaku8 '())))))))
(through? (permutations-list '(1 2 3 4 5 6)) KOUHOLIST)

単純な全探索(と言っても、随所で枝切り的なことはする)だったが、かなり実装に手こずった・・・
実際問題、Javaでqueueとか使った方がキレイに書けたんだろうなと。いやSchemeでもキレイに書けるはずなんだけど、いかんせん実力が追いつかず・・・
というか、全探索的な解き方ばっかりしてるな。かっこよく解けるのだろうか？
あと、そもそもスタート地点は三角数って決めちゃってよかったな、と解いた後に反省。