123-45-67+89=100

日経サイエンス誌の数学コラムをやっていたイアン・スチュアート氏の『数学の秘密の本棚』という本があったので暇つぶしに買ってみました。古いパズルから最近流行の話題まで色々載っており、また問題がわりあい易し目なのが多いので、理解できずにがっくりすること無く楽しめます。

その中の「デジタルで１００」という問題をFortranで解くことにします。

問題は、１ ２ ３ ４ ５ ６ ７ ８ ９ のどこかに数学記号を３つ入れて答えが１００になるようにするというものです。ここで数学記号の定義が何なのかよく分からなかったりするのですが、全体として数字と数字の間に加減乗除の記号を入れると解釈することにします。なお、記号は複数回使ってよく、数字は並べ替えてはならないという付加条件があります。

まず３重DO LOOPで数字を分割し、さらに３重DO LOOPで加減乗除の記号を生成して、その後簡単なスタック式計算式評価サブルーチンを使って評価します。ここで、割り算はきっかり割り切れたときのみ有効で、余りがでる場合は無効とみなすことにします。

FUNCTIONの返り値としてALLOCATABLEなINTEGER配列を使うこととし、有効な結果であれば大きさ１の配列に整数値を入れて返し、割り算が割り切れないとき等は、０サイズの配列を返すことでエラーを表す事にします。

■実行結果

一通りしか解がありませんでした。これは本の答えと一致します。

■ソース・コード

メイン・プログラムの６重ループに工夫がないですが、面倒くさくなってあまり考えませんでした。
Fortran2003のOOP機能として、不定型の入力引数型CLASS(*)を使ってみました。整数を引数にするか、文字型を引数にするかで挙動を変えます。機能としては総称名定義と似ています。

スタックを実現する為に配列長の自動最割付を多用しています。コンパイル・オプションとして/assume:realloc_lhsが必要となります。

配列生成子の使い方で、this%i = [this%i, x]の場合は、素直にthis%i(:)は配列長が１個のびて尻にxがくっつきますが、LISPのCONS的に前にくっつけようとすると、this%i = [ [x], this%i]のようにxを [x]のように配列生成子としてくくってやる必要があります。（右辺の要素を前から順番に放り込んでゆくのか、左辺に代入する前に右辺を評価するのかの違いのようですが、文法的に微妙な問題の気がします。）

MODULE m_stackでスタック計算機を、m_evalで簡単なパーサーを定義しています。メイン・ルーチンは数字の切り分けと演算記号の生成を行い、あらゆる可能な式を作っています。

MODULE m_stack
   IMPLICIT NONE
   TYPE :: t_stack 
    INTEGER  , ALLOCATABLE :: i(:)
    CHARACTER, ALLOCATABLE :: c(:)
   CONTAINS
    PROCEDURE :: push
    PROCEDURE :: pop
    PROCEDURE :: calc
   END TYPE
    
  CONTAINS

   SUBROUTINE push(this, x)
    CLASS(t_stack), INTENT(IN OUT) :: this
    CLASS(*), INTENT(IN) :: x
    SELECT TYPE(x)
     TYPE IS (INTEGER)
      this%i = [[x], this%i]
     TYPE IS (CHARACTER(*))
      this%c = [[x], this%c]
     CLASS DEFAULT
      STOP ' Error :: SUBROUTINE push'
    END SELECT
    RETURN
   END SUBROUTINE push

   SUBROUTINE pop(this, x)
    CLASS(t_stack), INTENT(IN OUT) :: this
    CLASS(*), INTENT(IN OUT) :: x
    SELECT TYPE(x)
     TYPE IS (INTEGER)
      x = this%i(1)
      this%i = [this%i(2:)]
     TYPE IS (CHARACTER(*))
      x = this%c(1)
      this%c = [this%c(2:)]
     CLASS DEFAULT
      STOP ' Error :: SUBROUTINE pop'
    END SELECT
    RETURN
   END SUBROUTINE pop
  
   FUNCTION calc(this) RESULT(err)
    CLASS(t_stack), INTENT(IN OUT) :: this
    LOGICAL :: err
    CHARACTER :: iop
    INTEGER :: n1, n2
    INTEGER, ALLOCATABLE :: n(:) 
    CALL this%pop(iop)
    CALL this%pop(n2)
    CALL this%pop(n1)
    n = icalc(iop, n1, n2)
    IF (SIZE(n) == 1) THEN
     CALL this%push(n(1))
     err = .FALSE.
    ELSE
     err = .TRUE. 
    END IF
    RETURN
    
   CONTAINS
   
    FUNCTION icalc(iop, n1, n2)
     INTEGER, ALLOCATABLE :: icalc(:)
     CHARACTER, INTENT(IN) :: iop
     INTEGER, INTENT(IN) :: n1, n2
     SELECT CASE(iop)
      CASE('+')
       icalc = [ n1 + n2 ]
      CASE('-') 
       icalc = [ n1 - n2 ]
      CASE('*')
       icalc = [ n1 * n2 ]
      CASE('/')
       IF ( n2 == 0 .OR. MOD(n1, n2) /= 0 ) THEN
        icalc = icalc(1:0) ! [] ! indivisible
       ELSE
        icalc = [ n1 / n2 ]
       END IF
      CASE DEFAULT
       icalc = icalc(1:0) ! [] ! undefined operator
     END SELECT
     RETURN
    END FUNCTION icalc

   END FUNCTION calc
   
