' h1clib.bas - jackord@kw.igs.net - revised 10 Sep 02 - Liberty Basic v3.01
' companion program to cat.bas showing the parameter variation sequence
'   (a) used in cat.bas
'   (b) in the simplex algorithm
' the catenary constants are also refined using the simplex algorithm
' Initialize Window
  nomainwin
  textbox#1.tx1, 98, 167, 90, 20
  textbox#1.tx2, 98, 192, 90, 20
  textbox#1.tx3, 98, 217, 90, 20
  button#1, "Vary", [vr], UL, 53, 167, 40, 20
  button#1, "Simp", [k2], UL, 53, 192, 40, 20
  button#1, "Catc", [k3], UL, 53, 217, 40, 20
  WindowWidth=470     ' pixel scale 0-460
  WindowHeight=304    ' pixel scale 0-285
  UpperLeftX=100: UpperLeftY=100
  open "Simplex" for graphics_nsb as #1   ' no slide bars
  #1 "trapclose [quit]"
  dim q(9,6)
  gosub [pin]

[waitHere]
  wait

[pin]                                                ' Initial screen
  #1 "backcolor white ; cls ; down"
  #1 "color black ; place 48 12 ; box 448 242"
  #1 "place 28 248": #1 "\40"
  #1 "place 28 18": #1 "\52"
  #1 "place 0 133": #1 "\tension"
  #1 "place 234 268": #1 "\angle"
  #1 "place 40 262": #1 "\58"
  #1 "place 440 262": #1 "\80"
  n=64: d=400/(n+1): phi=0-6000: pi=4*atn(1): tns=48: dtns=2
  #1 "color red ; backcolor red": gosub [hit]
  #1.tx1 "phi = "; using("##.##", 0-phi/100)
  #1.tx2 "tns = "; using("##.##", tns)
  #1.tx3 "dev = "; using("##.##", s)
return

[vr]
  kk=1: gosub [pin]
  #1 "color blue ; backcolor blue": gosub[ang]
  while s>.1                                         ' Vary initial tesion
    tns=tns+dtns: ss=s: gosub [ang]                  ' ...and angle
    #1.tx1 "phi = "; using("##.##", 0-phi/100)
    #1.tx2 "tns = "; using("##.##", tns)
    #1.tx3 "dev = "; using("##.##", s)
    if s>ss then dtns=0-dtns/2
    scan
  wend                                               ' ...to reach support
  #1 "color red ; backcolor red": gosub [hit]
goto [waitHere]

[k2]
  kk=2
goto [sm]

[k3]
  kk=3
goto [sm]

[sm]                                                 ' Simplex algorithm
  if kk=2 then
    nvr=2: nvx=nvr+1: lim=0.1
    q(1, 1)=0-6000: q(1, 2)=48
    q(2, 1)=0-6000-256: q(2, 2)=48
    q(3, 1)=0-6000: q(3, 2)=50
  else
    nvr=3: nvx=nvr+1: lim=0.00001
    q(1, 1)=152: q(1, 2)=0-42: q(1, 3)=69
    q(2, 1)=153: q(2, 2)=0-42: q(2, 3)=69
    q(3, 1)=152: q(3, 2)=0-41: q(3, 3)=69
    q(4, 1)=152: q(4, 2)=0-42: q(4, 3)=70
  end if
  jlof=0: ii=1: gosub [pin]
  for ii=1 to nvx
    gosub [hit]: q(ii, 0)=s
  next ii
  gosub [sort]
  while q(1, 0)>lim
    xflag=0
    for i=1 to nvr
      ave=0
      for j=1 to nvr
        ave=ave+q(j, i)
      next j
      q(nvx+1, i)=ave/nvr
    next i
    if jlof=1 and q(nvx+2, 0)=q(nvx, 0) then
      jlof=0: gosub [cns]
    else
      jlof=0: iv=nvx+2
      for i=1 to nvr
        q(iv, i)=2*q(nvx+1, i)-q(nvx, i)
      next i
      ii=iv: gosub [hit]: q(iv, 0)=s
      if q(iv, 0)>q(nvx, 0) then
        gosub [cns]
      else
        if q(iv, 0)<q(1, 0) then
          iv=nvx+3: nexp=2
          while xflag=0
            for i=1 to nvr
              q(iv, i)=(nexp+1)*q(nvx+1, i)- nexp*q(nvx, i)
            next i
            ii=iv: gosub [hit]: q(iv, 0)=s
            if q(iv, 0)<q(iv-1, 0) then
              for i=0 to nvr
                q(iv-1, i)=q(iv, i)
              next i
            else
              xflag=1
            end if
          wend
          for i=0 to nvr
            q(nvx, i)=q(nvx+2, i)
          next i
        else
          jlof=1
          for i=0 to nvr
            q(nvx, i)=q(nvx+2, i)
          next i
        end if
      end if
    end if
    gosub [sort]
  wend
  if kk=2 then
    #1.tx1 "phi = "; using("##.##", 0-q(1, 1)/100)
    #1.tx2 "tns = "; using("##.##", q(1, 2))
    #1.tx3 "dev = "; using("##.##", q(1, 0))
  else
    #1.tx1 "a = "; using("###.###", q(1, 1))
    #1.tx2 "b = "; using("###.###", q(1, 2))
    #1.tx3 "c = "; using("###.###", q(1, 3))
  end if
