Task: 24 game








VB: Sub Rosetta_24game()

Dim Digit(4) As Integer, i As Integer, iDigitCount As Integer
Dim stUserExpression As String
Dim stFailMessage As String, stFailDigits As String
Dim bValidExpression As Boolean, bValidDigits As Boolean, bValidChars As Boolean
Dim vResult As Variant, vTryAgain As Variant, vSameDigits As Variant


GenerateNewDigits:
    For i = 1 To 4
        Digit(i) = [randbetween(1,9)]
    Next i


GetUserExpression:
    bValidExpression = True
    stFailMessage = ""
    stFailDigits = ""
    stUserExpression = InputBox("Enter a mathematical expression which results in 24, using the following digits: " & _
        Digit(1) & ", " & Digit(2) & ", " & Digit(3) & " and " & Digit(4), "Rosetta Code | 24 Game")


    bValidDigits = True
    stFailDigits = ""
    For i = 1 To 4
        If InStr(stUserExpression, Digit(i)) = 0 Then
            bValidDigits = False
            stFailDigits = stFailDigits & " " & Digit(i)
        End If
    Next i
    If bValidDigits = False Then
        bValidExpression = False
        stFailMessage = "Your expression excluded the following required digits: " & stFailDigits & vbCr & vbCr
    End If


    bValidDigits = True
    stFailDigits = ""
    For i = 1 To Len(stUserExpression)
        If InStr("0123456789+-*/()", Mid(stUserExpression, i, 1)) = 0 Then
            bValidDigits = False
            stFailDigits = stFailDigits & " " & Mid(stUserExpression, i, 1)
        End If
    Next i
    If bValidDigits = False Then
        bValidExpression = False
        stFailMessage = stFailMessage & "Your expression contained invalid characters:" & stFailDigits & vbCr & vbCr
    End If


    bValidDigits = True
    stFailDigits = ""
    iDigitCount = 0
    For i = 1 To Len(stUserExpression)
        If Not InStr("0123456789", Mid(stUserExpression, i, 1)) = 0 Then
            iDigitCount = iDigitCount + 1
            If IsError(Application.Match(--(Mid(stUserExpression, i, 1)), Digit, False)) Then
                bValidDigits = False
                stFailDigits = stFailDigits & " " & Mid(stUserExpression, i, 1)
            End If
        End If
    Next i
    If iDigitCount > 4 Then
        bValidExpression = False
        stFailMessage = stFailMessage & "Your expression contained more than 4 digits" & vbCr & vbCr
    End If
        If iDigitCount < 4 Then
        bValidExpression = False
        stFailMessage = stFailMessage & "Your expression contained less than 4 digits" & vbCr & vbCr
    End If
    If bValidDigits = False Then
        bValidExpression = False
        stFailMessage = stFailMessage & "Your expression contained invalid digits:" & stFailDigits & vbCr & vbCr
    End If


    bValidDigits = True
    stFailDigits = ""
    For i = 11 To 99
        If Not InStr(stUserExpression, i) = 0 Then
            bValidDigits = False
            stFailDigits = stFailDigits & " " & i
        End If
    Next i
    If bValidDigits = False Then
        bValidExpression = False
        stFailMessage = stFailMessage & "Your expression contained invalid numbers:" & stFailDigits & vbCr & vbCr
    End If


    On Error GoTo EvalFail
    vResult = Evaluate(stUserExpression)
    If Not vResult = 24 Then
        bValidExpression = False
        stFailMessage = stFailMessage & "Your expression did not result in 24. It returned: " & vResult
    End If


    If bValidExpression = False Then
        vTryAgain = MsgBox(stFailMessage & vbCr & vbCr & "Would you like to try again?", vbCritical + vbRetryCancel, "Rosetta Code | 24 Game | FAILED")
            If vTryAgain = vbRetry Then
                vSameDigits = MsgBox("Do you want to use the same numbers?", vbQuestion + vbYesNo, "Rosetta Code | 24 Game | RETRY")
                If vSameDigits = vbYes Then
                    GoTo GetUserExpression
                Else
                    GoTo GenerateNewDigits
                End If
            End If
    Else
        vTryAgain = MsgBox("You entered: " & stUserExpression & vbCr & vbCr & "which resulted in: " & vResult, _
            vbInformation + vbRetryCancel, "Rosetta Code | 24 Game | SUCCESS")
        If vTryAgain = vbRetry Then
            GoTo GenerateNewDigits
        End If
    End If
    Exit Sub
