Project Euler(with Scheme) Problem 40〜43

続けてるし、人生も続いていく。

Problem 40

(define (ketasu n)
  (if (= n 0) 0
      (+ 1 (ketasu (quotient n 10)))))

(define (get-keta ind n)
  (if (= ind 0) (modulo n 10)
      (get-keta (- ind 1) (quotient n 10))))

(define (solver nowtarget end nownum ketacount ans)
  (cond ((> nowtarget end) ans)
        ((>= ketacount nowtarget) (solver (* nowtarget 10) end (+ nownum 1) (+ ketacount (ketasu (+ nownum 1))) (* ans (get-keta (- ketacount nowtarget) nownum))))
        (#t (solver nowtarget end (+ nownum 1) (+ ketacount (ketasu (+ nownum 1))) ans))))

(define (solve end)
  (solver 1 end 0 0 1))

汎用的な関数は作らず、"10の累乗"桁目を足し込むことに特化した関数で書きました。

Problem 41

(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 (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 (gene-num ls)
  (define (sub ls now)
    (if (null? ls) now
        (sub (cdr ls) (+ (* now 10) (car ls)))))
  (sub ls 0))

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

(define (print-prime ls)
  (if (null? ls) (display "No Prime Number in list.")
      (if (prime? (gene-num (car ls))) (display (gene-num (car ls)))
          (print-prime (cdr ls)))))

;(print-prime (permutations-list '(9 8 7 6 5 4 3 2 1)))
;9桁を探したが、"No Prime Number in list"とのこと
;(print-prime (permutations-list '(8 7 6 5 4 3 2 1)))
;8桁も
(print-prime (permutations-list '(7 6 5 4 3 2 1)))
(newline)

パンデジタル数にからむ問題は順列生成関数のおかげで高速なものをさらっと書けるように！

Problem 42

ターミナル上で下処理。
以前やったのと同じやり方で、","を" "に置換。

$ sed -e 's/","/" "/g' ./p042_words.txt > ./newwords.txt

そして普通に求めていく。文字列は意外とSchemeで扱いやすい。

;(char->integer #\A) -> 65
;(char->integer #\B) -> 66
(define (charscore ch) (- (char->integer ch) 64))

(define (stringscore str)
  (if (= (string-length str) 0) 0
      (+ (charscore (string-ref str 0)) (stringscore (substring str 1 (string-length str))))))

(define (sankaku? n)
  (define (sub i)
    (let ((tri (quotient (* i (+ i 1)) 2)))
      (cond ((> tri n) #f)
            ((= tri n) #t)
            (#t (sub (+ i 1))))))
  (sub 1))

(define (tri-string? str) (sankaku? (stringscore str)))

;最後の名前が"YOUTH"だったので、それを目印に
;これだと逆順に入っちゃうけどまぁいっか
(define (input)
  (define (sub ls)
    (let* ((a (read)))
      (if (string=? a "YOUTH") (cons a ls)
          (sub (cons a ls)))))
  (sub '()))

(define (count-tristring ls)
  (if (null? ls) 0
      (+ (if (tri-string? (car ls)) 1 0) (count-tristring (cdr ls)))))

(display (count-tristring (input)))
(newline)

Problem 43

パンデジタル数といえば！おなじみ順列の生成関数！

(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 (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 (ruijo10 n)
  (if (= n 0) 1
      (* 10 (ruijo10 (- n 1)))))

;nのstart桁目から3桁分取得する
(define (cut-3 n start)
  (modulo (quotient n (ruijo10 (- 8 start))) 1000))

(define PrimeArray (vector #f 2 3 5 7 11 13 17))

;ex)1406357289
(define (prime-pan? n)
  (define (sub i)
    (if (> i 7) #t
        (and (= 0 (modulo (cut-3 n (+ i 1)) (vector-ref PrimeArray i))) (sub (+ i 1)))))
  (sub 1))

(define (gene-num lis)
  (define (sub ls i)
    (if (null? ls) i
        (sub (cdr ls) (+ (* i 10) (car ls)))))
  (sub lis 0))

; 先頭の桁が0のものははじく
(define (solve lis)
  (define (sub ls sum)
    (if (null? ls) sum
        (sub (cdr ls) (+ sum (let ((nownum (gene-num (car ls)))) (if (and (> (car (car ls)) 0) (prime-pan? nownum)) (let* ((a (display nownum)) (b (newline))) nownum) 0))))))
  (sub lis 0))

(display (solve (permutations-list '(0 1 2 3 4 5 6 7 8 9))))
(newline)

途中経過が出るように書いてみたけど、該当する数は6個しかないのね。すごい。

続けてくぞ〜