Attribute VB_Name = "Module1"
'*******************************************************
'*                  3D  SURFACES                       *
'* --------------------------------------------------- *
'* This program draws 3D surfaces defined by equations *
'* Z = F(X,Y) by using unit graph_3d.pas.              *
'* --------------------------------------------------- *
'* SAMPLE RUN:                                         *
'* ( Draw the surface defined by:                      *
'*   Z = 8 sin(sqrt(X*X+Y*Y))/sqrt(X*X+Y*Y) )          *
'*                                                     *
'*  Input intervals [x1,x2] and [y1,y2]:               *
'*    X1 X2 = -10 10                                   *
'*    Y1 Y2 = -10 10                                   *
'*  Number of lines ..........: 100                    *
'*  Number of points per line : 100                    *
'*  Real or uniform view (r/u): u                      *
'*                                                     *
'*  Choice of projection type:                         *
'*  =========================                          *
'*    1. real perspective                              *
'*    2. ordinary parallel                             *
'*    3. Dimetric parallel                             *
'*    4. isometric parallel                            *
'*                                                     *
'*  Your choice (1 to 4): 4                            *
'* --------------------------------------------------- *
'* Ref.: "Graphisme dans le plan et dans l'espace en   *
'*        Turbo Pascal 4.0 By R. Dony, MASSON Paris,   *
'*        1990" [BIBLI 12].                            *
'*                                                     *
'*          Visual Basic Release By J-P Moreau, Paris. *
'*                      (www.jpmoreau.fr)              *
'*******************************************************
DefInt I-N

Dim LimX As Integer      'Dimensions in pixels of graphic zone
Dim LimY As Integer

Dim Hmax() As Integer
Dim Hmin() As Integer

Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single
Dim incx As Single
Dim incy As Single
Dim f1 As Single
Dim f2 As Single
Dim f3 As Single
Dim f4 As Single
Dim ic1 As Integer
Dim ic2 As Integer
Dim ic3 As Integer
Dim ic4 As Integer
Dim echx As Single
Dim echy As Single
Dim ech As Single
Dim xg As Integer
Dim yg As Integer
Dim xd As Integer
Dim yd As Integer

Dim nbrelignes As Integer
Dim nbrepoints As Integer

Public vue As String
Public example As Integer

'Hidden segments not removed
Sub DessinFonct()
  Dim x As Single
  Dim y As Single
  Dim z As Single
  Dim ligne As Integer
  Dim point As Integer
  For ligne = 0 To nbrelignes
    If ligne > nbrelignes / 2 Then
      Form1.ForeColor = RGB(255, 0, 0)
    End If
    y = y2 - ligne * incy
    x = x1
    z = F(x, y)
    Project x, y, z
    xcour = Int((xproj - f1) * echx) + ic1
    ycour = Int((yproj - f3) * echy) + ic3
    For point = 0 To nbrepoints
      x = x1 + point * incx
      z = F(x, y)
      Project x, y, z
      xecran = Int((xproj - f1) * echx) + ic1
      yecran = Int((yproj - f3) * echy) + ic3
      Form1.Line (xcour, LimY - ycour)-(xecran, LimY - yecran)
      xcour = xecran: ycour = yecran
    Next point
  Next ligne
  Form1.ForeColor = RGB(0, 0, 0)
End Sub


Function F(x As Single, y As Single) As Single
  XMacheps = 0.0000000001
  Select Case example
    Case 1
      F = 5# * Sin(x) * Sin(y)
    Case 2
      F = x * x + y * y
    Case 3
      xk = Sqr(x * x + y * y)
      If Abs(xk) > XMacheps Then
        F = 8# * Sin(xk) / xk
      Else
        F = 8#
      End If
    Case 4
      w1 = 4 * (x - 2) * (x - 2) + (y - 4) * (y - 4) - 1
      w2 = (x - 5) * (x - 5) / 9 + 4 * (y - 2) * (y - 2) - 1
      w3 = (x - 5) * (x - 5) / 9 + 4 * (y - 6) * (y - 6) - 1
      If w1 > 85 Then w1 = 85
      If w2 > 85 Then w2 = 85
      If w3 > 85 Then w3 = 85
      F = w1 * w1 * Exp(-w1) + w2 * w2 * Exp(-w2) + w3 * w3 * Exp(-w3)
  End Select
