4つの指輪

この記事は ひとりアドベントカレンダーRosettaCodeで楽しむプログラミング Advent Calendar 2025の6日めの記事です。

タスク

（超要約） $a + b = b + c + d = d + e + f = f + g$ の解を求めよ。

• 7つの変数に1から7の整数を重複なく割り当てる解全て
• 7つの変数に3から9の整数を重複なく割り当てる解全て
• 7つの変数に0から9の整数を重複を許して割り当てる、そのような解の個数

既存の解

RosettaCodeには既に、Haskell版が二つ掲載されている。

網羅的な探索をする方法

自分の書き方に勝手に直したもので示す。

import Data.List
import Control.Monad
import Text.Printf
import Data.Bool

perms :: (Eq a) => [a] -> [[a]]
perms [] = [[]]
perms xs = [x:xr | x <- xs, xr <- perms $ delete x xs]

combs :: Int -> [a] -> [[a]]
combs n xs = sequence $ replicate n xs

ringCheck :: [Int] -> Bool
ringCheck [a,b,c,d,e,f,g] = all (a+b ==) [b+c+d, d+e+f, f+g]

fourRings :: Int -> Int -> Bool -> Bool -> IO ()
fourRings low high allowDups verbose =
  do
    when verbose $ mapM_ print sols
    printf "%d%s unique solutions for %d to %d\n\n"
           (length sols) (bool "" " non" allowDups) low high
  where
    cands | allowDups = combs 7 [low..high]
          | otherwise = perms   [low..high]
    sols  = filter ringCheck cands

main :: IO ()
main = do
   fourRings 1 7 False True
   fourRings 3 9 False True
   fourRings 0 9 True False

ghci> main
[3,7,2,1,5,4,6]
[4,5,3,1,6,2,7]
[4,7,1,3,2,6,5]
[5,6,2,3,1,7,4]
[6,4,1,5,2,3,7]
[6,4,5,1,2,7,3]
[7,2,6,1,3,5,4]
[7,3,2,5,1,4,6]
8 unique solutions for 1 to 7

[7,8,3,4,5,6,9]
[8,7,3,5,4,6,9]
[9,6,4,5,3,7,8]
[9,6,5,4,3,8,7]
4 unique solutions for 3 to 9

2860 non unique solutions for 0 to 9

(16.88 secs, 8,899,561,008 bytes)

予想通り、最後は少し時間がかかる。

「構造的な探索」

自分が最初にこのコードを発見したときは卒倒した。2017年の過去ログ。

過去モードだと lang タグが認識されないらしく見づらいので、当時のコードをそのまま再掲する。

import Data.List (delete, sortBy, (\\))

rings :: Bool -> [Int] -> [(Int, Int, Int, Int, Int, Int, Int)]
rings u digits =
  let ds = sortBy (flip compare) digits
      h = head ds
  in ds >>=
     -- QUEEN ------------------------------------------------------------------
     (\q ->
         let ts = filter ((<= h) . (q +)) ds
             bs =
               if u
                 then delete q ts
                 else ds
         in bs >>=
            -- LEFT BISHOP AND ROOK --------------------------------------------
            (\lb ->
                let lRook = lb + q
                in if lRook <= h
                     then let rbs =
                                if u
                                  then ts \\ [q, lb, lRook]
                                  else ds
                          in rbs >>=
                             -- RIGHT BISHOP AND ROOK --------------------------
                             (\rb ->
                                 let rRook = q + rb
                                 in if (rRook <= h) && (not u || (rRook /= lb))
                                      then let ks =
                                                 if u
                                                   then ds \\
                                                        [ q
                                                        , lb
                                                        , rb
                                                        , rRook
                                                        , lRook
                                                        ]
                                                   else ds
                                               rookDelta = lRook - rRook
                                           in ks >>=
                                              -- SOLUTION WITH KNIGHTS ---------
                                              (\k ->
                                                  let k2 = k + rookDelta
                                                  in [ ( lRook
                                                       , k
                                                       , lb
                                                       , q
                                                       , rb
                                                       , k2
                                                       , rRook)
                                                     | (k2 `elem` ks) &&
                                                         (not u ||
                                                          notElem
                                                            k2
                                                            [ lRook
                                                            , k
                                                            , lb
                                                            , q
                                                            , rb
                                                            , rRook
                                                            ]) ])
                                      else [])
                     else []))

