home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / bp_4_94 / vbwin / sirds / sirds.txt < prev    next >
Text File  |  1995-02-26  |  10KB  |  269 lines
  1. Option Explicit
  2.  
  3. Sub Abbruch ()
  4.   ' Dieses passiert, wenn kein 256-Farbenmodus eingestellt ist.
  5.   Dim Text As String, Titel As String
  6.   Text = "Leider haben Sie keinen 256-Farbenmodus eingestellt."
  7.   Text = Text + " WΣhlen Sie bitte einen Super-VGA-Modus mit 256 Farben aus." + Chr$(13)
  8.   Text = Text + " Starten Sie Windows erneut."
  9.   Text = Text + " Versuchen Sie es dann nochmal!"
  10.   Text = Text + Chr$(13)
  11.   Text = Text + Space$(27) + "Viel Spa▀ beim Sirdsen."
  12.   MsgBox Text, 0, Titel
  13.   End
  14. End Sub
  15.  
  16. ' Die Ausgabe einer Zeile des SIRDS erfolgt hier
  17. Static Sub Ausgabe (Y%, Stereo() As Integer)
  18. Dim X%
  19. For X% = 0 To Form2.bldBild.ScaleWidth
  20.   form3.bldSirds.PSet (X%, Y%), QBColor(Stereo(X%)) ' Gibt den endgültigen SIRDS-Pixel aus.
  21. Next X%
  22. End Sub
  23.  
  24. Sub Form_Load ()
  25. Dim Ergebnis%
  26.    ' Mit der GDI-Funktion "GetDeviceCaps()" wird ⁿberprⁿft,
  27.    ' ob ein 256-Farbenmodus eingestellt ist.
  28.    ' Wenn ein anderer eingestellt ist, wird das Programm
  29.    ' mit der Prozedur "Abbruch" beendet.
  30.    Ergebnis% = GetDeviceCaps(Form1.hDC, 24)
  31.    If Ergebnis% <> 20 Then Call Abbruch
  32.    ' Die Skalierungsart wird auf natⁿrliche Pixel festgelegt.
  33.    Form2.bldBild.ScaleMode = 3
  34.    form3.bldSirds.ScaleMode = 3
  35.    ' Die Menuepunkte "Sirds" und "Speichern" werden zunΣchst deaktiviert.
  36.    mnuSirds.Enabled = False
  37.    mnuSpeichern.Enabled = False
  38. End Sub
  39.  
  40. ' Ermittelt den Blauanteil der RGB-Farbe.
  41. Function GetBlue (FarbWert As Long) As Integer
  42.   GetBlue = (FarbWert And &HFF&)
  43. End Function
  44.  
  45. ' Ermittelt den Grⁿnanteil der RGB-Farbe.
  46. Function GetGreen (FarbWert As Long) As Integer
  47.   GetGreen = (FarbWert And &HFF00&) \ 256
  48. End Function
  49.  
  50.  
  51. ' Ermittelt den Rotanteil der RGB-Farbe.
  52. Function GetRed (FarbWert As Long) As Integer
  53.   GetRed = (FarbWert And &HFF0000) \ 65536
  54. End Function
  55.  
  56.  
  57. ' Der Algorithmus fⁿr die Korrelationsberechnung erfolgt mit MacheKorrel(). Dabei wird das von Scannen
  58. ' erzeugte Feld Tiefe() umgerechnet
  59. Static Sub MacheKorrel (Tiefe() As Integer, Korrel() As Integer, AugeAbst As Single, Aufloesung As Integer)
  60. Dim l%, S%, Sl%, Sr%, Sichtbar%, X%, dx%, Vor%, zt%, E!, konst!, z!
  61. ' Das Feld Korrel() wird auf "nicht korreliert" gesetzt.
  62. For X% = 0 To Form2.bldBild.ScaleWidth
  63.   Korrel(X%) = X%
  64. Next X%
  65.  
  66. E! = AugeAbst! * Aufloesung%    ' Der Augenabstand wird in Anzahl der Pixel umgerechnet.
  67. konst! = 2 / (zSkal! * p! * E!)
  68. ' Hier beginnt der Algorithmus.
  69. For X% = 0 To Form2.bldBild.ScaleWidth
  70.  
  71. ' Kernberechnung des Algorithmus.
  72.   Vor% = Tiefe(X%)
  73.   z! = Vor% * zSkal!   ' Normierung der Farbwerte zwischen 0 und 1.
  74.   S% = (1 - p! * z!) * E! / (2 - p! * z!)  ' Die Berechnung von S.
  75.   Sl% = X% - S% / 2                        ' Berechnung des linken Stereopunktes.
  76.   Sr% = Sl% + S%                           ' Berechnung des rechten Stereopunktes.
  77.  
  78. ' Weiter, wenn Stereopunkte beide im Abbildungsbereich (Bildschirm) liegen.
  79.   If 0 <= Sl% And Sr% < Form2.bldBild.ScaleWidth Then
  80.  
  81. ' Teil des Algorithmus, der ⁿberprⁿft, ob der betrachtete Punkt überhaupt fürs Auge sichtbar ist.
  82. ' Hidden-Pixel Algorithmus. Siehe dazu Ausfⁿhrung im Text.
  83.     dx% = 1
  84.     Do
  85.       zt% = Vor% + (2 - p! * z!) * dx% * konst!
  86.       Sichtbar% = Tiefe(X% - dx%) < zt%
  87.       If Sichtbar% Then
  88.         Sichtbar% = Tiefe(X% + dx%) < zt%
  89.       End If
  90.       dx% = dx% + 1
  91.     Loop Until Not Sichtbar% Or zt% > zSkal!
  92.  
  93. ' Teil des Algorithmus, der die Randbedingungen berⁿcksichtigt.
  94. ' Lesen Sie dazu die Ausfⁿhrungen im Text.
  95.    If Sichtbar Then
  96.      l% = Korrel(Sl%)
  97.      While l% <> Sl% And l% <> Sr%
  98.        If l% < Sr% Then
  99.          Sl% = l%
  100.          l% = Korrel(Sl%)
  101.        Else
  102.          Korrel(Sl%) = Sr%
  103.          Sl% = Sr%
  104.          Sr% = l%
  105.          l% = Korrel(Sl%)
  106.        End If
  107.      Wend
  108.       Korrel(Sl%) = Sr%       ' Hier wird die Kernzuweisung gemacht,
  109.                               ' wobei die Korrelierung festgelegt wird.
  110.     End If
  111.   End If
  112. Next X%
  113. End Sub
  114.  
  115. ' Diese Procedur setzt die im Feld Korrel() enthaltenen Korrelationsinformationen um und
  116. ' setzt die Farbwerte der auszugebenen SIRDS-Zeile in das Feld Stereo() ein.
  117. Static Sub MacheSirds (Stereo() As Integer, Korrel() As Integer)
  118. Dim X%, Farbe%
  119. For X% = Form2.bldBild.ScaleWidth To 0 Step -1
  120.   Farbe% = Int(15 * Rnd) ' Die Zufallsfarbe wird generiert.
  121. ' Wenn keine Korrelierung vorliegt, dann wird einfach die Zufallsfarbe gesetzt.
  122.    If Korrel(X%) = X% Then
  123.      Stereo(X%) = Farbe%
  124.    Else
  125. ' Liegt Korrelierung vor, so setzte die gleiche Farbe wie die des anderen Stereopunktes.
  126.      Stereo(X%) = Stereo(Korrel(X%))
  127.    End If
  128. Next X%
  129. End Sub
  130.  
  131. Sub mnuEnde_Click ()
  132. ' Das Programm wird hiermit beendet.
  133. End
  134. End Sub
  135.  
  136. Sub mnuInfo_Click ()
  137.   ' Was soll noch mehr gesagt werden?
  138.   Dim Text As String, Titel As String
  139.   Titel = "▄ber das Programm"
  140.   Text = Space$(4) + "*** Sirdsbild Version 94 ***" + Chr$(13)
  141.   Text = Text + Chr$(13)
  142.   Text = Text + " Haben Sie schon Kopfschmerzen?"
  143.   Text = Text + Chr$(13)
  144.   Text = Text + Space$(4) + "<Jⁿrgen Riedel, 30.11.94>"
  145.   Text = Text + Chr$(13)
  146.   Text = Text + Space$(4) + "<CompuServe: 100422,1063>"
  147.   MsgBox Text, 0, Titel
  148. End Sub
  149.  
  150. Sub mnu╓ffnen_Click ()
  151.   Dim CancelFlag%
  152.   On Local Error GoTo ErrorRoutine
  153.   ' True legt hier fest, da▀ das BetΣtigen der AbbruchflΣche zum Laufzeitfehler
  154.   ' mit der Nummer 32755 fⁿhrt.
  155.   CMDialog1.CancelError = True
  156.   ' Setzten der Standardflags (Windowsvorgabe).
  157.   CMDialog1.Flags = AufDefault
  158.   ' Festlegen des Titels der Dialogbox.
  159.   CMDialog1.DialogTitle = "Bitmap ╓ffnen"
  160.   ' Es werden nur die Dateien mit der Endung ".bmp" angezeigt.
  161.   CMDialog1.Filter = "Bitmaps (*.bmp)|*.bmp"
  162.   ' Der Commen Dialog wird auf "laden" gesetzt.
  163.   CMDialog1.Action = 1
  164.   ' Wird nichts ausgewΣhlt, dann raus aus der Prozedur.
  165.   If CMDialog1.Filename = "" Then Exit Sub
  166.   ' Es ist kein "Fehler" aufgetreten.
  167.   If CancelFlag = 0 Then
  168.     ' Die Form "Eingabe.frm" wird der Gr÷▀e der geladenen Bitmap
  169.     ' angeglichen.
  170.     Form2.bldBild.AutoSize = True
  171.     ' Laden des Bitmap ins Bildfenster.
  172.     Form2.bldBild.Picture = LoadPicture(CMDialog1.Filename)
  173.     Form2.Width = Form2.bldBild.Width
  174.     Form2.Height = Form2.bldBild.Height
  175.     Form2.Show
  176.     ' Menuepunkt "Sirds" wird aktiviert.
  177.     mnuSirds.Enabled = True
  178.   End If
  179.   Exit Sub
  180. ErrorRoutine:
  181.   ' Ist der Laufzeitfehler aufgetreten, dann geschieht folgendes.
  182.   If Err = 32755 Then ' Vergleiche oben.
  183.     CancelFlag = -1
  184.   End If
  185.   ' Erm÷glicht die verz÷gerte Fehkerbehandlung
  186.   ' ⁿber die Variable "Err".
  187.   Resume Next
  188. End Sub
  189.  
  190. Sub mnuSirds_Click ()
  191. ' Deklarationsteil der Variablen.
  192. Dim Y%, Prozent%
  193. Static FarbWert As Long, Farbe As Long, R As Integer, B As Integer, G As Integer
  194. ' Menuepunkt "╓ffnen" wird deaktiviert.
  195. mnu╓ffnen.Enabled = False
  196. ' Die Form "Ausgabe.frm" wird verdeckt
  197. Load form3
  198. form3.Hide
  199. ' Die Form "Ausgabe.frm" wird dimensioniert.
  200. form3.bldSirds.Left = (form3.Width - Form2.bldBild.Width) / 2
  201. form3.bldSirds.Top = (form3.Height - Form2.bldBild.Height) / 2
  202. form3.bldSirds.Width = Form2.bldBild.Width
  203. form3.bldSirds.Height = Form2.bldBild.Height
  204. ' Die folgenden Felder werden dimensioniert.
  205. ReDim Tiefe(Form2.bldBild.ScaleWidth)
  206. ReDim Korrel(Form2.bldBild.ScaleWidth)
  207. ReDim Stereo(Form2.bldBild.ScaleWidth)
  208. Form2.Show
  209. frmLabel.Caption = " Sirdsberechnung: "
  210. ' Die Schleife fⁿr die abzuarbeitenden Bildzeilen.
  211. For Y% = 0 To Form2.bldBild.ScaleHeight ' 0 bis Anzahl der Zeilen der geladenden Bitmap
  212.   ' Reagiere auf Ereignisse.
  213.   DoEvents
  214.   ' Zeigt die schon abgearbeiteten Zeilen in Prozent an.
  215.   Prozent% = Y% / Form2.bldBild.ScaleHeight * 100
  216.   frmProzent.Caption = Str$(Prozent%) + "%"
  217.   ' Aufruf der einzelnen Unterroutinen.
  218.   Form2.Show
  219.   Call Scannen(Y%, Tiefe())
  220.   Call MacheKorrel(Tiefe(), Korrel(), 2.5, 72)
  221.   Call MacheSirds(Stereo(), Korrel())
  222.   Call Ausgabe(Y%, Stereo())
  223. Next Y%
  224. ' Zeige das Sirdsbild.
  225. form3.bldSirds.Picture = form3.bldSirds.Image
  226. form3.Show
  227. ' Mennuepunkte "╓ffnen" und "Speichern" werden aktiviert.
  228. mnuSpeichern.Enabled = True
  229. mnu╓ffnen.Enabled = True
  230. mnuSirds.Enabled = False
  231. End Sub
  232.  
  233. Sub mnuSpeichern_Click ()
  234.   On Error Resume Next
  235.   form3.bldSirds.Picture = form3.bldSirds.Image
  236.   ' Siehe Kommentare zu "mnu╓ffnen".
  237.   CMDialog1.CancelError = True
  238.   CMDialog1.Flags = ZuDefault
  239.   CMDialog1.DialogTitle = "Datei speichern unter"
  240.   CMDialog1.Filter = "Bitmaps (*.bmp)|*.bmp"
  241.   CMDialog1.DefaultExt = "bmp"
  242.   CMDialog1.Filename = "*.bmp"
  243.   ' Setzten des Commen Dialog auf "speichern".
  244.   CMDialog1.Action = 2
  245.   ' Ist kein Fehler aufgetren, dann speichere das Bild.
  246.   If Err = 0 Then
  247.     SavePicture form3.bldSirds.Picture, CMDialog1.Filename
  248.   End If
  249.   ' Die Menuepunkte "Speichern", "╓ffnen" und "Sirds" werden deaktiviert.
  250.   mnuSpeichern.Enabled = False
  251.   mnu╓ffnen.Enabled = False
  252.   mnuSirds.Enabled = False
  253. End Sub
  254.  
  255. Static Sub Scannen (Y%, Tiefe() As Integer)
  256.   Static FarbWert As Long, R As Integer, B As Integer, G As Integer
  257.   Dim X%
  258.   ' Einlesen der RGB-Farbwerte einer Bitmapzeile.
  259.   For X% = 0 To Form2.bldBild.ScaleWidth
  260.     FarbWert = Form2.bldBild.Point(X%, Y%) ' Farbwert des aktuellen Pixels wird eingelesen.
  261.     ' Umrechnung der RGB-Farbwerte in 256 Graustufen.
  262.     ' Tip: Probieren Sie doch andere Gewichtungsfaktoren aus.
  263.     ' Die Gewichtungsfaktoren sind auf eine durchschnittliche
  264.     ' Farbempfindlichkeit eingestellt.
  265.     Tiefe(X%) = .3 * GetRed(FarbWert) + .59 * GetGreen(FarbWert) + .11 * GetBlue(FarbWert)
  266.   Next X%
  267. End Sub
  268.  
  269.