goto [waitHere]

[sort]                                               ' Sort routine
  sw=1
  while sw>0
    sw=0
    for i=1 to nvr
      if q(i, 0)>q(i+1, 0) then
        sw=sw+1
        for j=0 to nvr
          temp=q(i, j): q(i, j)=q(i+1, j): q(i+1, j)=temp
        next j
      end if
    next i
  wend
  if kk=2 then
    x1=48-int((58+q(1, 1)/100)*400/22): y1=242-int((q(1, 2)-40)*230/12)
    x2=48-int((58+q(2, 1)/100)*400/22): y2=242-int((q(2, 2)-40)*230/12)
    x3=48-int((58+q(3, 1)/100)*400/22): y3=242-int((q(3, 2)-40)*230/12)
    #1 "color blue ; place "; x1; " "; y1
    #1 "goto "; x2; " "; y2: #1 "goto "; x3; " "; y3
    #1 "goto "; x1; " "; y1: #1 "color red"
  end if
return

[cns]                                                ' Shrink simplex
  iv=nvx+2
  for i=1 to nvr
    q(iv, i)=(q(nvx+1, i)+q(nvx, i))/2
  next i
  ii=iv: gosub [hit]: q(iv, 0)=s
  if q(iv, 0)<q(nvx, 0) then
    for i=0 to nvr
      q(nvx, i)=q(iv, i)
    next i
  else
    for i=1 to nvr
      for j=2 to nvx
        q(j, i)=(q(1, i)+q(j, i))/2
      next j
    next i
    for ii=2 to nvx
      gosub [hit]: q(ii, 0)=s
    next ii
  end if
return

[ang]                                                ' Find optimum angle
  dph=0-256
  while abs(dph)>1
    phi=phi+dph: so=s: gosub [hit]
    if s>so then dph=0-dph/2
  wend
  phi=phi+2*dph: gosub [hit]
return

[hit]                                                ' Trace out string
  if kk=3 then
    a=q(ii, 1): b=q(ii, 2): c=q(ii, 3)               ' Catenary constants
    x=(10-a)/c: y1=b+c/2*(exp(x)+exp(0-x))-230
    x=(250-a)/c: y2=b+c/2*(exp(x)+exp(0-x))-110
    x=(250-a)/c: y=(10-a)/c
    y3=c/2*(exp(x)-exp(0-x)-exp(y)+exp(0-y))-400
    s=(y1*y1+y2*y2+y3*y3)^.5
  else
    x=10: y=10:  t=tns                               ' First angle & tension
    if kk=2 then phi=q(ii,1): t=q(ii, 2)
    p=phi*pi/18000: tn=tan(p): tc=t*cos(p)
    x=x+d*cos(p): y=y-d*sin(p)
    #1 "place "; 48-int((58+phi/100)*400/22); " "; 242-int((t-40)*230/12)
    #1 "circlefilled 5"
    for i=1 to n                                     ' Loop
      tn=tn+1/tc: p=atn(tn): t=tc/cos(p)             ' Next angle & tension
      x=x+d*cos(p): y=y-d*sin(p)
    next i
    s=((x-250)*(x-250)+(y-130)*(y-130))^.5           ' Deviation
  end if
return

[quit]
  close #1
end