EvalFail:
    bValidExpression = False
    vResult = Err.Description
    Resume
End Sub



Fortran: program game_24
  implicit none
  real               :: vector(4), reals(11), result, a, b, c, d
  integer            :: numbers(4), ascii(11), i
  character(len=11)  :: expression
  character          :: syntax(11)
  
  character, parameter :: one(11)   = (/ '(','(','1','x','1',')','x','1',')','x','1' /)
  character, parameter :: two(11)   = (/ '(','1','x','(','1','x','1',')',')','x','1' /)
  character, parameter :: three(11) = (/ '1','x','(','(','1','x','1',')','x','1',')' /)
  character, parameter :: four(11)  = (/ '1','x','(','1','x','(','1','x','1',')',')' /)
  character, parameter :: five(11)  = (/ '(','1','x','1',')','x','(','1','x','1',')' /)
  
  do
    call random_number(vector)
    numbers = 9 * vector + 1
    write (*,*) 'Digits: ',numbers
    write (*,'(a)',advance='no') 'Your expression: '
    read (*,'(a11)') expression

    forall (i=1:11) syntax(i) = expression(i:i)
    ascii = iachar(syntax)
    where (syntax >= '0' .and. syntax <= '9')
      syntax = '1'  
    elsewhere (syntax == '+' .or. syntax == '-' .or. syntax == '*' .or. syntax == '/')
      syntax = 'x'  
    elsewhere (syntax /= '(' .and. syntax /= ')')
      syntax = '-'  
    end where

    reals = real(ascii-48)
    if ( all(syntax == one) ) then
      a = reals(3); b = reals(5); c = reals(8); d = reals(11)
      call check_numbers(a,b,c,d)
      result = op(op(op(a,4,b),7,c),10,d)
    else if ( all(syntax == two) ) then
      a = reals(2); b = reals(5); c = reals(7); d = reals(11)
      call check_numbers(a,b,c,d)
      result = op(op(a,3,op(b,6,c)),10,d)
    else if ( all(syntax == three) ) then
      a = reals(1); b = reals(5); c = reals(7); d = reals(10)
      call check_numbers(a,b,c,d)
      result = op(a,2,op(op(b,6,c),9,d))
    else if ( all(syntax == four) ) then
      a = reals(1); b = reals(4); c = reals(7); d = reals(9)
      call check_numbers(a,b,c,d)
      result = op(a,2,op(b,5,op(c,8,d)))
    else if ( all(syntax == five) ) then
      a = reals(2); b = reals(4); c = reals(8); d = reals(10)
      call check_numbers(a,b,c,d)
      result = op(op(a,3,b),6,op(c,9,d))
    else
      stop 'Input string: incorrect syntax.'
    end if

    if ( abs(result-24.0) < epsilon(1.0) ) then
      write (*,*) 'You won
    else
      write (*,*) 'Your result (',result,') is incorrect
    end if
  
    write (*,'(a)',advance='no') 'Another one? [y/n] '
    read (*,'(a1)') expression
    if ( expression(1:1) == 'n' .or. expression(1:1) == 'N' ) then
      stop
    end if  
  end do
  
contains

  pure real function op(x,c,y)
    integer, intent(in) :: c
    real, intent(in) :: x,y
    select case ( char(ascii(c)) )
      case ('+')
        op = x+y
      case ('-')
        op = x-y
      case ('*')
        op = x*y
      case ('/')
        op = x/y
    end select
  end function op
  
  subroutine check_numbers(a,b,c,d)
    real, intent(in) :: a,b,c,d
    integer          :: test(4)
    test = (/ nint(a),nint(b),nint(c),nint(d) /)
    call Insertion_Sort(numbers)
    call Insertion_Sort(test)
    if ( any(test /= numbers) ) then
      stop 'You cheat ;-) (Incorrect numbers)'
    end if
  end subroutine check_numbers
  
  pure subroutine Insertion_Sort(a)
    integer, intent(inout) :: a(:)
    integer                :: temp, i, j
    do i=2,size(a)
      j = i-1
      temp = a(i)
      do while ( j>=1 .and. a(j)>temp )
        a(j+1) = a(j)
        j = j - 1
      end do
      a(j+1) = temp
    end do
  end subroutine Insertion_Sort

end program game_24