Home

Add

Edit

Without Linenumbers

Code in Textfield

Quellbilder: http://mln.ath.cx/fbt/


histogram.bas

  1. #INCLUDE Once "fbgfx.bi"
    
  2. 
    
  3. 
    
  4. 
    
  5. Function BMPLoad(V_FilePathName As String, Byref R_Width As Integer, Byref R_Height As Integer) As Any Ptr
    
  6. Dim TImg As Any Ptr
    
  7. If Open(V_FilePathName For Binary Access Read As #1) <> 0 Then Return 0
    
  8. Get #1, 19, R_Width
    
  9. Get #1, 23, R_Height
    
  10. Close #1
    
  11. TImg = Imagecreate(R_Width, Abs(R_Height))
    
  12. If TImg = 0 Then Return 0
    
  13. If Bload(V_FilePathName, TImg) <> 0 Then Imagedestroy(TImg): Return 0
    
  14. Return TImg
    
  15. End Function
    
  16. 
    
  17. 
    
  18. 
    
  19. Screenres 800, 600, 32
    
  20. Dim TImgW As Integer
    
  21. Dim TImgH As Integer
    
  22. Dim TImg As Any Ptr = BMPLoad("img1.bmp", TImgW, TImgH)
    
  23. If TImg = 0 Then Screen 0: Print "cant load img!": Sleep: End -1
    
  24. Dim THistCol() As Uinteger
    
  25. Redim THistCol(0 To &H00FFFFFF) As Uinteger
    
  26. 
    
  27. Dim THistR(0 To &H000000FF) As Uinteger
    
  28. Dim THistRC As Uinteger
    
  29. Dim THistG(0 To &H000000FF) As Uinteger
    
  30. Dim THistGC As Uinteger
    
  31. Dim THistB(0 To &H000000FF) As Uinteger
    
  32. Dim THistBC As Uinteger
    
  33. 
    
  34. Dim THistLineWR(0 To &H000000FF) As Uinteger
    
  35. Dim THistLineWRC As Uinteger
    
  36. Dim THistLineWG(0 To &H000000FF) As Uinteger
    
  37. Dim THistLineWGC As Uinteger
    
  38. Dim THistLineWB(0 To &H000000FF) As Uinteger
    
  39. Dim THistLineWBC As Uinteger
    
  40. 
    
  41. Dim THistLineHR(0 To &H000000FF) As Uinteger
    
  42. Dim THistLineHRC As Uinteger
    
  43. Dim THistLineHG(0 To &H000000FF) As Uinteger
    
  44. Dim THistLineHGC As Uinteger
    
  45. Dim THistLineHB(0 To &H000000FF) As Uinteger
    
  46. Dim THistLineHBC As Uinteger
    
  47. 
    
  48. Dim TImgPtr As Uinteger Ptr = TImg + Sizeof(FB.Image)
    
  49. Dim TCol As Uinteger
    
  50. 
    
  51. 'Histogram für gesammtbild
    
  52. For Y As Uinteger = 0 To TImgH - 1
    
  53.     For X As Uinteger = 0 To TImgW - 1
    
  54.         TCol = *(TImgPtr + Y * TImgW + X)
    
  55.         THistCol(TCol And &H00FFFFFF) += 1
    
  56.         THistR((TCol Shr 16) And 255) += 1
    
  57.         If THistRC < THistR((TCol Shr 16) And 255) Then THistRC += 1
    
  58.         THistG((TCol Shr 8) And 255) += 1
    
  59.         If THistGC < THistG((TCol Shr 8) And 255) Then THistGC += 1
    
  60.         THistB(TCol And 255) += 1
    
  61.         If THistBC < THistB(TCol And 255) Then THistBC += 1
    
  62.     Next
    
  63. Next
    
  64. 
    
  65. Dim TDif8 As Double
    
  66. Dim TPosY As Uinteger
    
  67. Dim TMR As Integer
    
  68. Dim TMX As Integer
    
  69. Dim TMY As Integer
    
  70. Do Until Inkey() = Chr(27)
    
  71.     TMR = Getmouse(TMX, TMY)
    
  72.     If (TMX >= 0) And (TMX < TImgW) And (TMY >= 0) And (TMY < TImgH) Then
    
  73.         THistLineHRC = 0
    
  74.         THistLineHGC = 0
    
  75.         THistLineHBC = 0
    
  76.         THistLineWRC = 0
    
  77.         THistLineWGC = 0
    
  78.         THistLineWBC = 0
    
  79.         For X As Uinteger = 0 To 255
    
  80.             THistLineHR(X) = 0
    
  81.             THistLineHG(X) = 0
    
  82.             THistLineHB(X) = 0
    
  83.             THistLineWR(X) = 0
    
  84.             THistLineWG(X) = 0
    
  85.             THistLineWB(X) = 0
    
  86.         Next
    
  87.         'Histogram für mauskoordinate erzeugen
    
  88.         For Y As Uinteger = 0 To TImgH - 1
    
  89.             TCol = *(TImgPtr + Y * TImgW + TMX)
    
  90.             THistLineHR((TCol Shr 16) And 255) += 1
    
  91.             If THistLineHRC < THistLineHR((TCol Shr 16) And 255) Then THistLineHRC += 1
    
  92.             THistLineHG((TCol Shr 8) And 255) += 1
    
  93.             If THistLineHGC < THistLineHG((TCol Shr 8) And 255) Then THistLineHGC += 1
    
  94.             THistLineHB(TCol And 255) += 1
    
  95.             If THistLineHBC < THistLineHB(TCol And 255) Then THistLineHBC += 1
    
  96.         Next
    
  97.         For X As Uinteger = 0 To TImgW - 1
    
  98.             TCol = *(TImgPtr + TMY * TImgW + X)
    
  99.             THistLineWR((TCol Shr 16) And 255) += 1
    
  100.             If THistLineWRC < THistLineWR((TCol Shr 16) And 255) Then THistLineWRC += 1
    
  101.             THistLineWG((TCol Shr 8) And 255) += 1
    
  102.             If THistLineWGC < THistLineWG((TCol Shr 8) And 255) Then THistLineWGC += 1
    
  103.             THistLineWB(TCol And 255) += 1
    
  104.             If THistLineWBC < THistLineWB(TCol And 255) Then THistLineWBC += 1
    
  105.         Next
    
  106.     End If
    
  107.     
    
  108.     'zeichnen
    
  109.     Screenlock()
    
  110.     Cls()
    
  111.     'bild
    
  112.     Put (0, 0), TImg, Pset
    
  113.     
    
  114.     'histogram gesammt rot
    
  115.     TPosY = 522
    
  116.     TDif8 = 32 / THistRC
    
  117.     Line (8, TPosY - 34)-(267, TPosY + 2), &H00880000, B
    
  118.     For X As Uinteger = 0 To 255
    
  119.         Line (10 + X, TPosY - (TDif8 * THistR(X)))-(10 + X, TPosY), &H00FF0000
    
  120.     Next
    
  121.     
    
  122.     'histogram gesammt grün
    
  123.     TPosY += 36
    
  124.     TDif8 = 32 / THistGC
    
  125.     Line (8, TPosY - 34)-(267, TPosY + 2), &H00008800, B
    
  126.     For X As Uinteger = 0 To 255
    
  127.         Line (10 + X, TPosY - (TDif8 * THistG(X)))-(10 + X, TPosY), &H0000FF00
    
  128.     Next
    
  129.     
    
  130.     'histogram gesammt blau
    
  131.     TPosY += 36
    
  132.     TDif8 = 32 / THistBC
    
  133.     Line (8, TPosY - 34)-(267, TPosY + 2), &H00000088, B
    
  134.     For X As Uinteger = 0 To 255
    
  135.         Line (10 + X, TPosY - (TDif8 * THistB(X)))-(10 + X, TPosY), &H000000FF
    
  136.     Next
    
  137. 
    
  138. 
    
  139. 
    
  140.     'histogram maus x rot
    
  141.     TPosY = TImgH + 32 + 5
    
  142.     TDif8 = 32 / THistLineWRC
    
  143.     Line (8, TPosY - 34)-(267, TPosY + 2), &H00550000, B
    
  144.     For X As Uinteger = 0 To 255
    
  145.         Line (10 + X, TPosY - (TDif8 * THistLineWR(X)))-(10 + X, TPosY), &H00FF0000
    
  146.     Next
    
  147.     
    
  148.     'histogram maus x grün
    
  149.     TPosY += 40
    
  150.     TDif8 = 32 / THistLineWGC
    
  151.     Line (8, TPosY - 34)-(267, TPosY + 2), &H00005500, B
    
  152.     For X As Uinteger = 0 To 255
    
  153.         Line (10 + X, TPosY - (TDif8 * THistLineWG(X)))-(10 + X, TPosY), &H0000FF00
    
  154.     Next
    
  155.     
    
  156.     'histogram maus x blau
    
  157.     TPosY += 40
    
  158.     TDif8 = 32 / THistLineWBC
    
  159.     Line (8, TPosY - 34)-(267, TPosY + 2), &H00000055, B
    
  160.     For X As Uinteger = 0 To 255
    
  161.         Line (10 + X, TPosY - (TDif8 * THistLineWB(X)))-(10 + X, TPosY), &H000000FF
    
  162.     Next
    
  163. 
    
  164. 
    
  165. 
    
  166.     'histogram maus y rot
    
  167.     TPosY = 36 + 5
    
  168.     TDif8 = 32 / THistLineHRC
    
  169.     Line (TImgW + 8, TPosY - 34)-(TImgW + 267, TPosY + 2), &H00550000, B
    
  170.     For X As Uinteger = 0 To 255
    
  171.         Line (TImgW + 10 + X, TPosY - (TDif8 * THistLineHR(X)))-(TImgW + 10 + X, TPosY), &H00FF0000
    
  172.     Next
    
  173.     
    
  174.     'histogram maus y grün
    
  175.     TPosY += 40
    
  176.     TDif8 = 32 / THistLineHGC
    
  177.     Line (TImgW + 8, TPosY - 34)-(TImgW + 267, TPosY + 2), &H00005500, B
    
  178.     For X As Uinteger = 0 To 255
    
  179.         Line (TImgW + 10 + X, TPosY - (TDif8 * THistLineHG(X)))-(TImgW + 10 + X, TPosY), &H0000FF00
    
  180.     Next
    
  181.     
    
  182.     'histogram maus y blau
    
  183.     TPosY += 40
    
  184.     TDif8 = 32 / THistLineHBC
    
  185.     Line (TImgW + 8, TPosY - 34)-(TImgW + 267, TPosY + 2), &H00000055, B
    
  186.     For X As Uinteger = 0 To 255
    
  187.         Line (TImgW + 10 + X, TPosY - (TDif8 * THistLineHB(X)))-(TImgW + 10 + X, TPosY), &H000000FF
    
  188.     Next
    
  189.     
    
  190.     
    
  191.     
    
  192.     Line (0, TMY)-(TImgW, TMY), &H00FFFFFF
    
  193.     Line (TMX, 0)-(TMX, TImgH), &H00FFFFFF
    
  194.     
    
  195.     Screenunlock()
    
  196.     Sleep 1, 1
    
  197. Loop
    
  198. Screen 0
    
  199. End 0
    



fft.bas

  1. '!!!! Compile with: fbc -l gslcblas <app>.bas
    
  2. 
    
  3. #INCLUDE Once "fbgfx.bi"
    
  4. #INCLUDE Once "gsl/gsl_fft_complex_float.bi"
    
  5. 
    
  6. #MACRO REAL(z,i)
    
  7.     z[2*(i)]
    
  8. #ENDMACRO
    
  9. 
    
  10. 
    
  11. 
    
  12. 
    
  13. Function BMPLoad(V_FilePathName As String, Byref R_Width As Integer, Byref R_Height As Integer) As Any Ptr
    
  14. Dim TImg As Any Ptr
    
  15. If Open(V_FilePathName For Binary Access Read As #1) <> 0 Then Return 0
    
  16. Get #1, 19, R_Width
    
  17. Get #1, 23, R_Height
    
  18. Close #1
    
  19. TImg = Imagecreate(R_Width, Abs(R_Height))
    
  20. If TImg = 0 Then Return 0
    
  21. If Bload(V_FilePathName, TImg) <> 0 Then Imagedestroy(TImg): Return 0
    
  22. Return TImg
    
  23. End Function
    
  24. 
    
  25. 
    
  26. 
    
  27. 
    
  28. Screenres 800, 600, 32
    
  29. Dim TImgW As Integer
    
  30. Dim TImgH As Integer
    
  31. Dim TImg As Any Ptr = BMPLoad("img1.bmp", TImgW, TImgH)
    
  32. If TImg = 0 Then Screen 0: Print "cant load img!": Sleep: End -1
    
  33. 
    
  34. Dim TImgPtr As Uinteger Ptr = TImg + Sizeof(FB.Image)
    
  35. Dim TCol As Uinteger
    
  36. 
    
  37. 
    
  38. Dim TBasisLineWR As Double Ptr = Callocate(Sizeof(Double) * 2 * TImgW)
    
  39. Dim TBasisLineWRC As Double
    
  40. Dim TBasisLineWG As Double Ptr = Callocate(Sizeof(Double) * 2 * TImgW)
    
  41. Dim TBasisLineWGC As Double
    
  42. Dim TBasisLineWB As Double Ptr = Callocate(Sizeof(Double) * 2 * TImgW)
    
  43. Dim TBasisLineWBC As Double
    
  44. 
    
  45. Dim TFFTW As Integer = 2 ^ (Len(Bin(TImgW)) - 1)
    
  46. Dim TFFTH As Integer = 2 ^ (Len(Bin(TImgH)) - 1)
    
  47. Dim TFFTLineWR As Double Ptr = Callocate(Sizeof(Double) * 2 * TImgW)
    
  48. Dim TFFTLineWRC As Double
    
  49. Dim TFFTLineWG As Double Ptr = Callocate(Sizeof(Double) * 2 * TImgW)
    
  50. Dim TFFTLineWGC As Double
    
  51. Dim TFFTLineWB As Double Ptr = Callocate(Sizeof(Double) * 2 * TImgW)
    
  52. Dim TFFTLineWBC As Double
    
  53. 
    
  54. Dim TFFTDif As Double = 1 / 255
    
  55. 
    
  56. Dim TDif8 As Double
    
  57. Dim TPosY As Uinteger
    
  58. Dim TMR As Integer
    
  59. Dim TMX As Integer
    
  60. Dim TMY As Integer
    
  61. Dim TMXL As Integer
    
  62. Dim TMYL As Integer
    
  63. Do Until Inkey() = Chr(27)
    
  64.     TMR = Getmouse(TMX, TMY)
    
  65.     If (TMX >= 0) And (TMX < TImgW) And (TMY >= 0) And (TMY < TImgH) Then
    
  66.         TFFTLineWRC = 0
    
  67.         TFFTLineWGC = 0
    
  68.         TFFTLineWBC = 0
    
  69.         'FFT daten array füllen (jede farbe wird seperat betrachtet und muss seperat berechnet werden)
    
  70.         For X As Uinteger = 0 To TImgW - 1
    
  71.             TCol = *(TImgPtr + TMY * TImgW + X)
    
  72.             'Die 'Basis' zeigt den Wert der einzelnen Farbe am entsprechendem Pixel. Die Basis dient als Kopie für den späteren Draw
    
  73.             TBasisLineWR[X] = TFFTDif * ((TCol Shr 16) And 255)
    
  74.             TBasisLineWG[X] = TFFTDif * ((TCol Shr 8) And 255)
    
  75.             TBasisLineWB[X] = TFFTDif * (TCol And 255)
    
  76.             'Das FFT array wird genutzt, um die Werte zu berechnen. Diese Daten werden sich danach ändern. (ErgebnissArray = QuellArray)
    
  77.             TFFTLineWR[X] = TBasisLineWR[X]
    
  78.             TFFTLineWG[X] = TBasisLineWG[X]
    
  79.             TFFTLineWB[X] = TBasisLineWB[X]
    
  80.         Next
    
  81.         'FFT daten berechnen (für jede farbe seperat)
    
  82.         gsl_fft_complex_float_radix2_forward(Cast(gsl_complex_packed_array_float, TFFTLineWR), 1, TFFTW)
    
  83.         gsl_fft_complex_float_radix2_forward(Cast(gsl_complex_packed_array_float, TFFTLineWG), 1, TFFTW)
    
  84.         gsl_fft_complex_float_radix2_forward(Cast(gsl_complex_packed_array_float, TFFTLineWB), 1, TFFTW)
    
  85.         'FFT daten normalisieren (negativ-werte werden positiv)
    
  86.         For X As Uinteger = 0 To TImgW - 1
    
  87.             TFFTLineWR[X] = Abs(TFFTLineWR[X])
    
  88.             TFFTLineWG[X] = Abs(TFFTLineWG[X])
    
  89.             TFFTLineWB[X] = Abs(TFFTLineWB[X])
    
  90.         Next
    
  91.         'FFT daten max ermitteln (für draw nötig. eventuell für spätere berechnung hilfreich)
    
  92.         For X As Uinteger = 0 To TImgW - 1
    
  93.             'einmal für die basis-daten
    
  94.             If TBasisLineWRC < TBasisLineWR[X] Then TBasisLineWRC = TBasisLineWR[X]
    
  95.             If TBasisLineWGC < TBasisLineWG[X] Then TBasisLineWGC = TBasisLineWG[X]
    
  96.             If TBasisLineWBC < TBasisLineWB[X] Then TBasisLineWBC = TBasisLineWB[X]
    
  97.             'und für das fft ergebniss
    
  98.             If TFFTLineWRC < TFFTLineWR[X] Then TFFTLineWRC = TFFTLineWR[X]
    
  99.             If TFFTLineWGC < TFFTLineWG[X] Then TFFTLineWGC = TFFTLineWG[X]
    
  100.             If TFFTLineWBC < TFFTLineWB[X] Then TFFTLineWBC = TFFTLineWB[X]
    
  101.         Next
    
  102.     End If
    
  103.     
    
  104.     Screenlock()
    
  105.     Cls()
    
  106.     Put (0, 0), TImg, Pset
    
  107.     
    
  108.     
    
  109.     
    
  110.     'basis maus x rot
    
  111.     TPosY = TImgH + 32 + 5
    
  112.     TDif8 = 32 / TBasisLineWRC
    
  113.     Line (8, TPosY - 34)-(TImgW + 11, TPosY + 2), &H00550000, B
    
  114.     For X As Uinteger = 0 To TImgW - 1
    
  115.         Line (10 + X, TPosY - (TDif8 * TBasisLineWR[X]))-(10 + X, TPosY), &H00FF0000
    
  116.     Next
    
  117.     'basis maus x grün
    
  118.     TPosY += 40
    
  119.     TDif8 = 32 / TBasisLineWGC
    
  120.     Line (8, TPosY - 34)-(TImgW + 11, TPosY + 2), &H00005500, B
    
  121.     For X As Uinteger = 0 To TImgW - 1
    
  122.         Line (10 + X, TPosY - (TDif8 * TBasisLineWG[X]))-(10 + X, TPosY), &H0000FF00
    
  123.     Next
    
  124.     'basis maus x blau
    
  125.     TPosY += 40
    
  126.     TDif8 = 32 / TBasisLineWBC
    
  127.     Line (8, TPosY - 34)-(TImgW + 11, TPosY + 2), &H00000055, B
    
  128.     For X As Uinteger = 0 To TImgW - 1
    
  129.         Line (10 + X, TPosY - (TDif8 * TBasisLineWB[X]))-(10 + X, TPosY), &H000000FF
    
  130.     Next
    
  131.     
    
  132.     
    
  133.     'fft maus x rot
    
  134.     TPosY += 40
    
  135.     TDif8 = 32 / TFFTLineWRC
    
  136.     Line (8, TPosY - 34)-(TFFTW + 11, TPosY + 2), &H00550000, B
    
  137.     For X As Uinteger = 0 To TFFTW - 1
    
  138.         Line (10 + X, TPosY - (TDif8 * TFFTLineWR[X]))-(10 + X, TPosY), &H00FF0000
    
  139.     Next
    
  140.     'fft maus x grün
    
  141.     TPosY += 40
    
  142.     TDif8 = 32 / TFFTLineWGC
    
  143.     Line (8, TPosY - 34)-(TFFTW + 11, TPosY + 2), &H00005500, B
    
  144.     For X As Uinteger = 0 To TFFTW - 1
    
  145.         Line (10 + X, TPosY - (TDif8 * TFFTLineWG[X]))-(10 + X, TPosY), &H0000FF00
    
  146.     Next
    
  147.     'fft maus x blau
    
  148.     TPosY += 40
    
  149.     TDif8 = 32 / TFFTLineWBC
    
  150.     Line (8, TPosY - 34)-(TFFTW + 11, TPosY + 2), &H00000055, B
    
  151.     For X As Uinteger = 0 To TFFTW - 1
    
  152.         Line (10 + X, TPosY - (TDif8 * TFFTLineWB[X]))-(10 + X, TPosY), &H000000FF
    
  153.     Next
    
  154.     
    
  155.     
    
  156.     
    
  157.     Line (0, TMY)-(TImgW, TMY), &H00FFFFFF
    
  158.     Line (TMX, 0)-(TMX, TImgH), &H00FFFFFF
    
  159.     
    
  160.     Screenunlock()
    
  161.     Sleep 1, 1
    
  162. Loop
    
  163. Screen 0
    
  164. End 0