XProfan

' THE SQUARE ASSIGNMENT PROBLEM SOLVER
' in Profan-10
'{ DISCLAIMER     }
'  See https://en.wikipedia.org/wiki/Assignment_problem
'  and https://www.assignmentproblems.com/quadraticAP.htm
'  For Fortran-77 Code see https://www.netlib.org/toms/548
'  Translated to XProfan11.2a by P. Specht (F) 2011-02.
'  Prinziptest, möglicherweise nicht frei von Rechten Dritter!
'  Use solely on your own risk! Verwendung auf eigene Gefahr!
'}

PROC ASSGN

    '{ Parameters N&,A&[],C&[]
    Declare I&,J&,L&,K&,M&,NM&,LJ&,LM&,KSLC&,KSLR&
    Declare CH&[130],LC&[130],LR&[130],\
    LZ&[130],NZ&[130],RH&[131],SLC&[130],SLR&[130],U&[131]
    Declare H&,Q&,R&,S&,MAXNUM&,T&,NP1&
    'EQUIVALENCE [LZ&,RH&],[NZ&,CH&] 'Eigentlich Bereiche (Memory-shared)
    '}
    '{ REMARKS }
    ' This subroutine solves the Square Assignment Problem,
    ' full title: The square Agents Cost Per Task matrix solver
    '
    ' The meaning of the input parameters is
    ' n = number of rows and columns of the cost matrix,
    '     (current dimensions the maximum value of n is 130)
    ' a[i,j] = Element in row i and column j of the cost matrix
    '     (At the end of computation the elements of a are changed)
    ' Output parameters:
    '   c[j] = row assigned to column j  [j=1,n]
    '   t = cost of the optimal assignment
    ' ALL PARAMETERS ARE INTEGERS!
    '
    ' The meaning of the local variables:
    '  a[i,j] = element of the cost matrix
    ' case a[i,j] is positive:
    '  column of the unassigned zero following in row i [i=1,n]
    '  the unassigned zero of column j [j=1,n]
    ' case a[i,j] is not positive:
    '  a[i,n+1] = column of the first unassigned zero of row i [i=1,n]
    '  ch[i] = column of the next unexplored and unassigned zero
    '         of row i [i=1,n]
    ' lc[j] = label of column j [j=1,n]
    ' lr[i] = label of row i [i=1,n]
    ' lz[i] = column of the last unassigned zero of row i [i=1,n]
    ' nz[i] = column of the next unassigned zero of row i [i=1,n]
    ' rh[i] = unexplored row following the unexplored row i [i=1,n]
    ' rh[n+1]= first unexplored row
    ' slc[k] = k-th element contained in the set of the labelled columns
    ' slr[k] = k-th element contained in the set of the labelled rows
    ' u[i]   = unassigned row following the unassigned row i [i=1,n]
    ' u[n+1] = first unassigned row
    '
    ' The vectors c,ch,lc,lr,lz,nz,slc,slr must be dimensioned
    '   at least [n], the vectors rh and u at least at [n+1],
    '   the matrix a at least [n,n+1]
    '}
    '{ INITIALIZATION }
    MAXNUM&=2147483648' +/-, original: '10^14
    NP1&=N&+1

    WHILELOOP N&'10

        J&=&LOOP
        C&[J&]=0
        LZ&[J&]=0
        NZ&[J&]=0
        U&[J&]=0
        10:

    ENDWHILE

    U&[NP1&]=0
    T&=0
    '}
    '{ REDUCTION OF THE INITIAL COST MATRIX }

    WHILELOOP N&'40

        J&=&Loop
        S&=A&[1,J&]

        WHILELOOP 2,N&'20

            L&=&LOOP
            CASE A&[L&,J&]<S& : S&=A&[L&,J&]
            20:

        ENDWHILE

        T&=T&+S&

        WHILELOOP N&'30

            I&=&LOOP
            A&[I&,J&]=A&[I&,J&]-S&
            30:

        ENDWHILE

        40:

    ENDWHILE

    WHILELOOP N&'70

        I&=&LOOP
        Q&=A&[I&,1]

        WHILELOOP 2,N&'50

            L&=&LOOP
            CASE A&[I&,L&]<Q& : Q&=A&[I&,L&]
            50:

        ENDWHILE

        T&=T&+Q&
        L&=NP1&

        WHILELOOP N&' 60

            J&=&LOOP
            A&[I&,J&]=A&[I&,J&]-Q&
            CASE A&[I&,J&]<>0 : GOTO "60"'skip
            A&[I&,L&]=-J&
            L&=J&
            60:

        ENDWHILE

        70:

    ENDWHILE

    '}
    '{ CHOICE OF THE INITIAL SOLUTION }
    K&=NP1&

    WHILELOOP N&'140

        I&=&LOOP
        LJ&=NP1&
        J&=-A&[I&,NP1&]
        80:
        CASE C&[J&]=0 : GOTO "130"
        LJ&=J&
        J&=-A&[I&,J&]
        CASE J&<>0 : GOTO "80"
        LJ&=NP1&
        J&=-A&[I&,NP1&]
        90:
        R&=C&[J&]
        LM&=LZ&[R&]
        M&=NZ&[R&]
        100:
        CASE M&=0 : GOTO "110"
        CASE C&[M&]=0 : GOTO "120"
        LM&=M&
        M&=-A&[R&,M&]
        GOTO "100"
        110:
        LJ&=J&
        J&=-A&[I&,J&]
        CASE J&<>0 : GOTO "90"
        U&[K&]=I&
        K&=I&
        GOTO "140"
        120:
        NZ&[R&]=-A&[R&,M&]
        LZ&[R&]=J&
        A&[R&,LM&]=-J&
        A&[R&,J&]=A&[R&,M&]
        A&[R&,M&]=0
        C&[M&]=R&
        130:
        C&[J&]=I&
        A&[I&,LJ&]=A&[I&,J&]
        NZ&[I&]=-A&[I&,J&]
        LZ&[I&]=LJ&
        A&[I&,J&]=0
        140:

    ENDWHILE

    '}
    '{ SEARCH FOR A BETTER ASSIGNMENT }
    150:
    CASE U&[NP1&]=0 : RETURN

    WHILELOOP N&'160

        I&=&LOOP
        CH&[I&]=0
        LC&[I&]=0
        LR&[I&]=0
        RH&[I&]=0
        160:

    ENDWHILE

    RH&[NP1&]=-1
    KSLC&=0
    KSLR&=1
    R&=U&[NP1&]
    LR&[R&]=-1
    SLR&[1]=R&
    CASE A&[R&,NP1&]=0 : GOTO "220"
    170:
    L&=-A&[R&,NP1&]
    CASE A&[R&,L&]=0: GOTO "180"
    CASE RH&[R&]<>0 : GOTO "180"
    RH&[R&]=RH&[NP1&]
    CH&[R&]= -A&[R&,L&]
    RH&[NP1&]=R&
    180:
    CASE LC&[L&]=0 : GOTO "200"
    CASE RH&[R&]=0 : GOTO "210"
    190:
    L&=CH&[R&]
    CH&[R&]=-A&[R&,L&]
    CASE A&[R&,L&]<>0 : GOTO "180"
    RH&[NP1&]=RH&[R&]
    RH&[R&]=0
    GOTO "180"
    200:
    LC&[L&]=R&
    CASE C&[L&]=0 : GOTO "360"
    KSLC&=KSLC&+1
    SLC&[KSLC&]=L&
    R&=C&[L&]
    LR&[R&]=L&
    KSLR&=KSLR&+1
    SLR&[KSLR&]=R&
    CASE A&[R&,NP1&]<>0 : GOTO "170"
    210:

ENDWHILE

CASE RH&[NP1&]>0 : GOTO "350"
220:
' REDUCTION OF THE CURRENT COST MATRIX
H&=MAXNUM&

WHILELOOP N&'240

    J&=&LOOP
    CASE LC&[J&]<>0 : GOTO "240"

    WHILELOOP KSLR&'230

        K&=&LOOP
        I&=SLR&[K&]
        CASE A&[I&,J&]<H : H&=A&[I&,J&]
        230:

    ENDWHILE

    240:

ENDWHILE

T&=T&+H&

WHILELOOP N&'290

    J&=&LOOP
    CASE LC&[J&]<>0 : GOTO "290"

    WHILELOOP KSLR&'280

        K&=&LOOP
        I&=SLR&[K&]
        A&[I&,J&]=A&[I&,J&]-H&
        CASE A&[I&,J&]<>0 : GOTO "280"
        CASE RH&[I&]<>0 : GOTO "250"
        RH&[I&]=RH&[NP1&]
        CH&[I&]=J&
        RH&[NP1&]=I&
        250:
        L&=NP1&
        260:
        NL&=-A&[I&,L&]
        CASE NL&=0 : GOTO "270"
        L&=NL&
        GOTO "260"
        270:
        A&[I&,L&]=-J&
        280:

    ENDWHILE

    290:

