ab.com コミュニティ

パズル「ナンプレ」の自動生成機を作ってみました。

#N88BASIC
Dim A(8,8) As Byte,A$ As String,B(141) As Byte
Dim i As Long,j As Long,k As Long,i2 As Long,j2 As Long,i3 As Long,j3 As Long
Print "計算中..."
Print "Step 1"
randomize
For i2=0 To 2
	For j2=0 To 2
		For i=i2*3 To i2*3+2
			For j=j2*3 To j2*3+2
				k=Int(Rnd()*9)+1
				If IfCan(i,j,k) then
					A(i,j)=k
				Else
					If IfnCan(i,j) then
						For i=0 To 8
							For j=0 To 8
								A(i,j)=0
							Next
						Next
						i=0
						j=0
						i2=0
						j2=0
					End If
					j-=1
				End If
			Next
		Next
	Next
Next
i3=0
Print "Step 2"
Do
	i=Int(Rnd()*9)
	j=Int(Rnd()*9)
	If A(i,j)>10 then continue
	If IfCanThink(i,j) then
		A(i,j)=20
	Else
		A(i,j)+=10
	End If
	i3+=1
	If i3=81 then Exit Do
Loop
i3=0
For i=0 To 8
	For j=0 To 8
		A(i,j)-=10
		If A(i,j)<=9 then
			B(i3)=A(i,j)+48
			i3++
		Else
			B(i3)=63
			i3++
		End If
		If j=2 or j=5 then
			B(i3)=124
			i3++
		End If
	Next
	B(i3)=13
	B(i3+1)=10
	i3+=2
	If i=2 or i=5 then
		For i2=0 To 10
			B(i3)=61
			i3++
		Next
		B(i3)=13
		B(i3+1)=10
		i3+=2
	End If
Next
A$=MakeStr(B)
Cls 3
Print A$
Open Str$(Int(Rnd()*100000))+".txt" For Output As #1'かぶらなそうな名前にする。
Print #1,A$
Close #1

Function IfCan(i As Long,j As Long,k As Long) As Long
	Dim li As Long,lj As Long,c As Long
	For li=0 To 8
		If A(li,j)=k then c=-1
	Next
	For lj=0 To 8
		If A(i,lj)=k then c=-1
	Next
	For li=i\3*3 To i\3*3+2
		For lj=j\3*3 To j\3*3+2
			If A(li,lj)=k then c=-1
		Next
	Next
	If c=-1 then IfCan=FALSE else IfCan=TRUE
End Function

Function IfnCan(i As Long,j As Long) As Long
	Dim k As Long,c As Long
	c=0
	For k=1 To 9
		If IfCan(i,j,k) then
			c=-1
		End If
	Next
	If c=-1 then IfnCan=FALSE else IfnCan=TRUE
End Function

Function IfCanThink(i As Long,j As Long) As Long
	Dim k As Long,c As Long,a As Long
	a=A(i,j)
	A(i,j)=0
	c=IfCan2(i,j)
	A(i,j)=a
	If c=1 then IfCanThink=TRUE else IfCanThink=FALSE
End Function

Function IfCan2(i As Long,j As Long) As Long
	Dim a(8) As Byte,li As Long,lj As Long
	For li=0 To 8
		If A(li,j)<>20 then
			If A(li,j)>=10 then
				a(A(li,j)-10)=1
			Else
				a(A(li,j))=1
			End If
		End If
	Next
	For lj=0 To 8
		If A(i,lj)<>20 then
			If A(i,lj)>=10 then
				a(A(i,lj)-10)=1
			Else
				a(A(i,lj))=1
			End If
		End If
	Next
	For li=i\3*3 To i\3*3+2
		For lj=j\3*3 To j\3*3+2
			If A(li,lj)<>20 then
				If A(li,lj)>=10 then
					a(A(li,lj)-10)=1
				Else
					a(A(li,lj))=1
				End If
			End If
		Next
	Next
	lj=0
	For li=0 To 8
		lj=lj+a(li)
	Next
	If lj>=8 then IfCan2=TRUE else IfCan2=FALSE
End Function

解くことが可能かどうかの判定はしているつもりなんですが、なぜかいつも僕には解けません。（難しくて。）
頭の体操にはもってこいだと思いますが。

解答出力機能付き [ここをクリックすると内容が表示されます]

コード: 全て選択

#N88BASIC
Dim A(8,8) As Byte,A$ As String,B(141) As Byte,Ans(8,8) As Byte
Dim i As Long,j As Long,k As Long,i2 As Long,j2 As Long,i3 As Long,j3 As Long
Print "計算中..."
Print "Step 1"
randomize
For i2=0 To 2
    For j2=0 To 2
        For i=i2*3 To i2*3+2
            For j=j2*3 To j2*3+2
                k=Int(Rnd()*9)+1
                If IfCan(i,j,k) then
                    A(i,j)=k
                Else
                    If IfnCan(i,j) then
                        For i=0 To 8
                            For j=0 To 8
                                A(i,j)=0
                            Next
                        Next
                        i=0
                        j=0
                        i2=0
                        j2=0
                    End If
                    j-=1
                End If
            Next
        Next
    Next