--------------------------- TEST -------------------------
main :: IO ()
main = do
  let f (k, xs) = putStrLn k >> nl >> mapM_ print xs >> nl
      nl = putStrLn []
  mapM_
    f
    [ ("rings True [1 .. 7]", rings True [1 .. 7]),
      ("rings True [3 .. 9]", rings True [3 .. 9])
    ]
  f
    ( "length (rings False [0 .. 9])",
      [length (rings False [0 .. 9])]
    )

ど
　う
　　し
　　て
　　　こ
　　　　う
　　　　　な
　　　　　っ
　　　　　　た

2025年現在、By structured search と題して掲載されているものはまだ普通に見えるが、これを誰かなりに書き直したもので、本質は変わっていないようだ。

説明ではこのように述べている。
（変数 $a,b,c,d,e,f,g$ に順に left Rook, left Knight, left Bishop, Queen, right Bishop, right Knight, right Rook とあだ名を付けて呼んでいるところは無視する。）

• 中央の変数 $d$ から始めて、外側の変数 $a,g$ の方へ計算を進める。
• 元の方程式 $a + b = b + c + d = d + e + f = f + g$ より、$d + c = a$ である。
• 同様に $d + e = g$ である。
• $a + b = f + g$ より $a - g = f - b$ である。（一番外側どうしの変数の差と、その内側どうしの変数の差が同じ）
• 4つの >>= により、$d$, $c$ と $a$, $e$ と $g$ そして $b$ と $e$ の順で解を構築している。
• 可読性は良くないかもしれないが、高速で、さらなる最適化が望める。