End Function


Function Signe(x As Single) As Integer
  If x > 0 Then
    Signe = 1
  ElseIf x < 0 Then
    Signe = -1
  Else
    Signe = 0
  End If
End Function

Sub Data()
    'Intervals [x1,x2] and [y1,y2]
    x1 = Form2.Text7: x2 = Form2.Text8
    y1 = Form2.Text10: y2 = Form2.Text11
    'Number of lines
    nbrelignes = Form2.Text2
    'Number of points per line
    nbrepoints = Form2.Text13
    'Real or uniform view (1=r/2=u)
    If Form2.text9 = 1 Then
      vue = "r"
    Else
      vue = "u"
    End If
    example = Form2.Text12
    'Choice of projection type
    '=========================
    '1=real perspective
    '2=ordinary parallel
    '3=dimetric parallel
    '4=isometric parallel
    ichoice = Form2.Text1
    de = Form2.Text4
    projection = 2  'parallel
    
    If ichoice = 1 Then
      rho = Form2.Text3
      theta = Form2.Text5
      phi = Form2.Text6
      projection = 1  'Perspective
    ElseIf ichoice = 2 Then
      theta = Form2.Text5
      phi = Form2.Text6
    ElseIf ichoice = 3 Then
      theta = 22.20765
      phi = 20.704811
    Else  'ichoice=4
      de = 1#
      theta = 45#
      phi = 35.26439
    End If
End Sub

Sub Init()
  incx = (x2 - x1) / nbrepoints
  incy = (y2 - y1) / nbrelignes
  ic1 = 1: ic2 = LimX: ic3 = 1: ic4 = LimY
  f1 = 10000000000#: f2 = -f1: f3 = f1: f4 = -f1
  xg = -1: yg = -1: xd = -1: yd = -1
  For i = 0 To LimX
    Hmax(i) = 0
    Hmin(i) = LimY
  Next i
  If theta < 0# Or theta > 180# Then
    aux = x1: x1 = x2: x2 = aux: incx = -incx
    aux = y1: y1 = y2: y2 = aux: incy = -incy
  End If
End Sub

Sub Fenetre()
  Dim ligne As Integer
  Dim point As Integer
  Dim x As Single
  Dim y As Single
  Dim z As Single
  For ligne = 0 To nbrelignes
    y = y2 - ligne * incy
    For point = 0 To nbrepoints
      x = x1 + point * incx
      z = F(x, y)
      Project x, y, z
      If xproj < f1 Then f1 = xproj
      If xproj > f2 Then f2 = xproj
      If yproj < f3 Then f3 = yproj
      If yproj > f4 Then f4 = yproj
    Next point
  Next ligne
End Sub

Sub Echelles()
  echx = (ic2 - ic1) / (f2 - f1)
  echy = (ic4 - ic3) / (f4 - f3)
  If vue = "r" Then
    If echx < echy Then echy = echx
  Else
    echx = echy
  End If
End Sub

Function Max(ix1, ix2)
  If ix1 > ix2 Then
    Max = ix1
  Else
    Max = ix2
  End If
End Function

Function Min(ix1, ix2)
  If ix1 < ix2 Then
    Min = ix1
  Else
    Min = ix2
  End If
End Function

Function ICheck(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer)
  If x1 > 0 And x1 <= LimX And x2 > 0 And x2 < LimX And y1 > 0 And y1 <= LimY And y2 > 0 And y2 <= LimY Then
    ICheck = 1
  Else
    ICheck = 0
  End If
End Function

Sub Horizon(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer)
  Dim x As Integer
  Dim y As Integer
  Dim dx As Integer
  Dim pente As Single
  dx = Signe(x2 - x1)
  If dx = 0 Or ICheck(x1, y1, x2, y2) = 0 Then
    Hmax(x2 + 1) = Max(Hmax(x2), y2)
    Hmin(x2 + 1) = Min(Hmin(x2), y2)
  Else
    pente = (y2 - y1) / (x2 - x1)
    For x = x2 + 1 To x1
      y = Int(pente * (x - x1) + y1)
      Hmax(x) = Max(Hmax(x), y)
      Hmin(x) = Min(Hmin(x), y)
    Next x
  End If
End Sub