Next
memcpy(Ans,A,81)
i3=0
Print "Step 2"
Do
    i=Int(Rnd()*9)
    j=Int(Rnd()*9)
    If A(i,j)>10 then continue
    If IfCanThink(i,j) then
        A(i,j)=20
    Else
        A(i,j)+=10
    End If
    i3+=1
    If i3=81 then Exit Do
Loop
i3=0
For i=0 To 8
    For j=0 To 8
        A(i,j)-=10
        If A(i,j)<=9 then
            B(i3)=A(i,j)+48
            i3++
        Else
            B(i3)=63
            i3++
        End If
        If j=2 or j=5 then
            B(i3)=124
            i3++
        End If
    Next
    B(i3)=13
    B(i3+1)=10
    i3+=2
    If i=2 or i=5 then
        For i2=0 To 10
            B(i3)=61
            i3++
        Next
        B(i3)=13
        B(i3+1)=10
        i3+=2
    End If
Next
A$=Str$(Int(Rnd()*100000))
Open A$+".txt" As #1
Open A$+"_ans.txt" As #2
A$=MakeStr(B)
Cls 3
Print A$
Print #1,A$
Close #1
i3=0
For i=0 To 8
    For j=0 To 8
        B(i3)=Ans(i,j)+48
        i3++
        If j=2 or j=5 then
            B(i3)=124
            i3++
        End If
    Next
    B(i3)=13
    B(i3+1)=10
    i3+=2
    If i=2 or i=5 then
        For i2=0 To 10
            B(i3)=61
            i3++
        Next
        B(i3)=13
        B(i3+1)=10
        i3+=2
    End If
Next
A$=MakeStr(B)
Print #2,A$
Close #2

Function IfCan(i As Long,j As Long,k As Long) As Long
    Dim li As Long,lj As Long,c As Long
    For li=0 To 8
        If A(li,j)=k then c=-1
    Next
    For lj=0 To 8
        If A(i,lj)=k then c=-1
    Next
    For li=i\3*3 To i\3*3+2
        For lj=j\3*3 To j\3*3+2
            If A(li,lj)=k then c=-1
        Next
    Next
    If c=-1 then IfCan=FALSE else IfCan=TRUE
End Function

Function IfnCan(i As Long,j As Long) As Long
    Dim k As Long,c As Long
    c=0
    For k=1 To 9
        If IfCan(i,j,k) then
            c=-1
        End If
    Next
    If c=-1 then IfnCan=FALSE else IfnCan=TRUE
End Function

Function IfCanThink(i As Long,j As Long) As Long
    Dim k As Long,c As Long,a As Long
    a=A(i,j)
    A(i,j)=0
    c=IfCan2(i,j)
    A(i,j)=a
    If c=1 then IfCanThink=TRUE else IfCanThink=FALSE
End Function

Function IfCan2(i As Long,j As Long) As Long
    Dim a(8) As Byte,li As Long,lj As Long
    For li=0 To 8
        If A(li,j)<>20 then
            If A(li,j)>=10 then
                a(A(li,j)-10)=1
            Else
                a(A(li,j))=1
            End If
        End If
    Next
    For lj=0 To 8
        If A(i,lj)<>20 then
            If A(i,lj)>=10 then
                a(A(i,lj)-10)=1
            Else
                a(A(i,lj))=1
            End If
        End If
    Next
    For li=i\3*3 To i\3*3+2
        For lj=j\3*3 To j\3*3+2
            If A(li,lj)<>20 then
                If A(li,lj)>=10 then
                    a(A(li,lj)-10)=1
                Else
                    a(A(li,lj))=1
                End If
            End If
        Next
    Next
    lj=0
    For li=0 To 8
        lj=lj+a(li)
    Next
    If lj>=8 then IfCan2=TRUE else IfCan2=FALSE
End Function

わお。ナンプレは最近Sudokuとかいって海外の方々にも受けているらしいですよね。
僕はこういうの大好きです。で、やり慣れているせいかもしれないのですが、結構簡単に(20分ほど)解けてしまいました。

出題データと解答データ [ここをクリックすると内容が表示されます]

マニアにはちょっと物足りないかも？(笑)

コード: 全て選択

i3=0 
Print "Step 2" 
Do 
    i=Int(Rnd()*9) 
    j=Int(Rnd()*9) 
    If A(i,j)>10 then continue 
    If IfCanThink(i,j) then 
        A(i,j)=20 
    Else 
        A(i,j)+=10 
    End If 
    i3+=1 
    If i3=81 then Exit Do 
Loop

の直後に

コード: 全て選択

i3=0
Do
    i=Int(Rnd()*9) 
    j=Int(Rnd()*9) 
    If A(i,j)=20 then continue
    A(i,j)=20
    i3++
    If i3=1 then Exit Do'任意の数値にする。あまり多いとたまに抜け出せなくなるので注意。
Loop

と入れると、解けるかどうかの判定抜きに不定箇所が増えるので、難しくなると思います。

ab.com コミュニティ

ナンプレ

ナンプレ

解答報告