'MAGIC12.BAS H.Heinz April 1997
' July 3 /94 Magic12.bas
' after completing LoubereM sub-program & ClearText S.R.
' June 17 / 94 Magic11.bas
' use screen 12 for everything except sqrInput which uses screen 0
' April 20, 1994 Magic10.bas
' Start modifying MAGIC9C.BAS for screen 12 & magic lines routine
' This is modified version of MAGIC8.BAS as it was on Mar.9/94
' --- Following REM's apply to MAGIC8.BAS
' --- This is modified version of MAGICSQR.BAS 3/11/93 11:35
' --- This is MATTEST2.BAS renamed & with subprograms modified somewhat
' --- modified Mar6/93 to allow testing m.s. with non-consequetive numbers.
' --- demo Magic Square program showing use of general order sub-routines.
' --- this is a fully functional program for testing magic squares of
' order 2 to 9. The sub-routines adjust accordingly.
' --- matrixA() is used in subroutines to hold EITHER origSqr() OR rotateSqr().
DEFINT A-Z
CONST false = 0, true = NOT false
COMMON SHARED size, sum, sumCorrect, endroutine, origSqr(), rotateSqr(), nograph
DECLARE SUB AssocSum (matrixA()) ' test associated pairs
DECLARE SUB ClearText () ' clear some text for large m.s.
DECLARE SUB DiagSum (matrixA(), mainSum) ' test diagonals
DECLARE SUB DisplayMenuBox (choiceList$(), leftCoord, Prompt$, ok$) ' display main menu
DECLARE SUB displaySqr (pairnum()) ' control printing sqr
DECLARE SUB frame (left, right, top, bottom) ' draw a frame
DECLARE SUB lineImput () ' input a new square
DECLARE SUB Loubere () ' Loubere method
DECLARE SUB LoubereM () ' Modified Loubere method
DECLARE SUB magicLines () ' called by showSqr
DECLARE SUB MatRotate () ' rotate the original
DECLARE SUB menu2 (storedSqr()) ' select a stored m. s.
DECLARE SUB menu3 () ' demo's of construction
DECLARE SUB OrthoSum (matrixA()) ' test rows, columns
DECLARE SUB pan5x5 (matrixA(), pTbl(), pairnum()) 'generate all 5x5 basic pand
DECLARE SUB Pause () ' pauses for a keypress
DECLARE SUB SemiPanSum (matrixA()) ' test oppos. short diag
DECLARE SUB showSqr () ' print the square & grid
DECLARE SUB sqrInput () ' edit the square in memory
DECLARE SUB titleOne () ' prints the main title
DECLARE FUNCTION Getletter$ (Prompt$, legal$) ' get a letter
DECLARE FUNCTION menu (choices$()) ' main menu
DIM pairnum(3 TO 9) ' holds # of pairs for each order
DIM storedSqrs(1084) ' all squares are stored linearly, 1 after the other
DIM origSqr(9, 9) ' this array holds the original version
DIM rotateSqr(9, 9) ' this is a copy rotated 90 degrees
DIM matrixA(size, size) ' this matrix holds the m.s. in the sub-rout.
DIM menuOptions$(6) ' list of choices for the main menu
DIM pTbl(1 TO 36, 1 TO 9) ' table 7 from book p. 1137
SCREEN 12 ' run program on graphic screen with 80 x 30 text
nograph = 0 ' permit graphs unless this is 1 (sqrInput)
' --- # of correct associated pairs for each order (for Associated magic square).
DATA 4,8,12,18,24,32,40
FOR i = 3 TO 9 ' load into pairnum array
READ pairnum(i)
NEXT i
' --- sample magic squares, ALL are 'normal' except last order 6 (l) because NO normal
' singly-even order associated magic squares.
' --- order 4 squares
DATA 7,6,12,9,15,14,4,1,2,11,5,16,10,3,13,8
DATA 2,8,15,9,11,13,6,4,14,12,3,5,7,1,10,16
DATA 2,11,7,14,13,8,12,1,16,5,9,4,3,10,6,15
DATA 1,15,6,12,14,4,9,7,11,5,16,2,8,10,3,13
' --- order 5 squares
DATA 23,6,19,2,15,10,18,1,14,22,17,5,13,21,9,4,12,25,8,16,11,24,7,20,3
DATA 14,10,1,22,18,20,11,7,3,24,21,17,13,9,5,2,23,19,15,6,8,4,25,16,12
DATA 23,1,2,20,19,22,16,9,14,4,5,11,13,15,21,8,12,17,10,18,7,25,24,6,3
DATA 1,15,24,8,17,23,7,16,5,14,20,4,13,22,6,12,21,10,19,3,9,18,2,11,25
' --- order 6 magic squares
DATA 1,35,34,3,32,6,30,8,28,27,11,7,24,23,15,16,14,19,13,17,21,22,20,18,12,26,9,10,29,25,31,2,4,33,5,36
DATA 17,8,33,24,2,27,32,22,11,25,16,5,3,30,14,9,36,19,18,1,28,23,7,34,31,21,12,26,15,6,10,29,13,4,35,20
DATA 32,31,1,3,21,23,29,30,4,2,24,22,9,11,20,19,25,27,12,10,17,18,28,26,16,15,33,35,5,7,13,14,36,34,8,6
DATA 1,47,6,43,5,48,35,17,30,21,31,16,36,12,41,8,40,13,7,45,2,49,3,44,29,19,34,15,33,20,42,10,37,14,38,9
' --- order 7 magic squares
DATA 46,1,2,3,42,41,40,45,35,13,14,32,31,5,44,34,28,21,26,16,6,7,17,23,25,27,33,43,11,20,24,29,22,30,39,12,19,37,36,18,15,38,10,49,48,47,8,9,4
DATA 26,20,14,1,44,38,32,34,28,15,9,3,46,40,42,29,23,17,11,5,48,43,37,31,25,19,13,7,2,45,39,33,27,21,8,10,4,47,41,35,22,16,18,12,6,49,36,30,24
DATA 42,18,29,9,45,26,6,20,35,11,43,23,3,40,4,36,16,31,12,48,28,33,13,49,25,1,37,17,22,2,38,19,34,14,46,10,47,27,7,39,15,30,44,24,5,41,21,32,8
DATA 1,8,17,26,35,40,48,30,41,46,4,10,16,28,12,21,23,31,39,43,6,36,45,5,14,19,24,32,20,25,29,38,47,7,9,49,2,13,18,22,34,37,27,33,42,44,3,11,15
' --- order 8 magic squares
DATA 1,63,62,4,5,59,58,8,56,15,49,48,19,44,20,9,55,47,25,39,38,28,18,10,11,22,36,30,31,33,43,54,53,42,32,34,35,29,23,12,13,24,37,27,26,40,41,52,14,45,16,17,46,21,50,51,57,2,3,61,60,6,7,64
DATA 1,57,40,32,5,44,29,52,48,24,9,49,61,20,37,12,25,33,64,8,36,13,60,21,56,16,17,41,28,53,4,45,50,47,2,31,43,19,38,30,7,26,55,42,54,14,59,3,63,34,15,18,27,35,22,46,10,23,58,39,6,62,11,51
DATA 1,2,62,61,60,59,7,8,9,10,54,53,52,51,15,16,48,47,19,20,21,22,42,41,40,39,27,28,29,30,34,33,32,31,35,36,37,38,26,25,24,23,43,44,45,46,18,17,49,50,14,13,12,11,55,56,57,58,6,5,4,3,63,64
DATA 7,42,55,26,31,50,47,2,62,19,14,35,38,11,22,59,1,48,49,32,25,56,41,8,60,21,12,37,36,13,20,61,4,45,52,29,28,53,44,5,57,24,9,40,33,16,17,64,6,43,54,27,30,51,46,3,63,18,15,34,39,10,23,58
' --- order 9 magic squares
DATA 77,1,2,3,4,72,71,70,69,76,62,17,18,19,58,57,56,6,75,61,51,29,30,48,47,21,7,74,60,50,44,37,42,32,22,8,9,23,33,39,41,43,49,59,73,14,27,36,40,45,38,46,55,68,15,28,35,53,52,34,31,54,67,16,26,65,64,63,24,25,20,66,13,81,80,79,78,10,11,12,5
DATA 42,34,26,18,1,74,66,58,50,52,44,36,19,11,3,76,68,60,62,54,37,29,21,13,5,78,70,72,55,47,39,31,23,15,7,80,73,65,57,49,41,33,25,17,9,2,75,67,59,51,43,35,27,10,12,4,77,69,61,53,45,28,20,22,14,6,79,71,63,46,38,30,32,24,16,8,81,64,56,48,40
DATA 71,64,69,8,1,6,53,46,51,66,68,70,3,5,7,48,50,52,67,72,65,4,9,2,49,54,47,26,19,24,44,37,42,62,55,60,21,23,25,39,41,43,57,59,61,22,27,20,40,45,38,58,63,56,35,28,33,80,73,78,17,10,15,30,32,34,75,77,79,12,14,16,31,36,29,76,81,74,13,18,11
DATA 75,53,11,25,14,65,48,42,36,10,26,74,54,49,43,32,15,66,71,57,7,29,33,16,67,50,39,8,28,72,56,68,46,40,34,17,52,69,13,30,41,35,18,64,47,12,27,38,51,77,80,20,3,61,37,59,76,9,24,4,60,81,19,73,6,23,45,58,79,21,2,62,31,44,55,70,5,1,63,78,22
' --- All the magic squares are stored in 1 long string. The starting position for each m.s. is:
' order 4; 1, 17, 33, 49 order 5; 65, 90, 115,140
' order 6; 165,201,237,273 order 7; 309,358,407,456
' order 8; 505,569,633,697 order 9; 761,842,923,1004
FOR i = 1 TO 1084 ' load into storedSqrs array
READ storedSqrs(i)
NEXT i
' --- data for pTbl used in Pan5x5 routine - this is table 7 in the book
DATA 1,1,1,10,15,20,3,4,5,2,3,1,10,15,20,3,5,4,3,5,1,10,20,15,3,4,5
DATA 4,7,1,10,20,15,3,5,4,5,9,1,10,15,20,4,3,5,6,11,1,10,15,20,4,5,3
DATA 7,13,1,10,20,15,4,3,5,8,15,1,10,20,15,4,5,3,9,17,1,10,15,20,5,3,4
DATA 10,19,1,10,15,20,5,4,3,11,21,1,10,20,15,5,3,4,12,23,1,10,20,15,5,4,3
DATA 13,25,2,15,10,20,3,4,5,14,27,2,15,10,20,3,5,4,15,29,1,15,20,10,3,4,5
DATA 16,31,1,15,20,10,3,5,4,17,33,2,15,10,20,4,3,5,18,35,2,15,10,20,4,5,3
DATA 19,37,1,15,20,10,4,3,5,20,39,1,15,20,10,4,5,3,21,41,2,15,10,20,5,3,4
DATA 22,43,2,15,10,20,5,4,3,23,45,1,15,20,10,5,3,4,24,47,1,15,20,10,5,4,3
DATA 25,49,2,20,10,15,3,4,5,26,51,2,20,10,15,3,5,4,27,53,2,20,15,10,3,4,5
DATA 28,55,2,20,15,10,3,5,4,29,57,2,20,10,15,4,3,5,30,59,2,20,10,15,4,5,3
DATA 31,61,2,20,15,10,4,3,5,32,63,2,20,15,10,4,5,3,33,65,2,20,10,15,5,3,4
DATA 34,67,2,20,10,15,5,4,3,35,69,2,20,15,10,5,3,4,36,71,2,20,15,10,5,4,3
FOR snum = 1 TO 36 ' load into pTbl array
FOR j = 1 TO 9
READ pTbl(snum, j)
NEXT j
NEXT snum
' --- Main menu options
DATA show a stored square
DATA input a new square
DATA edit the square in memory
DATA display 5x5 pandiagonals
DATA view construction methods
DATA quit the program
FOR i = 1 TO 6 ' load into menuOptions array
READ menuOptions$(i)
NEXT i
CLS
' --- Display the menu & react to the user's choices
DO
titleOne ' print the main title
PRINT "This is a demo program only. Still being added to and modified. h.h. 12-1-93"
SELECT CASE menu(menuOptions$())
CASE 1 ' select a stored magic square
menu2 storedSqrs()
CASE 2 ' input a new magic square
lineImput
CASE 3
SCREEN 0
CLS : nograph = 1 ' flag to prevent graph
showSqr ' put the square on screen
sqrInput ' edit the square on screen
SCREEN 12
nograph = 0 ' reset for graphs
CASE 4 ' generate ALL essentially different
sum = 0
pan5x5 matrixA(), pTbl(), pairnum() ' order 5 pandiagonal m.s. (36)
CASE 5 ' show methods of construction
menu3
CASE 6
done = true ' set flag to exit program
CASE ELSE
' --- not necessary to do anything
END SELECT
IF NOT done THEN ' show the selected magic square
IF size > 0 THEN ' if no m.s. in memory
displaySqr pairnum() ' don't try to display one
Pause ' continue when ready
END IF
CLS
END IF
LOOP UNTIL done
SCREEN 0 ' reset for standard text screen before exit
END
keyevent: ' ---- exit sub-program if Function key two is pressed
endroutine = true
RETURN
PrinterError: ' --- Traps printer errors and pauses for corrections
LOCATE 23, 20
PRINT "*** Printer not in Operation ***"
Pause
LOCATE 23, 20
PRINT " "
RESUME NEXT
SUB AssocSum (matrixA())
' This sub routine tests for pairs of cells that are diametrically equidistant
' from the center summing to the total of the first and last numbers in the series.
' It test the corresponding pairs in the top left & lower right quadrants.
' On the second call it tests these same quadrants, but in the rotated matrix.
' This routine works on odd or doubly-even order NORMAL magic squares.
' Singly-even order m.s. are also tested although NO assoc.m.s. of this order.
' It is called by the displaySqr sub-routine.
sumCorrect = 0
pairsSum = size * size + 1 ' i.e. N^2+1 (only for NORMAL m.s.)
halfSize = size \ 2 ' integer division
IF size MOD 2 = 1 THEN
oddOrder = true ' order is odd
center = halfSize + 1
IF matrixA(center, center) = ((size * size) + 1) / 2 THEN
CouldBeAssoc = true
ELSE ' assoc. odd order m.s. must
CouldBeAssoc = false ' have center cell equal to
END IF ' (N^2 + 1)/2
ELSE
oddOrder = false ' order is even
CouldBeAssoc = true ' so it could be associated
END IF
cn = 1: cx = size
IF CouldBeAssoc THEN ' run test only if possibility
' of being associated
DO
rn = 1: rx = size
DO ' cycle through pairs of cells in
testSum = 0 ' upper left & lower right
testSum = matrixA(rn, cn) + matrixA(rx, cx)
IF testSum = pairsSum THEN
sumCorrect = sumCorrect + 1 ' count correct pairs
END IF
rn = rn + 1: rx = rx - 1
LOOP UNTIL rn > halfSize ' by rows, then columns
cn = cn + 1: cx = cx - 1
LOOP UNTIL cn > halfSize
IF oddOrder THEN ' odd order m.s. require you
cn = halfSize + 1 ' now do center column
rn = 1: rx = size
DO ' check pairs in center column
testSum = 0
testSum = matrixA(rn, cn) + matrixA(rx, cn)
IF testSum = pairsSum THEN
sumCorrect = sumCorrect + 1 ' second call, in effect
END IF ' does center row
rn = rn + 1: rx = rx - 1
LOOP UNTIL rn > halfSize
END IF
END IF
END SUB
SUB ClearText
' This sub-rooutine is used to clear several lines of text in the
' LoubereM sub-program
LOCATE 4, 1 ' erase text
FOR i = 1 TO 6
PRINT STRING$(80, 32)
NEXT i
END SUB
SUB DiagSum (matrixA(), mainSum)
' Sub routine DiagSum calculates & checks the sums of all the diagonals
' including broken diagonal pairs. It returns a count of the # correct.
' Call twice, once checks original, 2nd time checks rotated square to get
' diagonals in the other direction.
' MatrixA() holds origSqr() on first pass, rotateSqr() on second pass.
' It is called by the displaySqr sub-routine.
sumCorrect = 0 ' reset count of correct sums
mainSum = 0 ' reset main diagonal flag
' --- test diagonals from upper left to lower right, starting with main diagonal
FOR k = 1 TO size ' k counts the # of diagonals
testSum = 0 ' initialize for new diagonal
i = k: j = 0
DO
j = j + 1
testSum = testSum + matrixA(i, j)
IF i = size THEN ' move to 2nd half of broken diagonal
i = 1
ELSE i = i + 1
END IF
LOOP WHILE j < size ' is diagonal finished
IF k = 1 AND j = size AND testSum = sum THEN mainSum = 1 'main diagonal
IF testSum = sum THEN
sumCorrect = sumCorrect + 1 ' add to count if correct sum
END IF
NEXT k ' test next diagonal pair
END SUB
SUB DisplayMenuBox (choiceList$(), leftCoord, Prompt$, ok$)
' The DisplayMenuBox subprogram displays the menu choices on the screen and
' prepares the prompt string and validation string. This routine is called
' from the Menu function.
' --- Find the number of choices (numChoices) and initialize variables.
numChoices = UBOUND(choiceList$)
Prompt$ = " "
ok$ = ""
longChoice = 0
' --- Prepare the prompt string (prompt$) and the string of legal input
' characters (ok$). Also, find the length of the longest choice string.
FOR i = 1 TO numChoices
first$ = UCASE$(LEFT$(choiceList$(i), 1))
ok$ = ok$ + first$
Prompt$ = Prompt$ + first$ + " "
longTemp = LEN(choiceList$(i))
IF longTemp > longChoice THEN longChoice = longTemp
NEXT i
longChoice = longChoice + 1
Prompt$ = Prompt$ + "-> "
' --- Test to see if the prompt string is longer then promptChoice
IF LEN(Prompt$) >= longChoice THEN longChoice = LEN(Prompt$) + 1
' --- Given longChoice and numChoice, determine the demensions of the
' menu frame. Draw the frame, calling on the frame subprogram.
leftCoord = 37 - longChoice \ 2
rightCoord = 80 - leftCoord
topCoord = 5
bottomCoord = 10 + numChoices
frame leftCoord, rightCoord, topCoord, bottomCoord
' --- Display the menu choices. The first letter of each choice is
' displayed in uppercase, followed by a parenthesis character.
FOR i = 1 TO numChoices
LOCATE 7 + i, leftCoord + 3
PRINT UCASE$(LEFT$(choiceList$(i), 1)) + ")" + MID$(choiceList$(i), 2)
NEXT i
LOCATE 6, 38: PRINT "Menu"
line$ = STRING$(longChoice, 196)
LOCATE 7, leftCoord + 3: PRINT line$
LOCATE 8 + numChoices, leftCoord + 3: PRINT line$
' --- Print the input prompt.
LOCATE 9 + numChoices, leftCoord + 3: PRINT Prompt$;
END SUB
SUB displaySqr (pairnum())
' --- This subroutine handles the display of the square and summary.
' It also calls the routines that tests the various aspects of m.s.
' It is called from the main program & pan5X5 sub-routine.
CLS
titleOne ' print the main title
' --- sum is calculated for a normal m.s. (i.e. 1st N^2 natural numbers)(if it is now 0)
IF sum = 0 THEN sum = (size * size * size + size) / 2 ' this test allows for impure m.s.
halfSize = size \ 2 ' this is integer division
top = 13 - size: bottom = top + size * 2 + 1 ' position on the screen
showSqr ' routine to print square & grid
MatRotate ' rotate 90 degrees right
' --- test sums of rows (& later columns) & count correct ones
sumFlag = 0: sumFlag2 = 0 ' keep track of rows, col., & main diag
OrthoSum origSqr() ' test rows
rowTotal = sumCorrect ' # of rows correct
IF rowTotal = size THEN sumFlag = 1 ' i.e. all rows are correct
OrthoSum rotateSqr() ' test columns (of original m.s.)
colTotal = sumCorrect ' # of columns correct
IF colTotal = size THEN sumFlag = sumFlag + 1 ' i.e. all columns correct
' --- Test that main diagonals are correct. Also test all broken diagonals.
DiagSum origSqr(), mainSum ' test original diagonals
diagTotal = sumCorrect
sumFlag = sumFlag + mainSum ' add 1 if main diagonal OK
DiagSum rotateSqr(), mainSum ' test rotated diagonals
diagTotal = diagTotal + sumCorrect ' # of main & broken diagonals cor.
sumFlag = sumFlag + mainSum ' add 1 if main diagonal OK
IF diagTotal = 2 * size THEN
diagFlag = true ' this is a pandiagonal m.s.
END IF
' ---Count the number of complementary pairs for possible Associated m.s.
AssocSum origSqr() ' test for associated
assocTotal = sumCorrect ' # of pairs correct
AssocSum rotateSqr() ' test other 2 quadrants
assocTotal = assocTotal + sumCorrect ' total # of pairs correct
'Count opposite short diagonal pairs with the correct sum.
semipanTotal = 0
IF NOT diagFlag AND size > 3 THEN ' if not pandiagonal, semiPan ?
SemiPanSum origSqr() ' check for semi-pan
semipanTotal = sumCorrect ' is opposite short diagonal cor.
SemiPanSum rotateSqr() ' check for semi-pan
semipanTotal = semipanTotal + sumCorrect ' total # correct (need 2)
END IF
' --- Check values from above tests and advise specifications of magic square.
LOCATE 25, 1 'locate at bottom of screen
PRINT "Total rows correct: "; rowTotal, "Total columns correct: "; colTotal
PRINT "Total diagonals correct: "; diagTotal,
IF diagFlag THEN ' advise if this is a pandiagonal
PRINT "This is a Pandiagonal M.S.",
sumFlag2 = sumFlag + 1 ' add 1 to show it's not simple
END IF
IF semipanTotal = 2 THEN ' advise if semi-pandiagonal
PRINT "This is a Semi-Pandiagonal M. S.",
sumFlag2 = sumFlag + 1 ' add 1 to show it's not simple
END IF
IF assocTotal > 0 THEN ' show # of correct pairs
PRINT "Pairs of 2 assoc. cells correct:"; assocTotal,
END IF
IF assocTotal = pairnum(size) THEN ' correct # of pairs?
PRINT "This is an Associated M. Sqr.", ' # of pairs is correct for size
sumFlag2 = sumFlag + 1 ' add 1 to show it's not simple
END IF
' --- some squares may NOT have correct rows, or columns & still have correct diagonals
' or associated pairs. i.e. 16,2,14,4,5,11,7,9,8,10,6,12,13,3,15,1 has NO correct
' rows or columns yet otherwise it would be an associated pandiagonal m.s.
IF sumFlag = 4 AND sumFlag2 = 0 THEN ' ALL rows, col. & 2 main diag. O.K.?
PRINT "This is a simple magic square.",
ELSEIF sumFlag = 3 THEN ' only 1 main diagonal O.K.
PRINT "This square is only semi-magic !!",
ELSEIF sumFlag < 3 THEN ' not all rows or col. correct
PRINT "This square is NOT magic !!!", ' or not both diagonals
END IF
IF sumFlag > 3 THEN PRINT "The Magic Sum is "; sum; ' magic!! so constant is ...
END SUB
SUB frame (left, right, top, bottom) STATIC
' The Frame subprogram draws a rectangular double-line frame on
' the screen, using "text-graphics" characters from the
' IBM Extended ASCII character set. (change chr$ for single lines)
' --- Draw the four corners.
' use chr$ 218, 191, 192, 217 for corners of single line.
' use chr$ 201, 187, 200, 188 for corners of double line.
LOCATE top, left: PRINT CHR$(201)
LOCATE top, right: PRINT CHR$(187)
LOCATE bottom, left: PRINT CHR$(200)
LOCATE bottom, right: PRINT CHR$(188)
' --- Draw the vertical lines
' use chr$ 179 for single line.
' use chr$ 186 for double line.
FOR vert = top + 1 TO bottom - 1
LOCATE vert, left: PRINT CHR$(186);
LOCATE vert, right: PRINT CHR$(186);
NEXT vert
' --- Draw the horizontal lines.
' use chr$ 196 for single line.
' use chr$ 205 for double line.
horiz = right - left - 1
hline$ = STRING$(horiz, 205)
LOCATE top, left + 1: PRINT hline$
LOCATE bottom, left + 1: PRINT hline$;
END SUB
DEFSNG A-Z
FUNCTION Getletter$ (Prompt$, legal$)
' The getLetter function elicits a single letter response that must
' correspond to a letter that is included in the parameter Legal.
' These letters (in Legal) should be upper case.
' This function is called from the lineInput, Menu2, & pan5X5 sub-routines.
PRINT Prompt$; " -> ";
' --- Get the response. A beep indicates an invalid response.
DO
ans$ = UCASE$(INKEY$)
ansPos = INSTR(legal$, ans$)
IF ansPos = 0 THEN BEEP
LOOP UNTIL ans$ <> "" AND ansPos <> 0
PRINT ans$
Getletter$ = ans$
END FUNCTION
DEFINT A-Z
SUB lineImput
' --- this subprogram handles the input of a new magic square by asking for the numbers
' 1 at a time. If you make an error (like getting out of step), it can be edited
' later (from the main menu).
' This routine is called from the main program.
CLS
titleOne ' print the main title
PRINT
PRINT "This program demonstrates the use of generalized subroutines that perform"
PRINT "the required function for any order Magic Square. These routines may be"
PRINT "used in any Quickbasic program by 'merging'. "
PRINT "This program is a practical program for testing order 3 to 9 magic squares."
PRINT "Screen space (only) limits this demo to a maximum of order 9 magic squares."
PRINT
size$ = Getletter$("Enter length of line (order of square) 3-9 ", "3,4,5,6,7,8,9")
size = VAL(size$) ' size = order of m.s.
PRINT : PRINT "Enter the integers for the square, 1 at a time. If an error is made, "
PRINT "it may be corrected later by using 'edit' from the main menu."
PRINT "The constant will be determined by the sum of the cells in the first row."
endroutine = false ' be sure flag is clear
FOR r = 1 TO size
firstrowSum = 0
FOR c = 1 TO size
LOCATE 20, 5: PRINT "Number for row "; r; "col "; c; "is "; : INPUT n
firstrowSum = firstrowSum + n
origSqr(r, c) = n
LOCATE 20, 5: PRINT " "
NEXT c
IF r = 1 THEN
sum = firstrowSum
LOCATE 20, 5: PRINT "The magic constant is **"; sum; "** "; :
proceed$ = Getletter$("Is this correct (Y/N) ?", "Y,N")
IF proceed$ = "N" THEN EXIT SUB 'go back to main menu
LOCATE 20, 5: PRINT " "
END IF
ON KEY(2) GOSUB keyevent
KEY(2) ON
LOCATE 30, 1
PRINT "F2, then spacebar to exit"; ' provision for exiting this routine
Pause
IF endroutine THEN CLS : EXIT SUB ' leave orderly
LOCATE 30, 1: PRINT " ";
NEXT r
END SUB
SUB Loubere
sum = 0 ' set magic constant to 0
CLS
PRINT "De La Loubere Method of Magic Square Generation"
PRINT : PRINT "This is the most popular and widely known method of odd order m.s. generation"
LOCATE 4, 1
choice$ = Getletter$("Enter the size of the desired magic Square (3,5,7,or 9 please)", "3,5,7,9")
size = VAL(choice$)
IF size = 9 THEN ClearText ' clear bottom line of text for large square
FOR i = 1 TO size ' clear the magic square array
FOR j = 1 TO size
origSqr(i, j) = 0
k = k + 1
NEXT j
NEXT i
showSqr
Pause
r = 1: c = INT(size / 2) + 1: count = 1
origSqr(r, c) = count
showSqr
Pause
count = 2
DO
r = r - 1
IF r < 1 AND c = size THEN
r = r + 2: c = c - 1
END IF
IF r < 1 THEN r = size' c = c - 1 ' out of bounds
c = c + 1
IF c > size THEN c = 1 ' out of bounds
IF origSqr(r, c) > 0 THEN r = r + 2: c = c - 1 ' rest of diagonal filled
origSqr(r, c) = count
showSqr
Pause
count = count + 1
LOOP UNTIL count > size * size
END SUB
SUB LoubereM
CLS
PRINT "Modified De La Loubere Method of Magic Square Generation"
PRINT "Does starting at a different cell produce a magic square?"
sum = 0 ' set magic constant to 0
DO
LOCATE 4, 1
choice$ = Getletter$("Enter the size of the desired magic Square (3,5,7,or 9 please)", "3,5,7,9")
size = VAL(choice$)
choice$ = Getletter$("Enter the row of the starting cell", "1,2,3,4,5,6,7,8,9")
r = VAL(choice$)
choice$ = Getletter$("Enter the column of the starting cell", "1,2,3,4,5,6,7,8,9")
c = VAL(choice$)
IF r = 1 AND c = (size + 1) / 2 THEN
PRINT "Starting with this Cell uses the regular Loubere method"
choice$ = Getletter$("Proceed anyway Y/N ?", "Y,N")
IF choice$ = "Y" THEN
ClearText
LOCATE 3, 1: PRINT "This is the regular Loubere method"
EXIT DO
ELSE
ClearText
END IF
ELSE
ClearText
EXIT DO ' this is not a regular Loubere so proceed
END IF
LOOP
FOR i = 1 TO size ' clear the magic square array
FOR j = 1 TO size
origSqr(i, j) = 0
k = k + 1
NEXT j
NEXT i
showSqr ' empty at this point
Pause
count = 1
origSqr(r, c) = count
showSqr ' first number only here
Pause
count = 2
DO
r = r - 1
IF r < 1 THEN r = size ' out of bounds
c = c + 1
IF c > size THEN c = 1 ' out of bounds
IF origSqr(r, c) > 0 THEN r = r + 2: c = c - 1 ' rest of diagonal filled
IF c < 1 THEN c = size
IF r > size THEN r = r - size
origSqr(r, c) = count
showSqr ' show m.s. after each number is
Pause ' added to it, and pause to view
count = count + 1
LOOP UNTIL count > size * size
END SUB
SUB magicLines
'graph7.bas 4-19-94 Magic Lines
' --- draw a square based on size of array ---
' ---following lines maintains almost constant size regardless of order, and positions square
' so diagram is centered. 100 & 200 indicates position of top left corner (approximate)
cell = INT(91 / size) ' variable is 22,18,15,13,11,10
lineSize = cell * size ' then draw the square
LINE (2 + cell, 90 + cell)-(2 + cell + lineSize, 90 + cell + lineSize), , B
LOCATE 14, 3: PRINT "Magic Lines"
' ---locate position of consecutive numbers in the array ---
FOR i = 1 TO size * size 'step through consecutive numbers
startover = o ' flag
FOR r = 1 TO size 'step through position in string
FOR c = 1 TO size
IF origSqr(r, c) = i THEN ' find position of each number
startover = 1
IF origSqr(r, c) = 1 THEN 'this is the start of the pattern
starth = (2 + cell / 2) + cell * c
startv = (90 + cell / 2) + cell * r
oldh = starth: oldv = startv
END IF
IF origSqr(r, c) > 1 THEN
newh = (2 + INT(cell / 2)) + cell * c
newv = (90 + INT(cell / 2)) + cell * r
LINE (newh, newv)-(oldh, oldv)
oldh = newh: oldv = newv
IF origSqr(r, c) = size * size THEN ' this is the end of the pattern
LINE (starth, startv)-(newh, newv) 'close pattern
END IF
END IF
END IF
NEXT c
IF startover = 1 THEN EXIT FOR
NEXT r
NEXT i
' --- start of routine to show associated pairs ---
cornerh = 2 + cell: cornerv = 235 + cell ' constants for origin
LINE (cornerh, cornerv)-(2 + cell + lineSize, 235 + cell + lineSize), , B' draw the square
LOCATE 23, 3: PRINT "Assoc. Pairs"
number = 1 ' 2nd half of m.s. range indicater
abort = 0 ' flag for ginerating module
DO WHILE number <= size * size / 2
FOR r = 1 TO size 'find location for start of line
FOR c = 1 TO size
IF origSqr(r, c) = 0 THEN abort = 1 ' needed while generating a m.s.
'STOP
IF origSqr(r, c) = number THEN
startliner = r: startlinec = c
EXIT FOR
END IF
NEXT c
NEXT r
FOR r = 1 TO size 'find location for end of line
FOR c = 1 TO size
IF origSqr(r, c) = size * size + 1 - number THEN
endliner = r: endlinec = c
EXIT FOR
END IF
NEXT c
NEXT r
IF number > size THEN ' move line over 2 pixals
starth = cornerh + cell * startlinec - cell / 2 + 2 ' so two don't overlap
startv = cornerv + cell * startliner - cell / 2 + 2
endh = cornerh + cell * endlinec - cell / 2 + 2
endv = cornerv + cell * endliner - cell / 2 + 2
ELSE
starth = cornerh + cell * startlinec - cell / 2
startv = cornerv + cell * startliner - cell / 2
endh = cornerh + cell * endlinec - cell / 2
endv = cornerv + cell * endliner - cell / 2
END IF
IF abort = 0 THEN LINE (starth, startv)-(endh, endv) ' draw line if no value 0
number = number + 1
LOOP
END SUB
SUB MatRotate
' This subroutine copies A into B but rotated 90 degrees right.
' This cuts coding in half for OrthoSum, DiagSum, SemiPanSum, and AssocSum
' by calling these routines twice; once with origSqr() for 1 direction
' & once with rotateSqr() for the other direction.
' It is called from the displaySqr sub routine.
r = 0
DO
r = r + 1
FOR c = 1 TO size
cc = size + 1 - r ' new col is old row
rotateSqr(c, cc) = origSqr(r, c) ' new row is old column in reverse
NEXT c
LOOP WHILE r < size
END SUB
FUNCTION menu (choices$()) STATIC
' The Menu function displays a menu on the screen and elicits a menu
' choice from the user. Menu receives a string array (choices$)
' containing the manu choices and returns an integer indicating the
' users selection from among those choices.
' It is called from the main routine.
listLength = UBOUND(choices$)
DisplayMenuBox choices$(), leftMargin, promptStr$, okStr$
' --- Get a menu choice. Validate and verify the choice.
controlKeys$ = CHR$(13) + CHR$(27)
DO
LOCATE , , 1
charPos = 0
DO
answer$ = UCASE$(INKEY$)
IF answer$ <> "" THEN
charPos = INSTR(okStr$, answer$)
IF charPos = 0 THEN BEEP
END IF
LOOP UNTIL charPos > 0
PRINT answer$
LOCATE 11 + listLength, 23, 0
PRINT " to confirm; to redo."
inChoice = charPos
charPos = 0
DO
answer$ = INKEY$
IF answer$ <> "" THEN
charPos = INSTR(controlKeys$, answer$)
IF charPos = 0 THEN BEEP
END IF
LOOP UNTIL charPos > 0
IF charPos = 1 THEN
done = true
CLS
ELSE
done = false
LOCATE 11 + listLength, 23: PRINT SPACE$(35)
LOCATE 9 + listLength, leftMargin + 3 + LEN(promptStr$), 1: PRINT " ";
LOCATE , POS(0) - 1
END IF
LOOP UNTIL done
menu = inChoice
END FUNCTION
SUB menu2 (storedSqrs())
' --- Selects the required stored magic cell.
' Return with selected m.s. in origSqr & the order size in size.
' It is called from the main routine.
' --- Clear the screen & display the menu.
CLS
LOCATE 2, 30: PRINT " Stored Magic Squares "
PRINT TAB(11); "All are Normal - consequetive #'s starting with 1 (except l)"
LOCATE 5, 10: PRINT "Order 4"
LOCATE 6, 10: PRINT "a.- Simple magic Square b.- SemiPandiagonal m. Square"
LOCATE 7, 10: PRINT "c.- SemiPandiagonal Associative d.- Pandiagonal magic square"
LOCATE 8, 10: PRINT "Order 5"
LOCATE 9, 10: PRINT "e.- SemiPandiagonal Associative f.- Lozenge-even #'s in corners"
LOCATE 10, 10: PRINT "g.- Simple M. S. - bordered h.- Pandiagonal - Associated"
LOCATE 11, 10: PRINT "Order 6"
LOCATE 12, 10: PRINT "i.- Simple M. S. - bordered j.- SemiPandiagonal m. Square"
LOCATE 13, 10: PRINT "k.- Simple M. S. - no 6x6 assoc l.- Pandiagonal (but not normal"
LOCATE 14, 10: PRINT "Order 7"
LOCATE 15, 10: PRINT "m.- Simple M. S. - bordered n.- SemiPan Assoc.- Lozenge"
LOCATE 16, 10: PRINT "o.- SemiPandiagonal Associative p.- Pandiagonal magic square"
LOCATE 17, 10: PRINT "Order 8"
LOCATE 18, 10: PRINT "q.- Simple M. S. - bordered r.- SemiPandiagonal m. Square"
LOCATE 19, 10: PRINT "s.- SemiPandiagonal Associative t.- Pandiagonal Associated m.s."
LOCATE 20, 10: PRINT "Order 9"
LOCATE 21, 10: PRINT "u.- Simple M. S. - bordered v.- SemiPan. Assoc. - lozenge"
LOCATE 22, 10: PRINT "w.- SemiPan. Assoc. - Composite x.- Semipan - no Pandiagonal 9x9"
frame 7, 75, 1, 23 ' draw the frame
LOCATE 24, 25:
choice$ = Getletter$("Enter the appropriate letter", "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z")
choice$ = UCASE$(choice$)
SELECT CASE choice$
CASE "A"
k = 1: size = 4: sum = 34 ' k is starting position in storedSqrs array
CASE "B"
k = 17: size = 4: sum = 34
CASE "C"
k = 33: size = 4: sum = 34
CASE "D"
k = 49: size = 4: sum = 34
CASE "E"
k = 65: size = 5: sum = 65 ' order 5
CASE "F"
k = 90: size = 5: sum = 65
CASE "G"
k = 115: size = 5: sum = 65
CASE "H"
k = 140: size = 5: sum = 65
CASE "I" ' order 6
k = 165: size = 6: sum = 111
CASE "J"
k = 201: size = 6: sum = 111
CASE "K" ' the 9 2x2 subsquares are each in numerical
k = 237: size = 6: sum = 111 ' order & sums form a 3x3 m.s.
CASE "L"
k = 273: size = 6: sum = 150 ' not a normal m.s. (also 4 & 9 ply)
CASE "M" ' order 7
k = 309: size = 7: sum = 175
CASE "N"
k = 358: size = 7: sum = 175
CASE "O"
k = 407: size = 7: sum = 175
CASE "P"
k = 456: size = 7: sum = 175
CASE "Q" ' order 8
k = 505: size = 8: sum = 260
CASE "R"
k = 569: size = 8: sum = 260
CASE "S"
k = 633: size = 8: sum = 260
CASE "T"
k = 697: size = 8: sum = 260
CASE "U" ' order 9
k = 761: size = 9: sum = 369
CASE "V"
k = 842: size = 9: sum = 369
CASE "W" ' Composite - 9 3x3 squares are also
k = 923: size = 9: sum = 369 ' magic & arranged as a 3x3 magic square
CASE "X" ' Overlap - 2 4x4 upper left & lower right
k = 1004: size = 9: sum = 369 ' 2 5x5 upper right & lower left. All Pandiag
CASE ELSE
ON ERROR GOTO 0 ' Oops, invalid key pressed
END SELECT
' --- k = starting position of required m.s. .. size = order .. sum = constant
' --- All the magic squares are stored in 1 long string.
' The starting position for each m.s. is:
' order 4; 1, 17, 33, 49 order 5; 65, 90, 115,140
' order 6; 165,201,237,273 order 7; 309,358,407,456
' order 8; 505,569,633,697 order 9; 761,842,923,1004
FOR i = 1 TO size ' Enter the selected magic square into origSqr()
FOR j = 1 TO size
origSqr(i, j) = storedSqrs(k)
k = k + 1
NEXT j
NEXT i
END SUB
SUB menu3
CLS
' --- Selects the required method of generating a pure magic square.
' Return with generated m.s. in origSqr & the order size in size.
' It is called from the main routine.
' --- Clear the screen & display the menu.
CLS
LOCATE 2, 20: PRINT " Generate Magic Squares by Different Methods "
PRINT TAB(12); "All are Normal - i.e. use consecutive #'s starting with 1 "
LOCATE 5, 10: PRINT "Odd Order"
LOCATE 6, 10: PRINT "a.-De La Loubere method b.- Modified De La Loubere"
LOCATE 7, 10: PRINT "c.- d.- "
LOCATE 8, 10: PRINT
LOCATE 9, 10: PRINT "e.- f.- "
LOCATE 10, 10: PRINT "g.- h.-"
LOCATE 12, 10: PRINT "Even Order "
LOCATE 13, 10: PRINT "i.- j.- "
LOCATE 14, 10: PRINT "k.- l.- "
LOCATE 15, 10: PRINT
LOCATE 16, 10: PRINT "m.- n.- "
LOCATE 17, 10: PRINT "o.- q.- Return to main menu"
frame 7, 75, 1, 21 ' draw the frame
LOCATE 19, 25:
choice$ = Getletter$("Enter the appropriate letter", "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,Q")
choice$ = UCASE$(choice$)
SELECT CASE choice$
CASE "A"
Loubere ' goto the De La Loubere method
CASE "B"
LoubereM ' go to the modified De La Loubere
CASE "C"
EXIT SUB
CASE "D"
EXIT SUB
CASE "E"
EXIT SUB
CASE "F"
EXIT SUB
CASE "G"
EXIT SUB
CASE "H"
EXIT SUB
CASE "I"
EXIT SUB
CASE "J"
EXIT SUB
CASE "K"
EXIT SUB
CASE "L"
EXIT SUB
CASE "M"
EXIT SUB
CASE "N"
EXIT SUB
CASE "O"
EXIT SUB
CASE "Q"
EXIT SUB ' return to main menu
CASE ELSE
ON ERROR GOTO 0 ' Oops, invalid key pressed
END SELECT
END SUB
SUB OrthoSum (matrixA())
' sub OrthoSum calculates & checks the row sums (call 1),& column sums (call 2)
' it is called form displaySqr sub-routine
sumCorrect = 0 ' reset count of correct sums
FOR i = 1 TO size
testSum = 0 ' reset for new row or column
FOR j = 1 TO size
testSum = testSum + matrixA(i, j)
NEXT j
IF testSum = sum THEN ' if sum is correct then
sumCorrect = sumCorrect + 1 ' increment flag
END IF
NEXT i
END SUB
SUB pan5x5 (matrixA(), pTbl(), pairnum())
' adapted from PAN5X5M4.BAS
' This program will generate the 36 essentially different 5 x 5 pandiagonal
' magic squares.
' There are 99 additional magic squares that are cyclic permutations of each
' of these, for a total of 3600 different 5 x 5 pandiagonal magic squares.
' Of course each of these has 7 variations because of rotations and/or
' reflections. (i.e. 'camoflaged' or 'disguised' copies).
' This program relies heavily on information in chapter 19 of 'New
' Recreations in Magic Squares' by Benson & Jacoby, Dover Publ. 1976.
' In retrospect, it would have been simpler, and taken less memory to simply list
' the integers of the 36 magic squares.
' It is called from the main routine.
DIM bSqr1(5, 5) ' base square 1
DIM bSqr2(5, 5) ' base square 2
Title1$ = "Calculate & Display all 36 Essentially Different Order 5 Pandiagional Magic Sqrs"
a = 0: B = 5: v = 1: w = 2 ' these four variables are fixed
size = 5
snum = 1 ' start @ 1st square in the sequence
CLS
PRINT Title1$
PRINT : PRINT "Each of these 36 magic squares have 99 variations (plus the 3 reflections & 4"
PRINT "rotations), for a total of 3600 pandiagonal magic squares of order five."
PRINT " There are 0 order 3, 6, & 9; 48 order 4; 678,222,720 order 7; ? order 8"
'VIEW PRINT 5 TO 23
Report$ = Getletter$("Print a listing of Magic Squares (Y/N)", "YN")
IF Report$ = "Y" THEN
PRINT : PRINT "Turn on the printer *** set it to 15 CPI ***"
OPEN "lpt1:" FOR OUTPUT AS #1
WIDTH "lpt1:", 110 ' set printer output for wider lines
Pause ' wait for user response
ON ERROR GOTO PrinterError ' set the error trap
END IF
IF Report$ = "Y" THEN ' print report heading
PRINT #1, "": PRINT #1, " *** List of ALL Basic Pandiagonal Magic Squares of Order 5 ***"
PRINT #1, "": PRINT #1, " Each of these 36 squares have 99 variations (plus the 3 rotations & 4 reflections),"
PRINT #1, " for a total of 3600 Pandiagonal Magic Squares of order 5."
PRINT #1, " There are 0 order 3, 48 order 4, 0 order 6, 678,222,720 order 7, ? order 8, & 0 order 9"
PRINT #1, "": PRINT #1, " No. row 1 row 2 row 3 row 4 row 5"
END IF
CLS
endroutine = false ' be sure flag is clear s
conSqr = 1 ' consequetive order of square
DO ' cycle through the 36 squares
CLS
frNum = pTbl(snum, 2) ' Frenicle number ???
bSqr = pTbl(snum, 3) ' basic square number (1 or 2)
c = pTbl(snum, 4): d = pTbl(snum, 5): e = pTbl(snum, 6)
qx = pTbl(snum, 7): Y = pTbl(snum, 8): z = pTbl(snum, 9)
' --- calculate values for cells .. this is basic square 1
bSqr1(1, 1) = a + v: bSqr1(1, 2) = B + w: bSqr1(1, 3) = c + qx
bSqr1(1, 4) = d + Y: bSqr1(1, 5) = e + z
bSqr1(2, 1) = c + Y: bSqr1(2, 2) = d + z: bSqr1(2, 3) = e + v
bSqr1(2, 4) = a + w: bSqr1(2, 5) = B + qx
bSqr1(3, 1) = e + w: bSqr1(3, 2) = a + qx: bSqr1(3, 3) = B + Y
bSqr1(3, 4) = c + z: bSqr1(3, 5) = d + v
bSqr1(4, 1) = B + z: bSqr1(4, 2) = c + v: bSqr1(4, 3) = d + w
bSqr1(4, 4) = e + qx: bSqr1(4, 5) = a + Y
bSqr1(5, 1) = d + qx: bSqr1(5, 2) = e + Y: bSqr1(5, 3) = a + z
bSqr1(5, 4) = B + v: bSqr1(5, 5) = c + w
' --- calculate values for cells .. this is basic square 2
bSqr2(1, 1) = a + v: bSqr2(1, 2) = B + w: bSqr2(1, 3) = c + qx
bSqr2(1, 4) = d + Y: bSqr2(1, 5) = e + z
bSqr2(2, 1) = d + qx: bSqr2(2, 2) = e + Y: bSqr2(2, 3) = a + z
bSqr2(2, 4) = B + v: bSqr2(2, 5) = c + w
bSqr2(3, 1) = B + z: bSqr2(3, 2) = c + v: bSqr2(3, 3) = d + w
bSqr2(3, 4) = e + qx: bSqr2(3, 5) = a + Y
bSqr2(4, 1) = e + w: bSqr2(4, 2) = a + qx: bSqr2(4, 3) = B + Y
bSqr2(4, 4) = c + z: bSqr2(4, 5) = d + v
bSqr2(5, 1) = c + Y: bSqr2(5, 2) = d + z: bSqr2(5, 3) = e + v
bSqr2(5, 4) = a + w: bSqr2(5, 5) = B + qx
IF bSqr = 1 THEN
FOR i = 1 TO 5 ' transfer values from
FOR j = 1 TO 5 ' basic square 1 to
origSqr(i, j) = bSqr1(i, j) ' the magic square
NEXT j
NEXT i
ELSE ' Or
FOR i = 1 TO 5 ' transfer values from
FOR j = 1 TO 5 ' basic square 2 to
origSqr(i, j) = bSqr2(i, j) ' the magic square
NEXT j
NEXT i
END IF
displaySqr pairnum() ' display m.s. & report
IF Report$ = "Y" THEN
PRINT #1, : PRINT #1, " "; ' set to condensed type first
PRINT #1, " ";
PRINT #1, USING "##"; frNum; : PRINT #1, " "; ' print a quick & dirty
FOR i = 1 TO 5 ' list of magic squares
FOR j = 1 TO 5 ' 1 m.s. per line
PRINT #1, USING "##"; origSqr(i, j); : PRINT #1, " ";
NEXT j
PRINT #1, " ";
NEXT i
END IF
ON KEY(2) GOSUB keyevent
KEY(2) ON
LOCATE 1, 1
PRINT Title1$
PRINT : PRINT "Each of these 36 magic squares have 99 variations (plus the 3 reflections & 4"
PRINT "rotations), for a total of 3600 pandiagonal magic squares of order five."
PRINT " There are 0 order 3, 6, & 9; 48 order 4; 678,222,720 order 7; ? order 8"
LOCATE 19, 20: PRINT "Frenicle Number:"; frNum
LOCATE 19, 45: PRINT "Basic square Number:"; bSqr
LOCATE 20, 20: PRINT "Consequetive number:"; conSqr: conSqr = conSqr + 1
LOCATE 21, 20: PRINT "See New Recreations With Magic Squares "
LOCATE 22, 23: PRINT "by Benson & Jacoby, page 137"
LOCATE 23, 20
PRINT "F2, then spacebar to exit"; ' provision for exiting this routine
Pause
IF endroutine THEN CLS : EXIT SUB ' leave orderly
snum = snum + 1
LOOP UNTIL snum > 36
'VIEW PRINT: CLS ' all 36 m.s. displayed !
END SUB
SUB Pause STATIC
' The pause sub-routine allows the operater to view the screen until
' ready to proceed. It puts a message on the lower center of the
' screen and waits for a key-press.
' It is called from the main program & pan5X5.
'COLOR 0, 4
LOCATE 30, 30: PRINT "Press any key to continue.";
'COLOR 7, 1
DO WHILE INKEY$ = ""
ON KEY(2) GOSUB keyevent
KEY(2) ON
LOOP
LOCATE 30, 30: PRINT " ";
END SUB
SUB SemiPanSum (matrixA())
' This subroutine tests the opposite short diagonals. If each pair sums correctly
' it indicates a semi pandiagonal magic square.
' It is only called if the square is NOT pandiagonal, and is called twice,
' once with the original square, and once with the rotated square, in order to
' test both pairs (2 directions).
' Tests all order magic squares for the correct constant of both opposite short
' diagonal pairs.
' Test for singly-even order, if desired, before calling this routine, because
' there are no semi-pandiagonal magic squares of this order.
' It is called form the displaySqr sub-routine.
sumCorrect = 0
halfSize = size \ 2 ' integer division
r = halfSize: c = 1
IF halfSize * 2 <> size THEN ' order is odd because halfSize
' took only integer value
DO
testSum = testSum + matrixA(r, c) ' add cells in 1st half of diagonal pair
r = r - 1: c = c + 1
LOOP WHILE r > 0
r = size
c = c + 1 ' move to column past center
DO ' add cells in 2nd half of diagonal pair
testSum = testSum + matrixA(r, c)
r = r - 1: c = c + 1
LOOP WHILE r > halfSize + 1 ' stop before center row
testSum = testSum + matrixA((size + 1) / 2, (size + 1) / 2) ' add value of center cell
IF testSum = sum THEN ' test for constant
sumCorrect = 1
END IF
ELSE ' square order is even
DO ' so use this routine
testSum = testSum + matrixA(r, c) ' 1st half of pair
r = r - 1: c = c + 1 ' no need to add center cell &
LOOP WHILE r > 0 ' c doesn't have to jump over center
r = size
DO
testSum = testSum + matrixA(r, c) ' 2nd half of pair
r = r - 1: c = c + 1
LOOP WHILE r > halfSize
IF testSum = sum THEN ' test for correct constant
sumCorrect = 1
END IF
END IF
END SUB
SUB showSqr
' --- sub showSqr prints the matrix to the screen
' This is a general purpose subprogram that handles any order of m.s.
' It is called form the main program & also from displaySqr sub-routine.
' --- calculate frame parameters and call it
halfSize = size \ 2
top = 13 - size: bottom = top + size * 2 ' determine location & size of display
left = 39 - halfSize * 6: right = left + size * 6
frame left, right, top, bottom ' and call frame s.r.
FOR row = top + 2 TO bottom - 2 STEP 2 ' draw mid horizontal lines
FOR col = left + 1 TO right - 1
LOCATE row, col
PRINT CHR$(196)
NEXT col, row
firstVert = left + 6: lastVert = right - 6 ' location of 1st & last vertical lines
FOR col = firstVert TO lastVert STEP 6 ' draw mid vertical lines
FOR row = top + 1 TO bottom - 1
LOCATE row, col
PRINT CHR$(179)
NEXT row, col
FOR i = 1 TO size ' print the cell contents
FOR j = 1 TO size
row = top + 2 * i - 1
col = left + 6 * j - 4
LOCATE row, col
PRINT USING "###"; origSqr(i, j)
NEXT j, i
IF nograph = 0 THEN magicLines
END SUB
SUB sqrInput
' This routine allows input directly to the cells of the square.
' Best use is for changing a few cells to form a different m.s.
' Called by the main program.
' --- Values for keys on the curser keys and the spacebar:
CONST UP = 72, DOWN = 80, rightArrow = 77, SPACE = " "
halfSize = size \ 2 ' these 3 rows exactly the same
top = 11 - size: bottom = top + size * 2 ' as showSqr
left = 39 - halfSize * 6: right = left + size * 6 ' determine location & size of display
' --- Null$ is the first character of the two-character INKEY$
' value returned for direction keys such as UP and DOWN:
Null$ = CHR$(0)
LOCATE 1, 27: PRINT "Edit or Input a Magic Square"
LOCATE 21, 26: PRINT "Press 'q' to exit this module"
LOCATE 22, 5: PRINT "You MUST enter 3 digits for each cell (i.e. 001 for 1; or space,space,1)"
LOCATE 23, 5: PRINT "Correct errors by going to the right, up, or down until back at the cell"
LOCATE 24, 4: PRINT "Numbers (not digits) you pass over with the arrow keys will not be changed";
r = top + 3: c = left + 2: i = 1: j = 1
B$ = "": a$ = ""
DO
SELECT CASE keyVal$
CASE Null$ + CHR$(UP) ' move up to next row
r = r - 2: i = i - 1
IF r < top + 1 THEN ' if at top, go to bottom
r = bottom - 1: i = size
END IF
CASE Null$ + CHR$(DOWN) ' move down to next row
r = r + 2: i = i + 1
IF r > bottom - 1 THEN ' if at bottom, go to top
r = top + 1: i = 1
END IF
CASE Null$ + CHR$(rightArrow) ' move to next digit position
c = c + 1
IF c > right - 2 THEN ' go back to the start of the row
c = left + 2: j = 1
END IF
CASE SPACE ' enter key values
c = c + 1: a$ = " ": PRINT " ";
CASE "1"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "1"
CASE "2"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "2"
CASE "3"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "3"
CASE "4"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "4"
CASE "5"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "5"
CASE "6"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "6"
CASE "7"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "7"
CASE "8"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "8"
CASE "9"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "9"
CASE "0"
LOCATE r, c: PRINT keyVal$
c = c + 1: a$ = "0"
CASE ELSE ' The user pressed some key other than one of the direction
' keys, or the number keys, so don't do anything.
END SELECT
LOCATE r, c, 1 ' make curser visible
keyVal$ = UCASE$(INKEY$)
IF c MOD 6 = 2 THEN ' skip to next cell
c = c + 3: j = j + 1
END IF
IF LEN(B$) < 3 AND LEN(a$) > 0 THEN ' add digits to the number
B$ = B$ + a$: a$ = "" ' until there are 3 digits
END IF
IF LEN(B$) = 3 THEN
num = VAL(B$)
B$ = ""
IF num = 0 THEN ' keep original number
origSqr(i, j) = origSqr(i, j)
ELSE ' save new number
origSqr(i, j - 1) = num
IF c > right - 2 THEN ' you are at the end of the row
c = left + 2: j = 1 ' go back to the start
END IF
END IF
END IF
LOOP UNTIL keyVal$ = "Q" ' exit this routine
sum = 0 ' recalculate the constant
FOR c = 1 TO size
sum = sum + origSqr(1, c) ' sum cells of top row
NEXT c
END SUB
SUB titleOne
' --- This sub-routine prints the main title when required.
' It is called from various routines
PRINT "MAGICSQR.BAS --- Tests & demonstrates MAGIC SQUARES & use of general order S.R. "
END SUB
(
geocities.com/harveyhd)