$! ------------------ CUT HERE ----------------------- $ v='f$verify(f$trnlnm("SHARE_VERIFY"))' $! $! This archive created by VMS_SHARE Version 7.2-007 22-FEB-1990 $! On 30-MAY-1992 03:07:11.68 By user MASLIB $! $! This VMS_SHARE Written by: $! Andy Harper, Kings College London UK $! $! Acknowledgements to: $! James Gray - Original VMS_SHARE $! Michael Bednarek - Original Concept and implementation $! $!+ THIS PACKAGE DISTRIBUTED IN 2 PARTS, TO KEEP EACH PART $! BELOW 30 BLOCKS $! $! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER $! AND EXECUTE AS A COMMAND PROCEDURE ( @name ) $! $! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING: $! 1. BUILD.COM;1 $! 2. CONNECT4.PAS;1 $! 3. CONNECT4.PIC;1 $! $set="set" $set symbol/scope=(nolocal,noglobal) $f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID")) $e="write sys$error ""%UNPACK"", " $w="write sys$output ""%UNPACK"", " $ if f$trnlnm("SHARE_LOG") then $ w = "!" $ ve=f$getsyi("version") $ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START $ e "-E-OLDVER, Must run at least VMS 4.4" $ v=f$verify(v) $ exit 44 $UNPACK: SUBROUTINE ! P1=filename, P2=checksum $ if f$search(P1) .eqs. "" then $ goto file_absent $ e "-W-EXISTS, File ''P1' exists. Skipped." $ delete 'f'* $ exit $file_absent: $ if f$parse(P1) .nes. "" then $ goto dirok $ dn=f$parse(P1,,,"DIRECTORY") $ w "-I-CREDIR, Creating directory ''dn'." $ create/dir 'dn' $ if $status then $ goto dirok $ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped." $ delete 'f'* $ exit $dirok: $ w "-I-PROCESS, Processing file ''P1'." $ if .not. f$verify() then $ define/user sys$output nl: $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1' PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET( SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:= CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b)); LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION( BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1); IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE; MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1; ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")= 1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF"; POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r); ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1; COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE, "output_file"));ENDPROCEDURE;Unpacker;QUIT; $ delete/nolog 'f'* $ CHECKSUM 'P1' $ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT $ e "-E-CHKSMFAIL, Checksum of ''P1' failed." $ ENDSUBROUTINE $START: $ create 'f' X$ PASCAL CONNECT4 X$ LINK CONNECT4, INTERACT/LIB X$ DELETE *.OBJ;*/NOCONFIRM X$ EXIT $ CALL UNPACK BUILD.COM;1 486606478 $ create 'f' X`5B Inherit ('INTERACT') `5D X XPROGRAM Connect4; X XTYPE X also = (all,some); X v_array = varying `5B256`5D of char; X string = varying `5B20`5D of char; X filename = varying `5B16`5D of char; X XVAR X moves : integer; X last_move_x : integer; X last_move_y : integer; X size : integer; X len : integer; X score : integer; X point : array `5B0..9,0..9`5D of char; X best_move : Record X x : integer; X y : integer; X pri : integer; X size : integer; X follow : integer; X END; X ret : char; X it : string; X X XPROCEDURE scrollup; X`7B scrolls picture up `7D XBEGIN X qio_write ( VT100_Esc + 'D' ); XEND; `7B scrollup `7D X X XPROCEDURE Split_screen; XBEGIN X qio_write ( VT100_Esc + '`5B19;23r' ); XEND; `7B split `7D X X XPROCEDURE Split_off; XBEGIN X qio_write ( VT100_Esc + '`5B1;24r' ); X posn ( 1,23 ); XEND; `7B split `7D X X XPROCEDURE Drawscreen; XVAR X i : integer; XBEGIN X clear; X posn (11,2); X qio_write ( VT100_top + 'Connect 4'); X posn (11,3); X qio_write ( VT100_bottom + 'Connect 4'); X X posn (11,7); X qio_write ( VT100_wide ); X qio_write ( VT100_graphics_on ); X qio_write ('l'); X FOR i := 1 to 8 do X qio_write ('q'); X qio_write ('k'); X FOR i := 1 to 8 do X BEGIN X posn (11,7+i); X qio_write ( VT100_wide ); X qio_write ('x'); X posn (20,7+i); X qio_write ('x'); X END; X posn (11,16); X qio_write ( VT100_wide ); X qio_write ('m'); X FOR i := 1 to 8 do X qio_write ('q'); X qio_write ('j'); X qio_write ( VT100_graphics_off ); X posn (12,17); X qio_write ( VT100_wide ); X FOR i := 1 to 8 do X qio_write ( dec(i) ); XEND; `7B Drawscreen `7D X X XPROCEDURE Setup; XVAR X i : integer; X j : integer; XBEGIN X image_dir; X FOR i := 1 to 8 do X FOR j := 1 to 8 do X point `5Bi,j`5D := ' '; X drawscreen; X split_screen; XEND; `7B Setup `7D X X XPROCEDURE Screen ( a, b : integer; ch : char ); XBEGIN X point `5Ba,b`5D := ch; X posn (11+a,16-b); X qio_write (ch); XEND; `7B Screen `7D X X XPROCEDURE First_turn; XVAR X ran : integer; XBEGIN X moves := 1; X ran := random(8); X screen (ran,1,'X'); X posn (20,23); X qio_write ('Computers move : ' + dec(ran)); X scrollup; XEND; `7B First_turn `7D X X XFUNCTION Down_count ( x, y : integer; ch : char ) : integer; XBEGIN X IF ( y=0 ) or ( point`5Bx,y`5D<>ch ) then`20 X down_count := 0 X ELSE X down_count := down_count(x,y-1,ch) + 1; XEND; `7B Down_count `7D X X XFUNCTION Left_count ( x, y : integer; ch : char ) : integer; XBEGIN X IF ( x=0 ) or ( point`5Bx,y`5D<>ch ) then`20 X left_count := 0 X ELSE X left_count := left_count(x-1,y,ch) + 1; XEND; `7B Left_count `7D X X XFUNCTION Right_count ( x, y : integer; ch : char ) : integer; XBEGIN X IF ( x=9 ) or ( point`5Bx,y`5D<>ch ) then`20 X right_count := 0 X ELSE X right_count := right_count(x+1,y,ch) + 1; XEND; `7B Right_count `7D X X XFUNCTION Up_L_count ( x, y : integer; ch : char ) : integer; XBEGIN X IF ( y=9 ) or ( x=0 ) or ( point`5Bx,y`5D<>ch ) then`20 X up_l_count := 0 X ELSE X up_l_count := up_l_count(x-1,y+1,ch) + 1; XEND; `7B Up_L_count `7D X X XFUNCTION Down_R_count ( x, y : integer; ch : char ) : integer; XBEGIN X IF ( y=0 ) or ( x=9 ) or ( point`5Bx,y`5D<>ch ) then`20 X down_r_count := 0 X ELSE X down_r_count := down_r_count(x+1,y-1,ch) + 1; XEND; `7B Down_count `7D X X XFUNCTION UP_R_count ( x, y : integer; ch : char ) : integer; XBEGIN X IF ( y=9 ) or ( x=9 ) or ( point`5Bx,y`5D<>ch ) then`20 X up_r_count := 0 X ELSE X up_r_count := up_r_count(x+1,y+1,ch) + 1; XEND; `7B UP_R_count `7D X X XFUNCTION Down_L_count ( x, y : integer; ch : char ) : integer; XBEGIN X IF ( y=0 ) or ( x=0 ) or ( point`5Bx,y`5D<>ch ) then`20 X down_l_count := 0 X ELSE X down_l_count := down_l_count(x-1,y-1,ch) + 1; XEND; `7B Down_L_count `7D X X XFUNCTION Priority ( x, y : integer; info : also ) : integer; XVAR X i : integer; X k : integer; X X PROCEDURE Number_check ( n, p : integer; ch : char ); X BEGIN X IF ( down_count(x,y-1,ch) >= n ) or X ( left_count(x-1,y,ch) + right_count(x+1,y,ch) >= n ) or X ( up_l_count(x-1,y+1,ch) + down_r_count(x+1,y-1,ch) >= n ) or X ( up_r_count(x+1,y+1,ch) + down_l_count(x-1,y-1,ch) >= n ) then X priority := p; X END; `7B Number_check `7D X X X FUNCTION Total_count ( ch : char ) : integer; X BEGIN X total_count := down_count(x,y-1,ch) +`20 X left_count(x-1,y,ch) + right_count(x+1,y,ch) + X up_l_count(x-1,Y+1,ch) + down_r_count(x+1,Y-1,ch) + X up_r_count(x+1,Y+1,ch) + down_l_count(x-1,y-1,ch); X END; X X`7B priority code begins, NOTE computer 'X' `7D X XBEGIN X priority := 10; X`7B number check ( eg below ) 4 = priority given if row of 1 'O's is found ` V7D X Number_check(1,4,'O'); X Number_check(2,3,'X'); X Number_check(2,2,'O'); X Number_check(3,1,'O'); X Number_check(3,0,'X'); X X `7B side affect if all infomation required `7D X X IF ORD(info)=0 then X size := total_count('X'); XEND; `7B priority `7D X X XFUNCTION correct_priority ( x, y : integer; quant : integer ) : boolean; XVAR X i : integer; X k : integer; X X PROCEDURE Check ( n : integer; ch : char ); X BEGIN X IF ( down_count(x,y-1,ch) >= n ) or X ( left_count(x-1,y,ch) + right_count(x+1,y,ch) >= n ) or X ( up_l_count(x-1,y+1,ch) + down_r_count(x+1,y-1,ch) >= n ) or X ( up_r_count(x+1,y+1,ch) + down_l_count(x-1,y-1,ch) >= n ) then X correct_priority := true; X END; `7B Number_check `7D X X`7B priority code begins, NOTE computer 'X' `7D X XBEGIN X correct_priority := false; X IF ( quant=0 ) then check(3,'X'); X IF ( quant=1 ) then check(3,'O'); XEND; `7B correct_priority `7D X X XFUNCTION Count_length ( x, y : integer ) : integer; XVAR X len : integer; X tot_len : integer; X XBEGIN X tot_len := 0; X len := (down_count(x,y,'O')); X IF ( len>3 ) then tot_len := len; X len := (left_count(x-1,y,'O')+right_count(x+1,y,'O')+1); X IF ( len>3 ) then tot_len := tot_len + len; X len := (up_l_count(x-1,y+1,'O')+down_r_count(x+1,y-1,'O')+1); X IF ( len>3 ) then tot_len := tot_len + len; X len := (up_r_count(x+1,y+1,'O')+down_l_count(x-1,y-1,'O')+1); X IF ( len>3 ) then tot_len := tot_len + len; X count_length := tot_len; XEND; `7B Count_length `7D X X XFUNCTION Player_won : boolean; XBEGIN X player_won := correct_priority (last_move_x,last_move_y,1); XEND; `7B player_won `7D X X XFUNCTION Computer_won : boolean; XBEGIN X Computer_won := correct_priority (best_move.x,best_move.y,0); XEND; `7B computer_won `7D X X XPROCEDURE Refresh_screen; XVAR X a, b : integer; XBEGIN X FOR a := 1 to 8 do X FOR b := 1 to 8 do X IF ( point`5Ba,b`5D<>' ' ) then X screen(a,b,point`5Ba,b`5D); XEND; `7B Refresh_screen `7D X X XPROCEDURE Players_turn; XVAR X ch : char; X a,b :integer; XBEGIN X REPEAT X REPEAT X posn (20,23); X qio_write ('Your move (1-8) : '); X ch := upper_case(qio_1_char); X last_move_x := ORD(ch) - ORD('0'); X qio_write ( ch ); X scrollup; X IF ( ch='I' ) then`20 X BEGIN X reset_screen; X show_graphedt ('CONNECT4.PIC'); X drawscreen; X refresh_screen; X split_screen; X END; X IF ( last_move_x<1 ) or ( last_move_x>8 ) and ( ch<>'I' ) then X BEGIN X posn (20,23); X qio_write ('? WHAT ?'); X scrollup; X END; X UNTIL ( last_move_x>=1 ) and ( last_move_x<=8 ); X last_move_y := 0; X REPEAT X last_move_y := last_move_y + 1; X UNTIL ( point`5Blast_move_x,last_move_y`5D=' ' ) or ( last_move_y=8 ); X IF ( point`5Blast_move_x,last_move_y`5D<>' ' ) then X BEGIN X posn (20,23); X qio_write ('* FULL *'); X scrollup; X END; X UNTIL ( point`5Blast_move_x,last_move_y`5D=' ' ); X screen (last_move_x,last_move_y,'O'); X moves := moves + 1; XEND; `7B Players_turn `7D X X X XPROCEDURE Computers_turn; XVAR X i : integer; X j : integer; X k : integer; X dumb_move : boolean; X randomize : array `5B1..8`5D of integer; XBEGIN X posn (20,23); X qio_write ('Computers move : '); X best_move.pri := 20; X FOR i := 1 to 8 do`20 X BEGIN X j := 0; X REPEAT X j := j + 1; X UNTIL ( point`5Bi,j`5D=' ' ) or ( j=8 ); X IF ( point`5Bi,j`5D=' ' ) then X IF ( priority(i,j,all)best_move.size )) then X BEGIN X dumb_move := false; X IF ( j<8 ) then X BEGIN X IF ( correct_priority(i,j+1,1) ) and`20 X not( priority(i,j,some)=0 ) then X dumb_move := true; X IF ( priority(i,j,some)>1 ) and`20 X ( priority(i,j+1,some)=0 ) then X dumb_move := true; X END; X IF not dumb_move then X BEGIN X WITH best_move do X BEGIN X x := i; X y := j; X pri := priority (i,j,all); X END; X best_move.size := size; X END; X END; X END; X IF ( best_move.pri=20 ) then X BEGIN X FOR j := 1 to 8 do X randomize`5Bj`5D := 0; X k := 0; X REPEAT X WITH best_move do X BEGIN X REPEAT X x := random(8); X UNTIL ( x<>randomize`5B1`5D ) and ( x<>randomize`5B2`5D ) and X ( x<>randomize`5B3`5D ) and ( x<>randomize`5B4`5D ) and X ( x<>randomize`5B5`5D ) and ( x<>randomize`5B6`5D ) and X ( x<>randomize`5B7`5D ); X k := k + 1; X randomize`5Bk`5D := x; X j := 0; X REPEAT X j := j + 1; X UNTIL ( point`5Bk,j`5D=' ' ) or ( j=8 ); X IF ( point`5Bk,j`5D=' ' ) then X y := j; X END; X UNTIL ( point`5Bk,j`5D=' ' ); X best_move.x := k; X best_move.y := j; X END; X qio_write ( dec(best_move.x)); X scrollup; X screen ( best_move.x,best_move.y,'X'); X moves := moves + 1; XEND; `7B Computers_turn `7D X X XPROCEDURE Play_game; XVAR X first : char; XBEGIN X posn (19,23); X qio_write ('Type I for instructions'); X scrollup; X REPEAT X posn (20,23); X qio_write ('Can I go first (Y/N) :'); X first := upper_case (qio_1_char); X qio_write ( first ); X scrollup; X IF ( first='I' ) then`20 X BEGIN X reset_screen; X show_graphedt ('CONNECT4.PIC'); X drawscreen; X split_screen; X END; X UNTIL ( first='Y' ) or ( first='N' ); X moves := 1; X IF ( first='Y' ) then X first_turn X ELSE X moves := 0; X REPEAT X IF ( moves<64 ) then X players_turn; +-+-+-+-+-+-+-+- END OF PART 1 +-+-+-+-+-+-+-+-