Sub Visibilite(ByVal x As Integer, ByVal y As Integer, ByRef visi As Integer)
  If y < Hmax(x) And y > Hmin(x) Then
    visi = 0
  ElseIf y >= Hmax(x) Then
    visi = 1
  Else
    visi = -1
  End If
End Sub




Sub Inter1(ByVal x1 As Integer, ByVal y1 As Integer, ByVal x2 As Integer, ByVal y2 As Integer, ITabaux(), ByRef xi As Integer, ByRef yi As Integer)
  Dim ct1 As Single
  Dim ct2 As Single
  Dim p1 As Single
  Dim p2 As Single
  Dim xii As Single
  Dim yii As Single
  
  If x2 - x1 = 0 Or ICheck(x1, y1, x2, y2) = 0 Then
    xii = 1! * x2
    yii = 1! * ITabaux(x2)
  Else
    p1 = (y2 - y1) / (x2 - x1): p2 = (ITabaux(x2) - ITabaux(x1)) / (x2 - x1)
    If Abs(p1) > 0.0000000001 And Abs(p1 - p2) > 0.0000000001 Then
      ct1 = y1 - p1 * x1: ct2 = ITabaux(x1) - p2 * x1
      yii = (p1 * ct2 - p2 * ct1) / (p1 - p2)
      xii = (yii - ct1) / p1
    Else
      xii = 1! * x2
      yii = 1! * y2
    End If
  End If
  xi = Int(xii)
  yi = Int(yii)
  
End Sub

  
Sub AreteFermeture(ByVal x As Integer, ByVal y As Integer, ByRef xlateral As Integer, ByRef ylateral As Integer)
  If xlateral <> -1 Then Horizon xlateral, ylateral, x, y
  xlateral = x
  ylateral = y
End Sub

'Hidden segments removed
Sub DessinFonction()
  Dim x As Single
  Dim y As Single
  Dim z As Single
  Dim ligne As Integer
  Dim point As Integer
  Dim xi As Integer
  Dim yi As Integer
  Dim xprec As Integer
  Dim yprec As Integer
  Dim xcour As Integer
  Dim ycour As Integer
  Dim visicour As Integer
  Dim visiprec As Integer
  For ligne = 0 To nbrelignes
    y = y2 - ligne * incy
    x = x1
    z = F(x, y)
    Project x, y, z
    xprec = Int((xproj - f1) * echx) + ic1
    yprec = Int((yproj - f3) * echy) + ic3
    AreteFermeture xprec, yprec, xd, yd
    Visibilite xprec, yprec, visiprec
    For point = 0 To nbrepoints
      x = x1 + point * incx
      z = F(x, y)
      Project x, y, z
      xcour = Int((xproj - f1) * echx) + ic1
      ycour = Int((yproj - f3) * echy) + ic3
      Visibilite xcour, ycour, visicour
      If Hmax(xcour) = 0 Or Hmin(xcour) = LimY Then
        visicour = visiprec
      End If
      If visicour = visiprec Then
        If visicour = 1 Or visicour = -1 Then
          If ICheck(xprec, LimY - yprec, xcour, LimY - ycour) = 1 Then
            Form1.Line (xprec, LimY - yprec)-(xcour, LimY - ycour)
            Horizon xprec, yprec, xcour, ycour
          End If
        End If
      Else
        If visicour = 0 Then
          If visiprec = 1 Then
            Inter1 xprec, yprec, xcour, ycour, Hmax(), xi, yi
          Else
            Inter1 xprec, yprec, xcour, ycour, Hmin(), xi, yi
          End If
          If ICheck(xprec, LimY - yprec, xi, LimY - yi) = 1 Then
            Form1.Line (xprec, LimY - yprec)-(xi, LimY - yi)
            Horizon xprec, yprec, xi, yi
          End If
        Else
          If visicour = 1 Then
            If visiprec = 0 Then
              Inter1 xprec, yprec, xcour, ycour, Hmax(), xi, yi
              If ICheck(xi, LimY - yi, xcour, LimY - ycour) = 1 Then
                Form1.Line (xi, LimY - yi)-(xcour, LimY - ycour)
                Horizon xi, yi, xcour, ycour
              End If
            Else
              Inter1 xprec, yprec, xcour, ycour, Hmin(), xi, yi
              If ICheck(xprec, LimY - yprec, xi, LimY - yi) = 1 Then
                Form1.Line (xprec, LimY - yprec)-(xi, LimY - yi)
                Horizon xprec, yprec, xi, yi
              End If
              Inter1 xprec, yprec, xcour, ycour, Hmax(), xi, yi
              If ICheck(xi, LimY - yi, xcour, LimY - ycour) = 1 Then
                Form1.Line (xi, LimY - yi)-(xcour, LimY - ycour)
                Horizon xi, yi, xcour, ycour
              End If
            End If
          Else
            If visiprec = 0 Then
              Inter1 xprec, yprec, xcour, ycour, Hmin(), xi, yi
              If ICheck(xi, LimY - yi, xcour, LimY - ycour) = 1 Then
                Form1.Line (xi, LimY - yi)-(xcour, LimY - ycour)
                Horizon xi, yi, xcour, ycour
              End If
            Else
              Inter1 xprec, yprec, xcour, ycour, Hmax(), xi, yi
              If ICheck(xprec, LimY - yprec, xi, LimY - yi) = 1 Then
                Form1.Line (xprec, LimY - yprec)-(xi, LimY - yi)
                Horizon xprec, yprec, xi, yi
              End If
              Inter1 xprec, yprec, xcour, ycour, Hmin(), xi, yi
              If ICheck(xi, LimY - yi, xcour, LimY - ycour) = 1 Then
                Form1.Line (xi, LimY - yi)-(xcour, LimY - ycour)
                Horizon xi, yi, xcour, ycour
              End If
            End If
          End If
        End If  'if visicour=0
      End If  'if visicour=visiprec
      visiprec = visicour
      xprec = xcour
      yprec = ycour
    Next point
    AreteFermeture xcour, ycour, xg, yg
  Next ligne
