1 REM Ins{nd av Gunnar Tidner <1306>    1987-04-09 08.52.00 (KERMIT)
2 ! **********************************************
3 ! *                                            *
4 ! *       SAMK\P                               *
5 ! *                                            *
6 ! *       Version  2.0  1987-01-16             *
7 ! *                                            *
8 ! *       av Gunnar Tidner                     *
9 ! *                                            *
10 ! **********************************************
11 ! Program f|r samk|pbest{llning av exempelvis
12 ! fotografier som deltagare i gruppresa vill
13 ! utbyta med varandra. De individuella |nskem}len
14 ! lagras i filen OBJEKT.DAT enligt f|ljande syntax:
15 ! Namn,objekt,objekt,objekt,objekt,objekt etc
16 ! d{r varje 'objekt' givits en unik beteckning
17 ! t ex {garens signatur f|ljt av ett l|pnummer
18 ! som {garen satt p} sina bilder.
19 ! ----------------------------------------------
20 ! Infofilen SAMK\P.INF inkopierad 19870604 B Sandgren <2776>
21 ! F|r vidare information om programmet SAMK\P se artikeln
22 ! i ABC-bladet 1987:1 sid 30-32.
23 ! Programmet {r detsamma som finns listat p} sid 32 men med
24 ! den skillnaden att att }{| i variabelnamnen utbytts mot
25 ! aao f|r att programmet skall kunna k|ras {ven i BasicII/PC.
26 ! Gunnar Tidner <1306>
27 ! ----------------------------------------------
100 INTEGER : EXTEND 
110 ON ERROR GOTO 170
120 Z=FNInitiera
130 WHILE -1
140   INPUT LINE #1,Rad$ : Rad$=LEFT$(Rad$,LEN(Rad$)-2)
150   Z=FNBehandlarad
160 WEND 
170 IF ERRCODE<>34 THEN ; 'Fel nr' ERRCODE : STOP 
180 Z=FNAvsluta
190 END 
200 ! --------------------------------------------
1000 DEF FNInitiera
1010   OPEN 'OBJEKT.DAT' AS FILE 1
1020   DIM Rad$=160
1030   U=30 ! Max antal personer
1040   V=200 ! Max antal objekt
1050   N=40 ! Max antal f{lt i best{llningsrad
1060   Namnlangd=15 ! max antal tecken i namn
1070   Objektlangd=5 ! max antal tecken i objektbeteckning
1080   DIM Falt$(N)=Namnlangd ! F{lt i best{llningsrad
1090   DIM Namn$(U)=Namnlangd ! Namnvektor
1100   DIM Objekt$(V)=Objektlangd ! Objektvektor
1110   DIM V(U,V) ! Matris f|r registering av best{llningar
1120   DIM Namnsum(U),Objektsum(V)
1130   RETURN 0
1140 FNEND 
1150 ! ------------------------------------------
2000 DEF FNBehandlarad
2010   Sista=FNDelfalt(Rad$,',')
2020   Namn=FNLetanamn
2030   Z=FNBoka
2040   RETURN 0
2050 FNEND 
2060 ! ------------------------------------------
3000 DEF FNAvsluta
3010   CLOSE 1
3020   Z=FNSummera
3030   INPUT 'Matrisfil:'Utfil$
3040   IF LEN(Utfil$) THEN PREPARE Utfil$ AS FILE 1 : L=1
3050   ; #L,TAB(15);
3060   FOR I=1 TO Personer
3070     ; #L, USING '###' I;
3080   NEXT I 
3090   ; #L,''
3100   FOR J=1 TO Antalobjekt
3110     ; #L,Objekt$(J) TAB(15);
3120     FOR I=1 TO Personer
3130       ; #L, USING '###' V(I,J);
3140     NEXT I 
3150     ; #L, USING '####' Objektsum(J)
3160   NEXT J 
3170   INPUT 'Namnfil:'Utfil$
3180   IF LEN(Utfil$) THEN PREPARE Utfil$ AS FILE 2 : L=2
3190   FOR I=1 TO Personer
3200     ; #L,I TAB(5) Namn$(I) TAB(20) Namnsum(I)
3210   NEXT I 
3220   RETURN 0
3230 FNEND 
3240 ! ------------------------------------------
4000 DEF FNDelfalt(A$,B$) LOCAL M,P,Q
4010   Q=0
4020   FOR K=0 TO N
4030     Falt$(K)=''
4040   NEXT K 
4050   FOR K=0 TO N
4060     P=INSTR(Q+1,A$,B$)
4070     IF P=0 THEN Falt$(K)=RIGHT$(A$,Q+1) : M=K : GOTO 4090 ELSE Falt$(K)=MID$(A$,Q+1,P-Q-1) : Q=P
4080   NEXT K 
4090   RETURN M
4100 FNEND 
4110 ! ------------------------------------------
5000 DEF FNLetanamn
5010   FOR I=1 TO Personer+1
5020     IF Namn$(I)=Falt$(0) THEN 5050
5030     IF Namn$(I)='' THEN Namn$(I)=Falt$(0) : Personer=Personer+1 : GOTO 5050
5040   NEXT I 
5050   RETURN I
5060 FNEND 
5070 ! ------------------------------------------
6000 DEF FNBoka
6010   FOR K=1 TO Sista
6020     Objekt=FNLetaobjekt
6030     V(Namn,Objekt)=V(Namn,Objekt)+1
6040   NEXT K 
6050   RETURN 0
6060 FNEND 
6070 ! ------------------------------------------
7000 DEF FNLetaobjekt
7010   FOR J=1 TO Antalobjekt+1
7020     IF Objekt$(J)=Falt$(K) THEN 7050
7030     IF Objekt$(J)='' THEN Objekt$(J)=Falt$(K) : Antalobjekt=Antalobjekt+1 : GOTO 7050
7040   NEXT J 
7050   RETURN J
7060 FNEND 
7070 ! ------------------------------------------
8000 DEF FNSummera
8010   FOR I=1 TO Personer
8020     FOR J=1 TO Antalobjekt
8030       Namnsum(I)=Namnsum(I)+V(I,J)
8040     NEXT J 
8050   NEXT I 
8060   FOR J=1 TO Antalobjekt
8070     FOR I=1 TO Personer
8080       Objektsum(J)=Objektsum(J)+V(I,J)
8090     NEXT I 
8100   NEXT J 
8110   RETURN 0
8120 FNEND