rem Prim II ...... Rev 2.0
      rem A J Tooth // Rewritten and debugged 18th August 2007
      
      rem ==================================================================
      rem Demonstrates the PRIM Algorithm to find
      rem the minimum Spanning Tree for a Network.
      rem ==================================================================
      on error if (err=17) then quit
      
      himem=lomem + 200000000
      *FLOAT 64
      
      rem Setup
      proc_setup
      
      *REFRESH OFF
      rem Initial Net View
      proc_netview
      
      T=time
      gcol 3
      
      rem PRIM Algorithm
      Lev%=0 : Edgcnt%=0 : proc_PRIM(Lev%,0,Edgcnt%,Mdis)
      
      rem Report result
      proc_resrep
      
      a$=get$
      quit
      rem End of Program ===================================================
      
      rem Setup fullscreen
      def  proc_fullscreen(return xscreen%, return yscreen%)
      
      sys "GetSystemMetrics", 0 to xscreen%
      sys "GetSystemMetrics", 1 to yscreen%
      sys "SetWindowLong",@hwnd%,-16,&16000000
      sys "SetWindowPos",@hwnd%,-1,0,0,xscreen%,yscreen%,0
      vdu 23,22,xscreen%;yscreen%;8,16,16,1 : rem Set fullscreen mode
      off : mouse off
      endproc
      rem ==================================================================
      
      rem Setup
      def proc_setup
      local a%,b%,pass&
      
      proc_fullscreen(xlim%,ylim%)
      
      input tab(5,5)"How many vertices? (300) ",num%
      if num%=0 then num%=300
      
      print tab(5,10)"Do you want to see the entire network, or just the vertices? Press -n- or -v-. "
      repeat
        ch$=get$
      until ch$="n" or ch$="v"
      cls
      
      dim ver%(num%,2), edg(num%,num%), edgchk&(num%,num%), verseq%(num%)
      dim drw% 1000
      
      rem Random Vertices
      for a%=1 to num%
        ver%(a%,1)=rnd(xlim%)-1
        ver%(a%,2)=rnd(ylim%)-1
      next a%
      
      rem Edge distances matrix
      for a%=1 to (num%-1)
        for b%=(a%+1) to num%
          edg(a%,b%)=sqr((ver%(a%,1)-ver%(b%,1))^2 + (ver%(a%,2)-ver%(b%,2))^2)
          edg(b%,a%)=edg(a%,b%)
        next b%
      next a%
      edgcnt%=0 : verseq%(1)=1 : Mdis=1000000.0
      
      rem Dual-pass Assembly
      for pass&=0 to 2 step 2
        proc_drw(pass&)
      next pass&
      
      endproc
      rem ==================================================================
      
      rem Initial Net View
      def proc_netview
      local a%,b%
      
      rem Draw all lines between vertices
      if ch$="n" then
        colour 10,150,0,0 : gcol 10
        for a%=1 to (num%-1)
          for b%=(a%+1) to num%
            move 2*ver%(a%,1),2*ver%(a%,2)
            draw 2*ver%(b%,1),2*ver%(b%,2)
          next b%
          *REFRESH
        next a%
      endif
      
      rem Draw the vertices themselves
      colour 10,100,255,255 : gcol 10
      for a%=1 to num%
        circle fill 2*ver%(a%,1),2*ver%(a%,2),10
      next a%
      
      endproc
      rem ==================================================================
      
      rem PRIM Algorithm
      def proc_PRIM(return Lev%,subedg%,return edgcnt%,msub)
      local rep&, mdis
      
      Lev%+=1
      
      rep&=1
      repeat
        
        mdis=msub
        proc_search(mdis,subedg%+1,edgcnt%+1,ma%,mb%)
        
        if mdis<msub then
          rem Set the next edge
          proc_setedge(edgcnt%,ma%,mb%)
          
          call drw% : rem Draw the next connection
          *REFRESH
          
          proc_PRIM(Lev%,edgcnt%,edgcnt%,mdis)
          
        else
          rep&=0
        endif
        
      until (edgcnt%=num%-1) or rep&=0
      
      Lev%-=1
      
      endproc
      rem ==================================================================
      
      rem Search for next shortest link
      def proc_search(return mdis,srt%,fin%,return ma%,return mb%)
      local v%,a%,b%
      
      for v%=srt% to fin%
        a%=verseq%(v%) : b%=a%+1 : if b%>num% then b%=1
        
        repeat
          if edgchk&(a%,b%)=0 then
            if edg(a%,b%)<mdis then
              if ver%(b%,0)=0 then
                mdis=edg(a%,b%)
                ma%=a% : mb%=b%
              endif
            endif
          endif
          b%+=1 : if b%>num% then b%=1
        until b%=a%
      next v%
      endproc
      rem ==================================================================
      
      rem Set the next edge
      def proc_setedge(return edgcnt%,ma%,mb%)
      
      edgchk&(ma%,mb%)=1 : edgchk&(mb%,ma%)=1
      ver%(ma%,0)+=1 : ver%(mb%,0)+=1 : edgcnt%+=1
      verseq%(edgcnt%+1)=mb%
      endproc
      rem ==================================================================
      
      rem Report result
      def proc_resrep
      local DT
      
      DT=(time-T)/100
      *REFRESH ON
      colour 2 : print tab(0,0);Edgcnt%;" edges"
      print tab(0,1);DT;" secs"
      if DT>0.0 then print tab(0,2);(int(100*Edgcnt%/DT))/100;"/s"
      endproc
      rem ==================================================================
      
      rem Assembly Language Routine for Drawing
      def proc_drw(opt&)
      P%=drw%
      
      [opt opt&
      
      mov edx,[^ma%]
      shl edx,2
      mov eax,edx
      shl edx,1
      add eax,edx
      mov ebx,[eax + ^ver%(0,1)]
      shl ebx,1
      mov [^x1%],ebx
      mov ebx,[eax + ^ver%(0,2)]
      shl ebx,1
      mov [^y1%],ebx
      
      mov edx,[^mb%]
      shl edx,2
      mov eax,edx
      shl edx,1
      add eax,edx
      mov ebx,[eax + ^ver%(0,1)]
      shl ebx,1
      mov [^x2%],ebx
      mov ebx,[eax + ^ver%(0,2)]
      shl ebx,1
      mov [^y2%],ebx
      
      mov al,25                    ;Calls pl0t routine
      call "oswrch"
      mov al,4
      call "oswrch"
      mov bx,[^x1%]
      mov al,bl
      call "oswrch"
      mov al,bh
      call "oswrch"
      mov bx,[^y1%]
      mov al,bl
      call "oswrch"
      mov al,bh
      call "oswrch"
      
      mov al,25                    ;Calls pl0t routine
      call "oswrch"
      mov al,5
      call "oswrch"
      mov bx,[^x2%]
      mov al,bl
      call "oswrch"
      mov al,bh
      call "oswrch"
      mov bx,[^y2%]
      mov al,bl
      call "oswrch"
      mov al,bh
      call "oswrch"
      
      ret
      ]
      endproc
      rem ==================================================================