End Sub

Sub Affiche()
  Form1.ForeColor = RGB(0, 0, 0)  'black pen
  'aux$,ch$,s$: string
  'str(x1:4:1,aux); ch:=Concat('X=[',aux,',');
  aux$ = Str(x1): ch$ = "X=[" + aux$ + ","
  'str(x2:4:1,aux); ch:=Concat(ch,aux,']   ');
  aux$ = Str(x2): ch$ = ch$ + aux$ + "]   "
  'str(y1:4:1,aux); ch:=Concat(ch,'Y=[',aux,',');
  aux$ = Str(y1): ch$ = ch$ + "Y=[" + aux$ + ","
  'str(y2:4:1,aux); ch:=Concat(ch,aux,']   ');
  aux$ = Str(y2): ch$ = ch$ + aux$ + "]   "
  If projection = 1 Then
    'str(rho:4:1,aux); ch:=Concat(ch,'Rho=',aux,'  ')
    aux$ = Str(rho): ch$ = ch$ + "Rho=" + aux$ + "  "
  End If
  'str(theta:5:3,aux); ch:=Concat(ch,'Theta=',aux,'  ');
  aux$ = Str(theta): ch$ = ch$ + "Theta=" + aux$ + "  "
  'str(phi:5:3,aux); ch:=Concat(ch,'Phi=',aux,'  ');
  aux$ = Str(phi): ch$ = ch$ + "Phi=" + aux$ + "  "
  'StrPCopy(s,ch);
  'TextOut(CrtDc,20,5,s,strlen(s));
  Form1.CurrentX = 150: Form1.CurrentY = 150
  Form1.Print ch$
  'str(nbrelignes:2,aux); ch:=Concat('( ',aux,' lines','  ');
  aux$ = Str(nbrelignes): ch$ = "(" + aux$ + " lines  "
  'str(nbrepoints:3,aux); ch:=Concat(ch,aux,' pts per line )');
  aux$ = Str(nbrepoints): ch$ = ch$ + aux$ + " pts per line)"
  Form1.CurrentX = 150: Form1.CurrentY = 400
  Form1.Print ch$
End Sub

'main subroutine
Sub DrawSurface()
  MaxX = Form1.Width - 250: MaxY = Form1.Height - 1500
  LimX = MaxX: LimY = Int(0.8 * MaxY)
  ReDim Hmin(0 To 2 * LimX)
  ReDim Hmax(0 To 2 * LimX)
  ReDim ITabaux(0 To 2 * LimX)
  Data
  Init
  InitProj
  Fenetre
  Echelles
  Form1.Cls
  DessinFonction
  Affiche
End Sub