-+-+-+-+-+-+-+-+ START OF PART 2 -+-+-+-+-+-+-+-+ X if (index(card(board(from,mm)),'H').ne.0) send = save(3,1) X if (index(card(board(from,mm)),'C').ne.0) send = save(4,1) X if (not(compare_save(card(board(from,mm)),card(send), X + board(from,mm),send))) then X call illegal(disp) X go to 50 X else X call save_gain(disp,card,save,pile,board,from,mm) X score = score + 5 X call board_loss_single(disp,card,board,from,mm,top,score) X endif X elseif ((to.gt.0).and.(to.lt.8)) then X do i = 1,13 X if (board(from,i).ne.0) mm = i X if (board(to,i).ne.0) nn = i X enddo X if (not(compare_board(board,card(board(from,1)), X + card(board(to,nn)),to))) then X call illegal(disp) X go to 50 X else X call board_gain_whole(disp,card,board,from,mm,to,nn) X call board_loss_whole(disp,card,board,from,mm,top,score) X endif X endif X call ec(smg$put_chars(disp,' ',22,10)) X call ec(smg$set_cursor_abs(disp,22,10)) X go to 50 X endif X X X 96 call ec(smg$erase_display(disp,1,1,24,80)) X call ec(smg$put_chars_highwide(disp,'**************', X + 9,27,,smg$m_blink)) X call ec(smg$put_chars_highwide(disp,'* YOU WON! *', X + 11,27,,smg$m_blink)) X call ec(smg$put_chars_highwide(disp,'**************', X + 13,27,,smg$m_blink)) X call ec(smg$ring_bell(disp,3)) X call ec(smg$set_cursor_abs(disp,23,1)) X score = score + 25 X run = run + 1 X call ec(lib$wait(3.0)) X call ec(smg$delete_virtual_keyboard(keyb)) X call ec(smg$delete_pasteboard(paste)) X call ec(smg$delete_virtual_display(disp)) X go to 97 X`20 X 98 call ec(smg$delete_virtual_keyboard(keyb)) X call ec(smg$delete_pasteboard(paste)) X call ec(smg$delete_virtual_display(disp)) X call score_list(score,run) X print* X write(*,100) X read(*,'(a)') verify X if ((index(verify,'y').eq.0).and.(index(verify,'Y').eq.0)) then X quit = .true. X else X score = 0 X run = 1 X endif X 97 if (not(quit)) then X do i = 1,4 X save(i,1) = 0 X enddo X do i = 1,7 X do j = 1,13 X board(i,j) = 0 X enddo X enddo X do i = 1,6 X do j = 1,6 X top(i,j) = 0 X enddo X enddo X go to 3 X endif X call ec(lib$enable_ctrl(old)) X 100 format('$Do you wish to play again? ') X end X X X subroutine score_list (score,run) X implicit none X integer *4 score,num(15),ntmp(16),run,brd(15),btmp(15) X integer *4 i,j,lib$wait,lib$getjpi,status X character *12 userid,id(15),itmp(16) X integer *4 attempts X logical *4 change X include '($jpidef)' X X change = .false. X attempts = 0 X call ec(lib$getjpi(jpi$_username,,,,userid)) X10 attempts = attempts + 1 X open(11, X + file='disk$userdisk1:`5Bmas0.maslib.games.solitaire`5Dlist.high', X + status='unknown',iostat=status,shared) X if (status.ne.0) then X call ec(lib$wait(2.0)) X if (attempts.gt.10) then X print*,'ERROR opening scores list!' X stop X endif X go to 10 X endif X do i = 1,15 X read(11,80,end=60) ntmp(i),itmp(i),btmp(i) X enddo X 60 do i = 1,15 X if (score.gt.ntmp(i)) then X change = .true. X num(i) = score X id(i) = userid X brd(i) = run X do j = i+1,15 X num(j) = ntmp(j-1) X id(j) = itmp(j-1) X brd(j) = btmp(j-1) X enddo X go to 62 X endif X num(i) = ntmp(i) X id(i) = itmp(i) X brd(i) = btmp(i) X enddo X 62 if (change) then X rewind(11) X do i = 1,15 X write(11,80) num(i),id(i),brd(i) X enddo X endif X rewind(11) X print*,' RANK USERNAME SCORE BOARD' X print*,' ==== ======== ===== =====' X print* X do i = 1,15 X read(11,80,end=95) num(i),id(i),brd(i) X if (num(i).eq.0) go to 95 X write(*,82) i,id(i),num(i),brd(i) X enddo X 80 format(i4,a12,i4) X 82 format(' ',i4,6x,a12,1x,i4,6x,i4) X 95 close(11) X end X X X logical *4 function compare_save(cardf,cardt,from,to) X implicit none X character *(*) cardf,cardt X integer *4 from,to X X compare_save = .false. X if ((cardf(3:3).eq.cardt(3:3)).and.(from.eq.to+1)) X + compare_save = .true. X if ((to.eq.0).and.(index(cardf(1:1),'A').ne.0)) X + compare_save = .true. X end X X X logical *4 function compare_board(board,cardf,cardt,to) X implicit none X character *(*) cardf,cardt X integer *4 board(7,13),to,cardf_val,cardt_val X `20 X if (index(cardf,'A').ne.0) cardf_val = 1 X if (index(cardf,'2').ne.0) cardf_val = 2 X if (index(cardf,'3').ne.0) cardf_val = 3 X if (index(cardf,'4').ne.0) cardf_val = 4 X if (index(cardf,'5').ne.0) cardf_val = 5 X if (index(cardf,'6').ne.0) cardf_val = 6 X if (index(cardf,'7').ne.0) cardf_val = 7 X if (index(cardf,'8').ne.0) cardf_val = 8 X if (index(cardf,'9').ne.0) cardf_val = 9 X if (index(cardf,'0').ne.0) cardf_val = 10 X if (index(cardf,'J').ne.0) cardf_val = 11 X if (index(cardf,'Q').ne.0) cardf_val = 12 X if (index(cardf,'K').ne.0) cardf_val = 13 X X if (index(cardt,'A').ne.0) cardt_val = 1 X if (index(cardt,'2').ne.0) cardt_val = 2 X if (index(cardt,'3').ne.0) cardt_val = 3 X if (index(cardt,'4').ne.0) cardt_val = 4 X if (index(cardt,'5').ne.0) cardt_val = 5 X if (index(cardt,'6').ne.0) cardt_val = 6 X if (index(cardt,'7').ne.0) cardt_val = 7 X if (index(cardt,'8').ne.0) cardt_val = 8 X if (index(cardt,'9').ne.0) cardt_val = 9 X if (index(cardt,'0').ne.0) cardt_val = 10 X if (index(cardt,'J').ne.0) cardt_val = 11 X if (index(cardt,'Q').ne.0) cardt_val = 12 X if (index(cardt,'K').ne.0) cardt_val = 13 X X compare_board = .false. X if ((board(to,1).eq.0).and.(index(cardf,'K').ne.0)) X + compare_board = .true. X if ((index(cardf,'D').ne.0).or.(index(cardf,'H').ne.0)) then X if ((index(cardt,'S').ne.0).or.(index(cardt,'C').ne.0)) then X if (cardt_val.eq.cardf_val+1) then X compare_board = .true. X endif X endif X endif X if ((index(cardf,'S').ne.0).or.(index(cardf,'C').ne.0)) then X if ((index(cardt,'D').ne.0).or.(index(cardt,'H').ne.0)) then X if (cardt_val.eq.cardf_val+1) then X compare_board = .true. X endif X endif X endif X end X X X subroutine pile_loss(disp,card,pile) X implicit none X character *3 card(52) X integer *4 i,j,disp,smg$put_chars,pile(24),tmp(25) X include '($smgdef)' X X do i = 1,24 X tmp(i) = pile(i) X enddo X tmp(25) = 0 X do j = 1,24 X pile(j) = tmp(j+1) X enddo X if (pile(1).eq.0) then X call ec(smg$put_chars(disp,'---',21,55)) X return X endif X if (pile(1).lt.27) then X call ec(smg$put_chars(disp,card(pile(1)),21,55,,smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(pile(1)),21,55)) X endif X end X X X subroutine board_loss_single(disp,card,board,from,mm,top,score) X implicit none X character *3 card(52) X integer *4 disp,board(7,13),from,mm,top(6,6),smg$put_chars X integer *4 score X X if (mm.le.1) then X call ec(smg$put_chars(disp,' ',4,3+9*(from-1))) X board(from,1) = 0 X if (from.ne.1) call top_loss(disp,card,board,top,from,score) X else X call ec(smg$put_chars(disp,' ',3+mm,3+9*(from-1))) X board(from,mm) = 0 X endif X end X X X subroutine board_gain_single(disp,card,pile,board,to,nn) X implicit none X character *3 card(52) X integer *4 disp,board(7,13),pile(24),to,nn,smg$put_chars X include '($smgdef)' X X if (board(to,1).eq.0) nn = 0 X if (pile(1).lt.27) then X call ec(smg$put_chars(disp,card(pile(1)), X + 3+nn+1,3+9*(to-1),,smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(pile(1)), X + 3+nn+1,3+9*(to-1))) X endif X board(to,nn+1) = pile(1) X end X X X subroutine board_gain_whole (disp,card,board,from,mm,to,nn) X implicit none X character *3 card(52) X integer *4 i,disp,board(7,13),from,mm,to,nn,smg$put_chars X include '($smgdef)' X X if (board(to,1).eq.0) nn = 0 X do i = 1,13 X if (board(from,i).eq.0) return X if (board(from,i).lt.27) then X call ec(smg$put_chars(disp,card(board(from,i)), X + 3+nn+i,3+9*(to-1),,smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(board(from,i)), X + 3+nn+i,3+9*(to-1))) X endif X board(to,nn+i) = board(from,i) X enddo X end X X X subroutine board_loss_whole(disp,card,board,from,mm,top,score) X implicit none X character *3 card(52) X integer *4 i,disp,board(7,13),from,mm,top(6,6),smg$put_chars,score X X do i = 1,mm X call ec(smg$put_chars(disp,' ',3+i,3+9*(from-1))) X board(from,i) = 0 X enddo X if (from.eq.1) return X if (top(from-1,1).ne.0) call top_loss(disp,card,board,top,from, X + score) X end X X X subroutine save_gain(disp,card,save,pile,board,from,mm) X implicit none X character *3 card(52) X integer *4 disp,save(4,1),smg$put_chars,pile(24),from X integer *4 board(7,13),mm X include '($smgdef)' X `20 X if (((index(card(pile(1)),'S').ne.0).and.(from.eq.0)).or. X + ((index(card(board(from,mm)),'S').ne.0).and.(from.ne.0))) then X if (from.eq.0) then X save(1,1) = pile(1) X else X save(1,1) = board(from,mm) X endif X if (save(1,1).lt.27) then X call ec(smg$put_chars(disp,card(save(1,1)),2,67,, X + smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(save(1,1)),2,67)) X endif X endif X if (((index(card(pile(1)),'D').ne.0).and.(from.eq.0)).or. X + ((index(card(board(from,mm)),'D').ne.0).and.(from.ne.0))) then X if (from.eq.0) then X save(2,1) = pile(1) X else X save(2,1) = board(from,mm) X endif X if (save(2,1).lt.27) then X call ec(smg$put_chars(disp,card(save(2,1)),8,67,, X + smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(save(2,1)),8,67)) X endif X endif X if (((index(card(pile(1)),'H').ne.0).and.(from.eq.0)).or. X + ((index(card(board(from,mm)),'H').ne.0).and.(from.ne.0))) then X if (from.eq.0) then X save(3,1) = pile(1) X else X save(3,1) = board(from,mm) X endif X if (save(3,1).lt.27) then X call ec(smg$put_chars(disp,card(save(3,1)),14,67,, X + smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(save(3,1)),14,67)) X endif X endif X if (((index(card(pile(1)),'C').ne.0).and.(from.eq.0)).or. X + ((index(card(board(from,mm)),'C').ne.0).and.(from.ne.0))) then X if (from.eq.0) then X save(4,1) = pile(1) X else X save(4,1) = board(from,mm) X endif X if (save(4,1).lt.27) then X call ec(smg$put_chars(disp,card(save(4,1)),20,67,, X + smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(save(4,1)),20,67)) X endif X endif X end X X X subroutine top_loss(disp,card,board,top,from,score) X implicit none X character *3 card(52) X integer *4 i,j,disp,top(6,6),smg$put_chars,from,tmp(6,7) X integer *4 board(7,13),score X include '($smgdef)' X X if (top(from-1,1).eq.0) then X return X else X if (top(from-1,1).lt.27) then X call ec(smg$put_chars(disp,card(top(from-1,1)),4, X + 3+9*(from-1),,smg$m_reverse)) X else X call ec(smg$put_chars(disp,card(top(from-1,1)),4, X + 3+9*(from-1))) X endif X endif X board(from,1) = top(from-1,1) X do i = 1,6 X tmp(from-1,i) = top(from-1,i) X enddo X tmp(6,7) = 0 X do j = 1,6 X top(from-1,j) = tmp(from-1,j+1) X enddo X if (top(from-1,1).eq.0) then X call ec(smg$put_chars(disp,' ',2,11+9*(from-2))) X score = score + 8 X endif X end X X X subroutine shuffle(pile,board,top,run,seed) X implicit none X character *3 card(52) X real *4 value X integer *4 i,j,out(3),number,memory(52),count,seed,run X integer *4 pile(24),board(7,13),top(6,6) X X do i = 1,52 X memory(i) = 0 X enddo X if (run.eq.1) then X call time(out) X seed = out(2)/2 + 1 X value = ran(seed) * 100 X endif X 10 value = ran(seed) * 100 X number = value X if (number.gt.52) go to 10 X do i = 1,52 X if (memory(i).eq.number) go to 10 X if (memory(i).eq.0) go to 60 X enddo X 60 memory(i) = number X if (memory(52).ne.0) go to 90 X go to 10 X 90 count = 0 X do i = 1,7 X count = count + 1 X board(i,1) = memory(count) X enddo X do i = 1,6 X do j = 1,i X count = count + 1 X top(i,j) = memory(count) X enddo X enddo X do i = 1,24 X count = count + 1 X pile(i) = memory(count) X enddo X end X X X subroutine draw_card(pile) X implicit none X integer *4 i,j,pile(24),tmp(24) X X do i = 1,24 X if (pile(i).eq.0) go to 60 X tmp(i) = pile(i) X enddo X 60 if (i.le.4) then X do j = 1,i-1 X pile(j) = tmp(j+1) X enddo X pile(i-1) = tmp(1) X return X endif X do j = 1,i-1 X pile(j) = tmp(j+2) +-+-+-+-+-+-+-+- END OF PART 2 +-+-+-+-+-+-+-+-