$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
$!   On 14-JAN-1993 19:54:26.20   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 3 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. SOLITAIRE.FOR;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      program solitaire
X      implicit none
X      character *65 message,verify
X      character *4 sc_str
X      character *3 card(52)
X      integer *4 lib$disable_ctrl,length,sys$setpri,i,j,win,nn,mm
X      integer *4 disp,paste,keyb,memory(52),tm_code,lib$wait,mask,old
X      integer *4 from,to,pile(24),board(7,13),top(6,6),save(4,1),send
X      integer *4 lib$get_foreign,score,run,seed,lib$enable_ctrl,status
X      logical *4 compare_save,compare_board,quit/.false./
X      include '($smgdef)'
X      include '($smgmsg)'
X      include '($libclidef)'
X      include '(smg$routines)'
X
X      mask = lib$m_cli_ctrly
X      call ec(lib$disable_ctrl(mask,old))
X      run = 1
X
X      card(01) = 'A S'
X      card(02) = '2 S'
X      card(03) = '3 S'
X      card(04) = '4 S'
X      card(05) = '5 S'
X      card(06) = '6 S'
X      card(07) = '7 S'
X      card(08) = '8 S'
X      card(09) = '9 S'
X      card(10) = '10S'
X      card(11) = 'J S'
X      card(12) = 'Q S'
X      card(13) = 'K S'
X      card(14) = 'A C'
X      card(15) = '2 C'
X      card(16) = '3 C'
X      card(17) = '4 C'
X      card(18) = '5 C'
X      card(19) = '6 C'
X      card(20) = '7 C'
X      card(21) = '8 C'
X      card(22) = '9 C'
X      card(23) = '10C'
X      card(24) = 'J C'
X      card(25) = 'Q C'
X      card(26) = 'K C'
X      card(27) = 'A H'
X      card(28) = '2 H'
X      card(29) = '3 H'
X      card(30) = '4 H'
X      card(31) = '5 H'
X      card(32) = '6 H'
X      card(33) = '7 H'
X      card(34) = '8 H'
X      card(35) = '9 H'
X      card(36) = '10H'
X      card(37) = 'J H'
X      card(38) = 'Q H'
X      card(39) = 'K H'
X      card(40) = 'A D'
X      card(41) = '2 D'
X      card(42) = '3 D'
X      card(43) = '4 D'
X      card(44) = '5 D'
X      card(45) = '6 D'
X      card(46) = '7 D'
X      card(47) = '8 D'
X      card(48) = '9 D'
X      card(49) = '10D'
X      card(50) = 'J D'
X      card(51) = 'Q D'
X      card(52) = 'K D'
X
X
X 3    call ec(smg$create_virtual_display(24,80,disp))
X      call ec(smg$create_pasteboard(paste))
X      call ec(smg$create_virtual_keyboard(keyb))
X      call ec(smg$set_broadcast_trapping(paste))
X      call ec(smg$begin_display_update(disp))
X      call ec(smg$draw_rectangle(disp,3,1,17,7))
X      call ec(smg$draw_rectangle(disp,3,10,17,16))
X      call ec(smg$draw_rectangle(disp,3,19,17,25))
X      call ec(smg$draw_rectangle(disp,3,28,17,34))
X      call ec(smg$draw_rectangle(disp,3,37,17,43))
X      call ec(smg$draw_rectangle(disp,3,46,17,52))
X      call ec(smg$draw_rectangle(disp,3,55,17,61))
X      call ec(smg$draw_rectangle(disp,1,66,4,70))
X      call ec(smg$draw_rectangle(disp,7,66,10,70))
X      call ec(smg$draw_rectangle(disp,13,66,16,70))
X      call ec(smg$draw_rectangle(disp,19,66,22,70))
X      call ec(smg$draw_rectangle(disp,20,53,22,59))
X      call ec(smg$draw_rectangle(disp,20,45,22,51))
X      call ec(smg$put_chars(disp,'1',18,4))
X      call ec(smg$put_chars(disp,'2',18,13))
X      call ec(smg$put_chars(disp,'3',18,22))
X      call ec(smg$put_chars(disp,'4',18,31))
X      call ec(smg$put_chars(disp,'5',18,40))
X      call ec(smg$put_chars(disp,'6',18,49))
X      call ec(smg$put_chars(disp,'7',18,58))
X      call ec(smg$put_chars(disp,'S',2,72))
X      call ec(smg$put_chars(disp,'D',8,72))
X      call ec(smg$put_chars(disp,'H',14,72))
X      call ec(smg$put_chars(disp,'C',20,72))
X      call ec(smg$put_chars(disp,'Stack',23,54))
X      call ec(smg$put_chars(disp,'Score',23,46))
X      call ec(smg$put_chars(disp,'     ',2,11,,smg$m_reverse))
X      call ec(smg$put_chars(disp,'     ',2,20,,smg$m_reverse))
X      call ec(smg$put_chars(disp,'     ',2,29,,smg$m_reverse))
X      call ec(smg$put_chars(disp,'     ',2,38,,smg$m_reverse))
X      call ec(smg$put_chars(disp,'     ',2,47,,smg$m_reverse))
X      call ec(smg$put_chars(disp,'     ',2,56,,smg$m_reverse))
X      call ec(smg$put_chars(disp,'   ',21,55,,smg$m_reverse))
X      call ec(smg$end_display_update(disp))
X      call ec(smg$paste_virtual_display(disp,paste,1,1))
X      call shuffle(pile,board,top,run,seed)
X      call ec(smg$begin_display_update(disp))
X      j = 0
X      do i = 3,57,9
X        j = j + 1
X        if (board(j,1).lt.27) then
X          call ec(smg$put_chars(disp,card(board(j,1)),4,i,,
X     +      smg$m_reverse))
X        else
X          call ec(smg$put_chars(disp,card(board(j,1)),4,i))
X        endif
X      enddo
X      call ec(smg$put_chars(disp,'Move> ',22,4))
X      call ec(smg$end_display_update(disp))
X
X*
X* The cards have been distributed and the board has been set.
X* It is now time to proceed with the interactive game.
X*
X
X
X 50   call ec(sys$setpri(,,%val(4),))
X      call num_to_str(score,sc_str,length)
X      call ec(smg$put_chars(disp,sc_str(1:length),21,46+4-length))
X      call ec(smg$get_broadcast_message(paste,message,length))
X      if (length.ne.0) then
X        call ec(smg$ring_bell(disp,2))
X        call ec(smg$put_chars(disp,message,1,1))
X      endif
X      win = 0
X      do i = 1,4
X        if (index(card(save(i,1)),'K').ne.0) win = win + 1
X      enddo
X      if (win.eq.4) go to 96
X      call ec(smg$set_cursor_abs(disp,22,10))
X      status = smg$read_keystroke(keyb,tm_code)
X      if ((.not.status).and.(status.ne.smg$_eof)) call ec(status)
X      if (tm_code.eq.smg$k_trm_lowercase_r) then
X        call ec(smg$erase_chars(disp,65,1,1))
X        call ec(smg$repaint_screen(paste))
X        go to 50
X      endif
X      if (tm_code.eq.smg$k_trm_lowercase_q) go to 98
X      if ((tm_code.eq.smg$k_trm_one).or.(tm_code.eq.smg$k_trm_kp1))
X     +  then
X        from = 1
X        call ec(smg$put_chars(disp,'1'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_two).or.(tm_code.eq.smg$k_trm_kp2))
X     +  then
X        from = 2
X        call ec(smg$put_chars(disp,'2'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_three).or.(tm_code.eq.smg$k_trm_kp3))
X     +  then
X        from = 3
X        call ec(smg$put_chars(disp,'3'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_four).or.(tm_code.eq.smg$k_trm_kp4))
X     +  then
X        from = 4
X        call ec(smg$put_chars(disp,'4'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_five).or.(tm_code.eq.smg$k_trm_kp5))
X     +  then
X        from = 5
X        call ec(smg$put_chars(disp,'5'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_six).or.(tm_code.eq.smg$k_trm_kp6))
X     +  then
X        from = 6
X        call ec(smg$put_chars(disp,'6'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_seven).or.(tm_code.eq.smg$k_trm_kp7))
X     +  then
X        from = 7
X        call ec(smg$put_chars(disp,'7'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_pf1).or.(tm_code.eq.smg$k_trm_f18)) then
X        from = 9 !draw option
X        call ec(smg$put_chars(disp,'Draw'))
X        call draw_card(pile)
X        if (pile(1).lt.27) then
X          call ec(smg$put_chars(disp,card(pile(1)),21,55,,
X     +      smg$m_reverse))
X        else
X          call ec(smg$put_chars(disp,card(pile(1)),21,55))
X        endif
X        call ec(smg$put_chars(disp,'    ',22,10))
X        go to 50
X      endif
X      if ((tm_code.eq.smg$k_trm_pf2).or.
X     +  (tm_code.eq.smg$k_trm_question_mark)) then
X        call help(paste,keyb)
X        go to 50
X      endif
X      if ((tm_code.eq.smg$k_trm_pf3).or.(tm_code.eq.smg$k_trm_f19)) then
X        from = 0 !from option
X        call ec(smg$put_chars(disp,'Stack'))
X        go to 55
X      endif
X      if ((tm_code.eq.smg$k_trm_pf4).or.(tm_code.eq.smg$k_trm_f20)) then
X        from = 8 !save option
X        call ec(smg$put_chars(disp,'Save'))
X        go to 55
X      endif
X      call ec(smg$put_chars(disp,'Type "?" for help',24,6))
X      call ec(lib$wait(1.0))
X      call ec(smg$put_chars(disp,'                  ',22,10))
X      call ec(smg$put_chars(disp,'                 ',24,6))
X      call ec(smg$set_cursor_abs(disp,22,10))
X      go to 50
X
X 55   call ec(smg$put_chars(disp,' to '))
X      call ec(smg$read_keystroke(keyb,tm_code))
X      if ((tm_code.eq.smg$k_trm_one).or.(tm_code.eq.smg$k_trm_kp1))
X     +  then
X        to = 1
X        call ec(smg$put_chars(disp,'1'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_two).or.(tm_code.eq.smg$k_trm_kp2))
X     +  then
X        to = 2
X        call ec(smg$put_chars(disp,'2'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_three).or.(tm_code.eq.smg$k_trm_kp3))
X     +  then
X        to = 3
X        call ec(smg$put_chars(disp,'3'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_four).or.(tm_code.eq.smg$k_trm_kp4))
X     +  then
X        to = 4
X        call ec(smg$put_chars(disp,'4'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_five).or.(tm_code.eq.smg$k_trm_kp5))
X     +  then
X        to = 5
X        call ec(smg$put_chars(disp,'5'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_six).or.(tm_code.eq.smg$k_trm_kp6))
X     +  then
X        to = 6
X        call ec(smg$put_chars(disp,'6'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_seven).or.(tm_code.eq.smg$k_trm_kp7))
X     +  then
X        to = 7
X        call ec(smg$put_chars(disp,'7'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_pf3).or.(tm_code.eq.smg$k_trm_f19)) then
X        to = 0
X        call ec(smg$put_chars(disp,'Stack'))
X        go to 60
X      endif
X      if ((tm_code.eq.smg$k_trm_pf4).or.(tm_code.eq.smg$k_trm_f20)) then
X        to = 8
X        call ec(smg$put_chars(disp,'Save'))
X        go to 60
X      endif
X      call ec(smg$put_chars(disp,'Type "?" for help',24,6))
X      call ec(lib$wait(1.0))
X      call ec(smg$put_chars(disp,'                  ',22,10))
X      call ec(smg$put_chars(disp,'                 ',24,6))
X      call ec(smg$set_cursor_abs(disp,22,10))
X      go to 50
X
X 60   if ((from.eq.8).or.(to.eq.0)) then
X        call illegal(disp)
X        go to 50
X      endif
X      if (from.eq.to) then
X        call illegal(disp)
X        go to 50
X      endif
X      if (from.eq.0) then
X        if (to.eq.8) then
X          if (index(card(pile(1)),'S').ne.0) send = save(1,1)
X          if (index(card(pile(1)),'D').ne.0) send = save(2,1)
X          if (index(card(pile(1)),'H').ne.0) send = save(3,1)
X          if (index(card(pile(1)),'C').ne.0) send = save(4,1)
X          if (not(compare_save(card(pile(1)),card(send),
X     +      pile(1),send))) then
X            call illegal(disp)
X            go to 50
X           else
X            call save_gain(disp,card,save,pile,board,0,0)
X            score = score + 12
X            call pile_loss(disp,card,pile)
X          endif
X        elseif ((to.gt.0).and.(to.lt.8)) then
X          do i = 1,13
X            if (board(to,i).ne.0) nn = i
X          enddo
X          if (not(compare_board(board,card(pile(1)),card(board(to,nn)),
X     +      to))) then
X            call illegal(disp)
X            go to 50
X          else
X            call board_gain_single(disp,card,pile,board,to,nn)
X            score = score + 5
X            call pile_loss(disp,card,pile)
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      elseif ((from.gt.0).and.(from.lt.8)) then
X        do i = 1,13
X          if (board(from,i).ne.0) mm = i
X        enddo
X        if (to.eq.8) then
X          if (index(card(board(from,mm)),'S').ne.0) send = save(1,1)
X          if (index(card(board(from,mm)),'D').ne.0) send = save(2,1)
+-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-