何を言っているのか、何がコードになっているのか、分析する。
まず、全体はリストモナドでの探索をしているようだ。

  in ds >>=
     -- QUEEN ------------------------------------------------------------------
     (\q ->
[略]
         in bs >>=
            -- LEFT BISHOP AND ROOK --------------------------------------------
            (\lb ->
[略]
                in if lRook <= h -- 下のelseと呼応して、guard を成している
                     then let rbs =
[略]
                          in rbs >>=
                             -- RIGHT BISHOP AND ROOK --------------------------
                             (\rb ->
[略]
                                 in if (rRook <= h) && (not u || (rRook /= lb)) -- これもguard
                                      then let ks =
[略]
                                           in ks >>=
                                              -- SOLUTION WITH KNIGHTS ---------
                                              (\k ->
[略、答えにまとめている]
                                      else [])
                     else []))

リストモナドのdo記法を使えば（いや、使わなくても）そんなインデントはいらないし、さらにそれと等価な内包表記を使って書ける話だと思う。
ということで、等価に書き直し、何をしていたのかを読み解く。

rings :: Bool -> [Int] -> [(Int, Int, Int, Int, Int, Int, Int)]
rings u digits =
  [ (lRook, k, lb, q, rb, k2, rRook)
  | let ds = sortBy (flip compare) digits         -- なぜ大きい方から？
  , let h = head ds
-- QUEEN
  , q <- ds                                       -- 中央 d を任意に選ぶ
  , let ts = filter ((<= h) . (q +)) ds           -- dを足しても最大値を超えない数字だけ、
  , let bs = if u then delete q ts else ds        -- 重複なしのとき、そこから d を除いたものが c の候補、さもなくば ds 全域（tsにしないの？）
  , lb <- bs                                      -- c を候補から選ぶ
-- LEFT BISHOP AND ROOK
  , let lRook = lb + q                            -- 関係 a = c + d から a 確定
  , lRook <= h                                    -- a は最大値を超えない（c,dと一致することはないのでこれだけ）
  , let rbs = if u then ts \\ [q, lb, lRook] else ds -- 重複なしのとき、使用済み数字を除いたものが e の候補
  , rb <- rbs
-- RIGHT BISHOP AND ROOK --------------------------
  , let rRook = q + rb                            -- 関係 g = d + e から g 確定
  , (rRook <= h) && (not u || (rRook /= lb))      -- g は最大値を超えない、c と一致しない
  , let ks = if u then ds \\ [ q, lb, rb, rRook, lRook] else ds -- 重複なしのとき、使用済み数字を除いたものが e の候補
  , let rookDelta = lRook - rRook                 -- a - g = f - b の値
  , k <- ks                                       -- b を候補から選ぶ
-- SOLUTION WITH KNIGHTS ---------
  , let k2 = k + rookDelta                        -- 関係 a - g = f - b から f 確定
  , k2 `elem` ks                                  -- それは未使用である必要がある
  , not u || notElem k2 [lRook, k, lb, q, rb, rRook]
  ]

サイトの方では、別の方針で修正された版になっているが…
妙に縦に長いシグネチャと一部の式を修正して転載する。

import Data.List (delete, sortBy, (\\))

--------------- 4 RINGS OR 4 SQUARES PUZZLE --------------

type Rings = [(Int, Int, Int, Int, Int, Int, Int)]

rings :: Bool -> [Int] -> Rings
rings u digits =
  ((>>=) <*> (queen u =<< head))
    (sortBy (flip compare) digits)

queen :: Bool -> Int -> [Int] -> Int -> Rings
queen u h ds q = xs >>= leftBishop u q h ts ds
  where
    ts = filter ((<= h) . (q +)) ds
    xs
      | u = delete q ts
      | otherwise = ds

leftBishop :: Bool -> Int -> Int -> [Int] -> [Int] -> Int -> Rings
leftBishop u q h ts ds lb
  | lRook <= h = xs >>= rightBishop u q h lb ds lRook
  | otherwise = []
  where
    lRook = lb + q
    xs
      | u = ts \\ [q, lb, lRook]
      | otherwise = ds

rightBishop :: Bool -> Int -> Int -> Int -> [Int] -> Int -> Int -> Rings
rightBishop u q h lb ds lRook rb
  | (rRook <= h) && (not u || (rRook /= lb)) =
    let ks
          | u = (ds \\ [q, lb, rb, rRook, lRook])
          | otherwise = ds
     in ks
          >>= knights u (lRook - rRook) lRook lb q rb rRook ks
  | otherwise = []
  where
    rRook = q + rb

knights :: Bool -> Int -> Int -> Int -> Int -> Int -> Int -> [Int] -> Int -> Rings
knights u rookDelta lRook lb q rb rRook ks k =
  [ (lRook, k, lb, q, rb, k2, rRook)
    | (k2 `elem` ks)
        && ( not u
               || notElem
                 k2
                 [lRook, k, lb, q, rb, rRook]
           )
  ]
  where
    k2 = k + rookDelta

なんだかなぁ…

素直に、かつ賢く探索

オリジナルの解法。
重複を許さない場合、リスト内包表記で、一つ候補が選ばれるたびに、以降の生成器で使える候補が減る、という構造の繰り返しになっているところを関数にまとめる。
すなわち、変数の候補を順に返す生成器に、そこで選択した要素を除いた残りの候補リストも返させる。

    ucand es = [(x,es1) | x <- es, let es1 = delete x es]

変数の値が固定的に決まる場合、現在の候補に残っている値か確認し、また候補リストから除く、
固定的な要素のみを返す ucand の変種を用意する。

    ufix v es = [(v, es1) | elem v es, let es1 = delete v es]

重複を許す場合にはこれらを、残りの候補リストを変更しない変種に差し替えることで、本体は共通にできる。

rings u ds =
  [ (a,b,c,d,e,f,g)
  | (a,ds1) <- cand ds
  , (b,ds2) <- cand ds1, let s = a + b
  , (c,ds3) <- cand ds2
  , (d,ds4) <- fix (a-c) ds3
  , (e,ds5) <- cand ds4
  , (f,ds6) <- fix (s-e-d) ds5
  , (g,_) <- fix (s-f) ds6 ]
  where
    (cand, fix) = if u then (ucand, ufix) else (ncand, nfix)
    ucand es = [(x,es1) | x <- es, let es1 = delete x es]
    ncand es = [(x,es)  | x <- es]
    ufix v es = [(v, es1) | elem v es, let es1 = delete v es]
    nfix v es = [(v, es)  | elem v es]

「構造的な探索」と同等の rings 関数がここまでコンパクトになった。

余談

あの悪夢の "Structured search" は、恐ろしいことに派生コードを産んでいる。
こんなことワザワザやるのは本人なんじゃないかと思うけど、編集履歴を追うのも面倒なので調べてはいない。