END MODULE m_stack

!====================================================

MODULE m_eval
   USE m_stack
   IMPLICIT NONE
 
   TYPE :: t_exp
     INTEGER  , ALLOCATABLE :: n(:)
     CHARACTER, ALLOCATABLE :: op(:)
    CONTAINS
     PROCEDURE :: ieval
   END TYPE t_exp
 
 CONTAINS
 
    FUNCTION ieval(this) 
     INTEGER, ALLOCATABLE :: ieval(:)
     CLASS(t_exp), INTENT(IN) :: this
     INTEGER  , ALLOCATABLE :: num(:)
     CHARACTER, ALLOCATABLE :: opr(:)
     TYPE(t_stack) :: stack
     CHARACTER :: opp
     INTEGER :: ires

     ieval = [ieval(1:0)] ![] : error
     CALL stack%push( this%n(1) )
     num = [this%n(2:)]
     opr = [this%op]
     DO 
      IF ( SIZE(opr) > 0 ) THEN
       IF ( SCAN('+-', opr(1)) > 0 ) THEN
        CALL stack%push( num(1)  )
        opp = opr(1)
        num = [num(2:)]
        opr = [opr(2:)]
        IF ( eval2() ) RETURN
        CALL stack%push( opp )
        IF ( stack%calc() ) RETURN       
       ELSE IF ( SCAN('*/', opr(1)) > 0 ) THEN
        CALL stack%push( num(1) )
        CALL stack%push( opr(1) )
        num = [num(2:) ]
        opr = [opr(2:)]
        IF ( stack%calc() ) RETURN 
       ELSE
        STOP 'undefined operator'
       END IF
     ELSE
       CALL stack%pop(ires)
       ieval = [ires]
       RETURN
      END IF
     END DO
     STOP 'never reach here'         

    CONTAINS
    
     RECURSIVE FUNCTION eval2() RESULT(err)
      LOGICAL :: err
      err = .TRUE.
      IF ( SIZE(opr) == 0 ) THEN 
       err = .FALSE. 
       RETURN      
      END IF
      IF ( SCAN('+-', opr(1)) > 0 ) THEN
       err = .FALSE. 
      ELSE IF ( SCAN('*/', opr(1)) > 0 ) THEN
       CALL stack%push( num(1) )
       CALL stack%push( opr(1) )
       num = [num(2:)]
       opr = [opr(2:)]
       IF ( stack%calc() ) RETURN       
       IF ( eval2() ) RETURN
       err = .FALSE.
      ELSE
       STOP 'undefined operator: eval2'
      END IF
      RETURN
     END FUNCTION eval2 

   END FUNCTION ieval   
END MODULE m_eval

!==============================================

PROGRAM test
   USE m_eval
   IMPLICIT NONE
   INTEGER, ALLOCATABLE :: n(:)
   TYPE(t_exp) :: expression
   CHARACTER(LEN = 9), PARAMETER :: text = '123456789'
   CHARACTER(LEN = 1), PARAMETER :: oper(4) = TRANSFER('+-*/', [' '], 4) !['+', '-', '*', '/']
   INTEGER :: i, i1, i2, i3, k, kop1, kop2, kop3, num(4)
   CHARACTER(LEN = 1) :: ops(3)  
   DO i1 = 1, 6
    num(1) = itext( text(1:i1) )
    DO i2 = i1 + 1, 7
     num(2) = itext( text(i1 + 1:i2) )
     DO i3 = i2 + 1, 8
      num(3) = itext( text(i2 + 1:i3) )
      num(4) = itext( text(i3 + 1:9 ) )
      DO kop1 = 1, 4
       ops(1) = oper(kop1)
       DO kop2 = 1, 4
        ops(2) = oper(kop2)
        DO kop3 = 1, 4
         ops(3) = oper(kop3)
         expression = t_exp(num, ops)
         n = expression%ieval()
         IF ( SIZE(n) == 0 ) CYCLE
         IF ( n(1) == 100 ) PRINT '(10(i5, a3))', (num(i), ops(i), i = 1, 3), num(4), '=', n
        END DO
       END DO
      END DO
     END DO
    END DO
   END DO
   STOP
   
 CONTAINS

   INTEGER FUNCTION itext(text)
     CHARACTER(LEN = *), INTENT(IN) :: text
     READ(text, *) itext
     RETURN
   END FUNCTION itext

END PROGRAM test