;=======================================================================* ; PROGRAMM: M I N D M A S T E R 2.0 TYP: Spielprogramm * ;=======================================================================* ; BESCHREIBUNG: Mastermind-Algorithmus mit Treiber fuer CP/M. * ; Das Programm spielt das als MasterMind oder Superhirn bekannte Spiel * ; gegen den Benutzer. Der Benutzer denkt sich eine Farbkombination aus, * ; das Programm versucht, diese durch Nachfragen herauszubekommen. * ; Der verwendete Algorithmus ist fast optimal: es wird - nach der * ; ersten Frage - jeweils eine weitere Frage errechnet, die unabhaengig * ; von ihrer Beanwortung moeglichst wenige Faelle uebriglaesst. * ; Jedoch werden zur Beschleunigung nur Fragen aus den noch vorhandenen * ; Moeglichkeiten gestellt - eine Bewertung aller moeglichen Fragen * ; koennte die Anzahl der noetigen Fragen weiter reduzieren. * ; Davon abgesehen wird immer das einschrittige Optimum ausgerechnet. * ; Es ist eine Zeitschranke eingebaut, die jedoch nur im Fall 5x7 und * ; nach der ersten Frage richtig wirksam wird und die Suche nach dem * ; Optimum begrenzt. Auf die Zahl der noetigen Antworten scheint das * ; aber keinen Einfluss zu haben. * ; Das Programm erlaubt Generierung fuer NASCOM mit und ohne IVC, * ; bis zu 7 Farben und bis zu 5 Plaetzen. * ; * ; (C) Wolfgang Strobl 1980, '82 V1.0 25.08.80 * ; V1.1 1.09.80 * ; Anpassung an CP/M V2.0 29.12.82 * ;-----------------------------------------------------------------------* ; Schwarz bedeutet: Farbe & Pos richtig. Weiss bedeutet: Farbe richtig * ; * ;-----------------------------------------------------------------------* ???nas set 0 ; NASCOM or IVC/GALAXY Version ???test set 0 ; Testswitch: prepare for Debugger .pla equ 5 ; 3..5 std: 5 Anzahl Plaetze max wegen compress .farb equ 7 ; 2..7 std: 7 Anzahl Farben " " " ; Siehe auch TTABLE. if ???test=1 .start equ 600h ; Zum leicheren Entwanzen auf .par equ 200h ; leicht merkbare Grenzen legen. .work equ 1000h ; Bei Assemblierfehler hochsetzen. endif org 100h ; Orig TPA if ???test=1 call .begin rst 38h else call .begin jp .boot ; Das wird z.Zt. aber nicht benutzt endif ;-----------------------------------------------* ; Daten und Parameterlisten * ;-----------------------------------------------* if ???test=1 org .par ; Datenbereich, als I: und O: (in/out) vom Standpunkt von 'mm' beschrieben else .par equ $ endif wstr db 1,2,3,4,5 ; erlaubt sogar 7 Plaetze rstr db 0,0,0,0,0 ; flag db 0 ; I: Erster Aufruf? .first equ 0 .next equ 1 anzpla db .pla ; I: Anzahl Plaetze cperg: cmpsw db 0 ; Parm mmu: Schwarz Pos + Farb cmpws db 0 ; Parm mmu: Weiss Farb pstr db 0,0,0,0,0 ; O: Neuer Vorschlag vstr db 0,0,0,0,0 ; I: Alte Frage aptr dw .work ; I: A(Workspace) alen dw 0 ; O: Len(Workspace used) bptr dw 0 max dw 0 ; O: Maximaler naechster Suchraum maxp dw 0 ; O: Zeiger auf maximales Element six dw 0 answ: ; I: Antwort vom Spieler anssw db 1 ; I: Schwarz answs db 0 ; I: Weiss versuch db 0 ; Anzahl Versuche bis jetzt nr dw 0 rcount dw 0 ; Zaehler zur Zeitbegrenzung rcountm dw 20000 ; " Maximum ds 32 ; own stack stack equ $ ;---------------------------------------------* ; Farben * ;---------------------------------------------* farben dw what ; Farbe 0 dw gelb ; 1 dw gruen ; 2 dw rot ; 3 dw blau ; 4 dw braun ; 5 dw lila ; 6 dw weiss ; 7 farben. equ $-farben what db ' ?',0 gelb db ' Gelb',0 gruen db ' Gruen',0 rot db ' Rot',0 blau db ' Blau',0 braun db ' Braun',0 lila db ' Lila',0 weiss db ' Weiss',0 ; moegliche Fragen: Anfang, mittendrin, Ende, Display msgfs db ' Ist es ',0 msgvm db 'Ich vermute ',0 msgfi db 'Es ist wohl ',0 msgsp db ' ',0 ;-----------------------------------------------* ; Farbenliste ausgeben. IX -> F1..Fn * ; modifies IX, AF * ;-----------------------------------------------* prfa: push hl push de push bc if ???nas=0 call prs db '(',0 endif ld b,.pla ; $for #(farben) prfal1 ld a,(ix) ; hole nummer der farbe inc ix ; naechste farbennummer adressieren add a,a ; farb#*2 als index ld hl,farben ; farbentabelle ld e,a ; de := farb#*2 ld d,0 add hl,de ; hl := a(farben+farb#*2) ld a,(hl) inc hl ld h,(hl) ld l,a ; hl := [hl] call prm ; Farbe ausgeben call space ; blank djnz prfal1 ; for$ if ???nas=0 call prs db ')',0 endif pop bc pop de pop hl ret ; Abbruchroutine break if ???test=1 rst 38h ; jump to debugger halt else jp .boot ; or reboot endif ; break search if BRKCHR has been typed BRKCHR equ ' ' ; printable! brkchk push af ; save accu call instat ; has char been typed? or a jr z,brkcn ; no: return call inchar ; yes: get 'm cp BRKCHR jr z,brkcb ; restart if BRKCHR typed brkcn pop af ret brkcb ld a,-1 ; make time count negative ld (rcount+1),a ; to break search loop call prs ; remove echoed break char db bs,0 ; pop af ret ; and continue ;-----------------------------------------------* ; M A I N L O O P * ;-----------------------------------------------* .begin ld sp,stack ld hl,flag ; Merken: erster Versuch ld (hl),.first call initmsg ; Beim Spieler anmelden call firsttry ; Erste Frage aussuchen call questf ; Erste Frage stellen qlop call display ; und Liste der Farben ausgeben call ask ; und nach Treffern fragen jp c,quest ; redisplay if necessary cmm call prs db ' ',0 call mm ; Suche guenstigste naechste Frage ld hl,flag ; Merken: schon mittendrin ld (hl),.next call stat ; Statistik ausgeben jr c,.begin ; Inkonsistenz gefunden? ja: neues Spiel jr z,single ; Nur noch eine Moeglichkeit? Ja: sagen ld hl,versuch ; Versuchszaehler hochzaehlen inc (hl) ld hl,pstr ; guenstigste Frage ld de,vstr ; stellen ld bc,.pla ldir quest call questn ; Fragetext ausgeben jr qlop single ld hl,msgfi ; jetzt wissen wir's genau call prm ; also anderen Fragetext call display ; ausgeben call crlf jr .begin ; und ein neues Spiel initmsg call prs if ???nas=1 db cr,lf,'**********************************************' db cr,lf,'* Mind Master 2.0 ';5x7 (C) Strobl 1982 *' db ' ',.pla+'0',' x ',.farb+'0',' (C) Strobl 1982 *' db cr,lf,'**********************************************' db cr,lf,0 else db cr,lf,'********************************************************************' db cr,lf,'* M i n d M a s t e r 2.0 ';5 x 7 (C) W. Strobl 1982 *' db ' ',.pla+'0',' x ',.farb+'0',' (C) W. Strobl 1982 *' db cr,lf,'********************************************************************' db cr,lf,lf,0 endif ret firsttry: ; Make Random First Question ld b,.pla ; init count ld hl,vstr ; destination ld a,r ; get random from refresh reg ld d,2 ; addr page 2 ld e,a ; random addr ftryl1 inc de ; next memory position ld a,(de) ; get 'random' from memory and 7 ; mask for 0..7 inc a ; 1..8 cp .farb+1 ; exclude .farb+1..8 jr nc,ftryl1 ; retry cp c jr z,ftryl1 ; exclude reptitions ld c,a ld (hl),a ; move to destination inc hl ; next position djnz ftryl1 ; and repeat ret questf ld hl,msgfs call prm ret questn ld hl,msgvm call prm ret display ld ix,vstr call prfa ret ask if ???nas=1 call prs db cr,lf,0 endif ask1 ld hl,msgsw call askb ret c ; return for redisplay ld (anssw),a cp .pla+1 jr c,ask2 call askbs4 jr ask1 ask2 ld hl,msgws call askb ld (answs),a ld b,a ld a,(anssw) add a,b cp .pla+1 jr c,ask3 call askbs4 call askbs4 jr ask1 ask3 or a ; ret with NC ret askbs4 call prs db bs,bs,bs,bs,0 ret msgsw db ' S-',0 msgws db ' W-',0 askb call prm call inchar cp CAN jr z,askbr cp '?' ; space display requested? jr z,askb2 jr asko askbr call crlf ; break requested call break ; bkpt jr askb ; try again if possible asko sub '0' ; make binary or a ; clear carry ret askb2 call showsp ; display current space scf ; request redisplay ret stat if ???nas=1 call crlf endif ld hl,(alen) srl h ; HL := HL/2 rr l ld (nr),hl ; nr := max/2 ld hl,(nr) call binword ld hl,(max) call binword call crlf ld hl,(nr) ld a,h or a ret nz ; return NZ if nr > 1 ld a,l or a jr z,empty ; inconsistent answers if nr=0 cp 1 ; return Z if nr = 1 ret empty call prs db 'Mindestens eine der Antworten stimmt nicht !' db cr,lf,0 scf ; return C if nr = 0 ret binword push hl ld ix,statau. ld b,$statau call binstr ld hl,statau call prm pop hl ret statau db '....' $statau equ $-statau statau. db 0 ; showsp push af call crlf ld ix,(aptr) showl1 ld a,(ix+0) or a jr z,showspe ld iy,showfa ld a,.expa call mmu push ix ld hl,msgsp call prm ld ix,showfa call prfa call crlf pop ix inc ix inc ix jr showl1 showspe pop af ret showfa ds 7 ;------------------------------------------------------------ if ???test=1 org .start endif mm: ld ix,(aptr) ld (six),ix ; generieren des ersten Array's genf ld hl,pstr ; PSTR := 1 1 1 1 1 ld b,.pla-1 il1 ld (hl),1 inc hl djnz il1 ld (hl),0 ld ix,(aptr) jr next ; gena ld de,wstr ld hl,pstr ld bc,.pla ldir ; wstr := pstr ld de,rstr ld hl,vstr ld bc,.pla ldir ; rstr := vstr ld hl,(answ) ; gegebene Antwort call testans ; ueberpruefen jr nz,next ; stimmt nicht ld iy,pstr ld a,.cmpr call mmu ; compress IX inc ix inc ix ; next position ; next call gnext ; pstr := pstr + 1/NEXT P. jr nc,gena ; loop generate Array ld (ix+0),0 ; mark end of Array push ix pop hl ld de,(aptr) or a sbc hl,de ld (alen),hl ld a,h or l ; war or a ??? jr nz,go1 ld a,l cp 1 jr z,ret jr c,ret go1 inc ix ld (bptr),ix ; free store jr overut1 ret ret gnext ld a,(flag) ; first call? or a jr z,gnx0 ; Array to be generated ld iy,pstr ld hl,(six) ld a,(hl) or a jr z,gnx3 ; END OF ARRAY push ix push hl ; IX:=HL pop ix ld a,.expa call mmu ; expand inc ix inc ix ld (six),ix ; next old array element pop ix jr gnx5 gnx0 ld b,.pla ld hl,pstr+.pla-1 gnx1 ld a,(hl) inc a cp .farb+1 jr nz,gnx2 ld a,1 ld (hl),a dec hl djnz gnx1 gnx3 scf ret gnx2 ld (hl),a gnx5 or a ret testans push de ld a,.verg call mmu ; compare ld de,(cperg) ; ergebnis compare or a sbc hl,de pop de ret ; INIT outer loop overut1 call prs db ' ',0 ; Show Activity ... ld hl,(rcountm) ; init time limit ld (rcount),hl ld ix,(aptr) ; first element ld hl,0ffffh ; biggest ld (max),hl ld (maxp),hl ; garbage ; $LOOP outer loop tsl1 equ $ ld hl,(bptr) dec hl ld de,(bptr) ld bc,.ttable*2+1 ldir ; clear freq. table ld iy,vstr ld a,.expa call mmu ; expand push ix ; INIT inner loop ld ix,(aptr) ; $LOOP inner loop tsl2 ld iy,wstr ld a,.expa call mmu ; expand push bc ld de,rstr ld hl,vstr ld bc,.pla ldir pop bc ld a,.verg call mmu ; COMPARE ld a,(cperg+1) ld b,a ld a,(cperg) rlca rlca rlca or b ld hl,ttable ; load address ld bc,.ttable cpir jp nz,interr ex de,hl ld hl,ttable ; load address or a ex de,hl sbc hl,de add hl,hl ex de,hl ld hl,(bptr) add hl,de push hl pop iy ; IY [BPTR].type ld d,(iy+1) ; count for this one ld e,(iy+0) inc de ; one more ld (iy+1),d ld (iy+0),e inc ix ; next Array element inc ix ld hl,(rcount) ; decr time count dec hl ld (rcount),hl ld a,(ix+0) ; end of Array? or a ; LOOP$ inner loop jr nz,tsl2 ; no. ;-----------------------------------------------* ; We have finished for this row. Now at [BPTR] * ; there is a table of sizes . For each possible * ; answer it contains the size of the set of * ; combinations giving that answer. Now search * ; its maixmal element's value. * ;-----------------------------------------------* ; INIT inner loop (search max) srm ld b,.ttable ; spaces ld de,0 ; current max ld ix,(bptr) ; first entry ; $LOOP inner loop spl1 ld h,(ix+1) ld l,(ix+0) or a sbc hl,de ; entry-oldmax jr c,spl1e ld h,(ix+1) ld l,(ix+0) ex de,hl ; new max spl1e inc ix inc ix djnz spl1 ; LOOP$ inner loop ; ; we now have the size of current space ; pop ix ; get outer element ld hl,(max) ; outer minimum or a ; clear carry sbc hl,de ; oldmin-entry jr c,nxto ; carry: bigger means garbage jr z,nxto ; same too ld (maxp),ix ; points to "lowest" element ld (max),de ; new min push ix push hl push de call askbs4 ; Show Activity ex de,hl call binword pop de pop hl pop ix nxto inc ix ; next outer element inc ix call brkchk ; allow break ld a,(rcount+1) ; early end? or a jp m,fguess ; yes if rcount negative ld a,(ix+0) ; was last one? or a ; LOOP$ outer loop jp nz,tsl1 ; no. ; fguess ld ix,(maxp) ; fetch best guess ld a,.expa ; expand ld iy,pstr call mmu call askbs4 ; Show Activity call askbs4 jp ret ; THAT WAS IT ! ;-----------------------------------------------* interr call prs db 'Internal Error',cr,lf,0 call break halt ;-----------------------------------------------* ttable: ; Teil 1 fuer bis zu 5 Plaetzen db 0*8+0,0*8+1,0*8+2,0*8+3,0*8+4,0*8+5 db 1*8+0,1*8+1,1*8+2,1*8+3,1*8+4 db 2*8+0,2*8+1,2*8+2,2*8+3 db 3*8+0,3*8+1,3*8+2 db 4*8+0,4*8+1 db 5*8+0 if .pla>5 ; Teil 2 fuer bis zu 7 Plaetzen db 0*8+6,1*8+5,2*8+4,3*8+3,4*8+2,5*8+1,6*8+0 db 0*8+7,1*8+6,2*8+5,3*8+4,4*8+3,5*8+2,6*8+1,7*8+0 endif .ttable equ $-ttable db 0 ;------------------------------------------------ ; ; mmutil/2.2 ;-2.2-------------------------------------* ; PRG: MMUTIL TYP: subr fuer mastermind ; {COMPARE EXPAND COMPRESS} ; Steuerparamter ; A .verg COMPARE ; .expa EXPAND ; .cmpr COMPRESS ; Beschreibung COMPARE: ; FUNKTION: teste zwei Farbkombinationen ; gegeneinander. Expandiere. ; INPUTPARAMETER: ; ANZPLA Byte Anzahl Plaetze ; WSTR String ; RSTR String ; ; OUTPUTPARAMETER: ; CMPSW Byte Anzahl richtig (schwarz) ; CMPWS Byte Anzahl Farb treff(weiss) ; ; BESCHREIBUNG: ; Die Strings bei RSTR und WSTR werden in ; der Laenge ANZPLA verglichen. Die Anzahl ; der uebereinstimmender Bytes wird in ; CMPSW notiert. Von den restlichen Bytes ; wird die Anzahl uebereinstimmender Werte ; in CMPWS notiert. ; 3.9. W. Strobl 22.8.80 ;-----------------------------------------* ; EQUATES .verg equ 0 ; call COMPARE .expa equ 1 ; call EXPAND .cmpr equ 2 ; call COMPRESS ;--------- programm --------------------* ; mmu: push af push bc push de push hl push ix cp .verg jr z,compare jr expand ; will test others compare ld a,(anzpla) ld b,a ; Anzahl Plaetze B ld c,0 ; Schwarz Count ld hl,rstr ld de,wstr cpl1 ld a,(de) cp (hl) jr nz,cpl1e xor a ; A:=0 ld (de),a ; clear both elements ld (hl),a ; to exclude them from inc c ; pass two; Count them. cpl1e inc de ; select next element's inc hl djnz cpl1 ; repeat black loop ld a,c ld (cmpsw),a ;---------------------------------------- ld a,(anzpla) ld e,a ld b,a ld d,0 ; white count ld hl,rstr cpl2 ld a,(hl) or a jr z,cpl2e ; missing Element push bc ; for inner loop ld b,e ; anz. plaetze ld ix,wstr cpl3 ld a,(ix+0) or a ; already used? jr z,cpl3e ; yes cp (hl) ; this two bytes eq? jr nz,cpl3e inc d ; yes: count them xor a ld (hl),a ; say: used ld (ix+0),a ; " cpl3e inc ix ; select next one djnz cpl3 pop bc cpl2e inc hl ; select next one djnz cpl2 ld a,d ld (cmpws),a ; PROC$ return pop ix pop hl pop de pop bc pop af ret ;----------------------------------------* ; EXPAND dekomprimiere 2 byte 5 byte * ; * ; 7 6 5 4 3 2 1 0 7 6 5 4 3 2 1 0 <-IX * ; \____/\____/\______/\____/\____/ * ; 1 2 3 4 5 <-IY * ;----------------------------------------* expand cp .expa jr nz,compres ; will test others ld a,(ix+0) ld b,a and 0e0h rlca rlca rlca ld (iy+0),a ; -1- ld a,b and 01ch rrca rrca ld (iy+1),a ; -2- ld a,b and 003h ld b,a ld a,(ix+1) ld c,a ; save it rlca ld a,b rla ld (iy+2),a ; -3- ld a,c and 070h rrca rrca rrca rrca ld (iy+3),a ; -4- ld a,c and 00eh rrca ld (iy+4),a ; -5- toretrn jr return ;----------------------------------------* ; COMPRESS * EXPAND = id * ;----------------------------------------* compres cp .cmpr jr nz,toretrn ; don't know ld a,(iy+0) ; -1- rrca rrca rrca and 0e0h ld b,a ld a,(iy+1) ; -2- rlca rlca and 01ch or b ld b,a ld a,(iy+2) ; -3- rrca and 003h or b ld (ix+0),a ; first compr byte ld a,(iy+2) ; again -3- rrca and 080h ld b,a ld a,(iy+3) ; -4- rlca rlca rlca rlca and 070h or b ld b,a ld a,(iy+4) ; -5- rlca and 00eh or b ld b,a ld (ix+1),a jr toretrn mmend equ $ mmlen equ mmend-mm .boot equ 0 ; SERVICE.ZAP Serviceroutinen 82-09-23/82-09-24 ;---------------------------------------------------------------- ; ; prs - print string constant ; ahex - print a hex ; hlhex - print hl hex ; hexbyte - print hex byte (a), space ; hexword - print hex word(hl), space ; space - print space ; crlf - print newline ; outchar - print char in a ; inchar - get char into a ; instat - check if char has been typed A=0 means no ; crtkbd - get char into a from crt (no wait) ; crtget - get char into a from crt (wait) ; crtput - put char in a to crt ; .svbdos equ 5 .svconin equ 1 .svconout equ 2 .svconst equ 11 .svdc equ 6 ; direct console i/o .svdcin equ 0ffh ; - input ; .svcr equ 0dh .svlf equ 0ah ; print string ; usage: call prs, string, 0 ; prs equ $ ex (sp),hl push af prsl ld a,(hl) inc hl ; output unless 0 or a jr z,prsr prs2 call outchar jr prsl prsr pop af ex (sp),hl dret ret ; ; prm Print Message HL -> Message, 0 ; prm equ $ prml ld a,(hl) inc hl or a ret z call outchar jr prml ; ; prt Print String HL -> string BC=len (0..2^16) ; prt push bc prtl ld a,b or c jr z,prtr ld a,(hl) call outchar inc hl dec bc jr prtl prtr pop bc ret if ???test=1 ; ; print [a] hex ; modified: af ; ahex equ $ b2hex push af rra rra rra rra call b1hex pop af ; output low half a b1hex and 0fh add a,'0' cp '9'+1 jr c,b1h4 add a,'a'-'0'-10 ; output char b1h4 call outchar ret ; hlhex equ $ ld a,h call ahex ld a,l call ahex ret endif ; space equ $ ld a,' ' call outchar ret if ???test=1 ; hexword equ $ push af call hlhex call space pop af ret ; hexbyte equ $ push af call ahex call space pop af ret endif ; crlf ld a,.svcr call outchar ld a,.svlf call outchar ret ; outchar equ $ push bc push de push hl ld e,a ld c,.svconout call .svbdos pop hl pop de pop bc ret ; inchar equ $ push bc push de push hl ld c,.svconin call .svbdos pop hl pop de pop bc ret ; instat equ $ push bc push de push hl ld c,.svconst call .svbdos pop hl pop de pop bc ret ; scan CRT Keybord, char into A, A=0 means no char available crtkbd equ $ push bc push de push hl ld c,.svdc ld e,.svdcin call .svbdos pop hl pop de pop bc ret ; get char from CRT into A crtget equ $ call crtkbd or a jr z,crtget ret ; output A to CRT crtput equ $ push bc push de push hl ld c,.svdc ld e,a call .svbdos pop hl pop de pop bc ret ; put char from A to IVC putvid push af pv0 in a,(0b2h) rrca jr c,pv0 pop af out (0b1h),a ret ;---------------------------------------------- ; div - 16-bit divide ; divides two 16-bit unsigned integers. ; No divide check (/0) is made! ; i: HL: divisor DE: dividend ; o: HL: result DE: remainder ;---------------------------------------------- div equ $ push bc xor a ld c,a ld b,a $divlp1 push hl sbc hl,de ccf pop hl jr nc,$divout sla e rl d inc b jr nc,$divlp1 $divout push af or b jr z,$divres pop af $divlp2 rr d rr e push hl sbc hl,de ccf jr nc,$divold ex (sp),hl $divold pop hl rla rl c djnz $divlp2 push af $divres pop af ex de,hl ld h,c ld l,a pop bc ret ; multiply HL with 10 ;mult10 z.Zt. nicht benutzt push de add hl,hl ; HL=HL*2 ex de,hl ; DE=IN*2 push de pop hl add hl,hl add hl,hl ; HL=IN*8 add hl,de ; HL=IN*8+IN*2 pop de ret ; ; Conversion BIN -> CHAR ; HL auszugebende Zahl IX Ende-Ausgabebereich B Anzahl Stellen ; binstr binstr1 ld de,10 call div ; ld a,e add a,'0' ld (ix-1),a ld a,d or e or h or l jr nz,binstr2 ld (ix-1),' ' binstr2 dec ix djnz binstr1 ret if 1=0 ; unused mark ld a,esc call outchar ld a,'A' call outchar ret unmark ld a,esc call outchar ld a,'N' call outchar ret endif ;-----------------------------------------------* cr equ 0dh lf equ 0ah bs equ 08h CAN equ 03h esc equ 1bh if ???test=1 org .work else .work equ $ endif end