プレゼント交換マッチシステム

■プレゼント交換マッチシステム
http://d.hatena.ne.jp/scinfaxi/20061224/1166895125

引き続き上についてカタカタと。


やっと書けた(;´Д`)


;よーし計算開始!!
;Dr Scheme,Pentium-M 1.5Gのマシンで10分ぐらいかかる
;Gaucheだと一分半
(find_correct_exchanges (list 1 2 3 4 5 6 7 8 9))

;以下メインのロジック

(define (find_correct_exchanges group_description)
(print (next_man () (length group_description) group_description 0))
)

(define (next_man current_state man_count group_description all_result)
(cond
((= (length current_state) man_count)
(cond
((not (check_is_tail_illegal current_state group_description)) (begin (print current_state) (newline) 1))
(else 0)
)
)
((eq? (check_is_tail_illegal current_state group_description) #f)
(+ all_result (select_target current_state man_count 1 group_description all_result))
)
(else 0)
)
)

(define (select_target current_state man_count index group_description all_result)
(cond
((= index (inc man_count)) 0)
(else
(+ (select_target current_state man_count (inc index) group_description all_result) (next_man (append current_state (list index)) man_count group_description all_result))
)
)
)

(define (check_is_tail_illegal state group_description)
(cond
((empty? state) #f)
((or (= (get_last state) (length state))
(eq? (get_group_by_id (get_last state) group_description) (get_group_by_id (length state) group_description))
(check_contain_same_last state)
) #t)
(else #f)
)
)

(define (get_group_by_id user_id group_description)
(cond
((>= (dec user_id) 0) (list-ref group_description (dec user_id)))
(else -1)
)
)



;以下組み込みであるんじゃないか疑惑

(define (get_last lis)
(cond
((>= (length lis) 1) (list-ref lis (dec (length lis))))
(else -1)
)
)

(define (check_contain_same_last lis)
(cond
((= 0 (length lis)) #f)
(else (a_check_contain_same1 lis (dec (length lis)) 0))
)
)

(define (a_check_contain_same1 lis target_index current)
(cond
((>= current (length lis)) #f)
(else
(cond
((and (not (= current target_index)) (= (list-ref lis current) (list-ref lis target_index))) #t)
(else (a_check_contain_same1 lis target_index (inc current)))
)
)
)
)

(define (inc num)
(+ num 1)
)

(define (dec num)
(- num 1)
)

(define (sort xs)
(cond
((= (length xs) 0) xs)
(else (insert (first xs)(sort (rest xs))))
)
)

(define (insert n nums)
(cond
((empty? nums) (cons n ()))
(else (cond
((>= (first nums) n) (cons n nums))
((< (first nums) n) (cons (first nums) (insert n (rest nums))))
)
)
)
)

(define (first lis)
(list-ref lis 0)
)

(define (rest lis)
(rest_sub lis 0)
)

(define (rest_sub lis counter)
(cond
((= counter (length lis)) ())
((= counter 0) (rest_sub lis (inc counter)))
(else (append (list (list-ref lis counter)) (rest_sub lis (inc counter))))
)
)

(define (empty? lis)
(cond
((= (length lis) 0) #t)
(else #f)
)
)

実行結果


省略
(2 1 4 3 6 9 8 5 7)
(2 1 4 3 6 9 5 7 8)
(2 1 4 3 6 8 9 7 5)
(2 1 4 3 6 8 9 5 7)
(2 1 4 3 6 8 5 9 7)
(2 1 4 3 6 7 9 5 8)
(2 1 4 3 6 7 8 9 5)
(2 1 4 3 6 7 5 9 8)
(2 1 4 3 6 5 9 7 8)
(2 1 4 3 6 5 8 9 7)
133496
探索の方針としては全探索+枝刈り。まじめにやるのなら不正なやつはトライしないようにしなくちゃいけないけど面倒だからそこまでやってない。


計算量は富豪的。メモリは人数分のint配列ぐらいの量しか食わないので普通。


後半の関数は車輪の再開発の予感。組み込みできっとあるよね?


エロい人添削よろしく。


#追記
どうやら全部数え上げなくても一個だけ見つければよいらしい。なーんだ。
それなら乱数から適当な組み合わせを作って条件に合致するかを調べればよさげ。俺の努力は。。。。( ´Д`)