ENDWHILE

CASE KSLC&=0 : GOTO "350"

WHILELOOP N&'340

    I&=&LOOP
    CASE LR&[I&]<>0 : GOTO "340"

    WHILELOOP KSLC&'330

        K&=&LOOP
        J&=SLC&[K&]
        CASE A&[I&,J&]>0 : GOTO "320"
        L&=NP1&
        300:
        NL&= -A&[I&,L&]
        CASE NL&=J& : GOTO "310"
        L&=NL&
        GOTO "300"
        310:
        A&[I&,L&]=A&[I&,J&]
        A&[I&,J&]=H&
        GOTO "330"
        320:
        A&[I&,J&]=A&[I&,J&]+H&
        330:

    ENDWHILE

    340:

ENDWHILE

350:
R&=RH&[NP1&]
GOTO "190"
360:
' ASSIGNMENT OF A NEW ROW
C&[L&]=R&
M&=NP1&
370:
NM&=-A&[R&,M&]
CASE NM&=L& : GOTO "380"
M&=NM&
GOTO "370"
380:
A&[R&,M&]=A&[R&,L&]
A&[R&,L&]=0
CASE LR&[R&]<0 : GOTO "390"
L&=LR&[R&]
A&[R&,L&]=A&[R&,NP1&]
A&[R&,NP1&]=-L&
R&=LC&[L&]
GOTO "360"
390:
U&[NP1&]=U&[R&]
U&[R&]=0
GOTO "150"
'}

EndProc

'{ MAIN PROGRAM   }
Declare n&,A&[130,131],C&[130],T&
WindowTitle "ASSGN - Kostenoptimale Aufgabenzuordnung (Ungetestete Pre-ALPHA Version)"
CLS rgb(200,200,200)
' There are a number of agents and a number of tasks. Any agent can be assigned
' to perform any task, incurring some cost that may vary depending on the
' agent-task assignment. It is required to perform all tasks by assigning exactly one
' agent to each task in such a way that the total cost of the assignment is minimized!
'}
'{ DATA SECTION   }
N&=5' 5 Personen sollen 5 Aufgaben zugeordnet werden.
' Deren Eignung sei z.B. defniert als [1:Sehr_gut - 5:Unzumutbar]
' Anm: Eine (n+1). Spalte ist für prozedurinterne Zwecke reserviert.
'Aufgabe1 :     2     :    3      :    4      :    5      '  Person:
A&[1,1]=2 : A&[1,2]=2 : A&[1,3]=3 : A&[1,4]=2 : A&[1,5]=1'    1
A&[2,1]=2 : A&[2,2]=2 : A&[2,3]=4 : A&[2,4]=1 : A&[2,5]=3'    2
A&[3,1]=2 : A&[3,2]=3 : A&[3,3]=5 : A&[3,4]=2 : A&[3,5]=3'    3
A&[4,1]=2 : A&[4,2]=4 : A&[4,3]=2 : A&[4,4]=1 : A&[4,5]=2'    4
A&[5,1]=2 : A&[5,2]=2 : A&[5,3]=2 : A&[5,4]=3 : A&[5,5]=5'    5
'}
'{ WORK SECTION   }
T&=ASSGN()
'}
'{ OUTPUT SECTION }
Print
Print " Kostenoptimales Ergebnis gemäß Angaben in der DATA Section des Programms:"
Print

Whileloop n&

print "   Der Aufgabe Nr.",&LOOP,"wird Person",c&[&LOOP],"zugeordnet! "

EndWhile

print
print " Kosten dieser Lösung: ",t&*n&,"Leistungseinheiten."
print " Leistungseinheiten je Mitarbeiter: ",t&
print
print
Print " Zum Beenden Taste/Maus drücken! "
'}
WAITINPUT
END -1