home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Real-time_206881622007.psc / Curves.frm < prev   
Text File  |  2007-06-02  |  14KB  |  383 lines
  1. VERSION 5.00
  2. Begin VB.Form frmCurves 
  3.    BackColor       =   &H00C0C0C0&
  4.    BorderStyle     =   1  'Fixed Single
  5.    Caption         =   "Real-time Image Curves - tannerhelland@hotmail.com"
  6.    ClientHeight    =   8835
  7.    ClientLeft      =   45
  8.    ClientTop       =   630
  9.    ClientWidth     =   6270
  10.    BeginProperty Font 
  11.       Name            =   "Arial"
  12.       Size            =   8.25
  13.       Charset         =   0
  14.       Weight          =   400
  15.       Underline       =   0   'False
  16.       Italic          =   0   'False
  17.       Strikethrough   =   0   'False
  18.    EndProperty
  19.    LinkTopic       =   "Form1"
  20.    MaxButton       =   0   'False
  21.    MinButton       =   0   'False
  22.    ScaleHeight     =   589
  23.    ScaleMode       =   3  'Pixel
  24.    ScaleWidth      =   418
  25.    StartUpPosition =   2  'CenterScreen
  26.    Begin VB.TextBox txtExplanation 
  27.       Appearance      =   0  'Flat
  28.       Height          =   3855
  29.       Left            =   120
  30.       MultiLine       =   -1  'True
  31.       TabIndex        =   3
  32.       Text            =   "Curves.frx":0000
  33.       Top             =   4800
  34.       Width           =   2055
  35.    End
  36.    Begin VB.PictureBox picMain 
  37.       Appearance      =   0  'Flat
  38.       AutoRedraw      =   -1  'True
  39.       BackColor       =   &H80000005&
  40.       BeginProperty Font 
  41.          Name            =   "MS Sans Serif"
  42.          Size            =   8.25
  43.          Charset         =   0
  44.          Weight          =   400
  45.          Underline       =   0   'False
  46.          Italic          =   0   'False
  47.          Strikethrough   =   0   'False
  48.       EndProperty
  49.       ForeColor       =   &H80000008&
  50.       Height          =   4530
  51.       Left            =   120
  52.       Picture         =   "Curves.frx":0140
  53.       ScaleHeight     =   300
  54.       ScaleMode       =   3  'Pixel
  55.       ScaleWidth      =   400
  56.       TabIndex        =   1
  57.       Top             =   120
  58.       Width           =   6030
  59.    End
  60.    Begin VB.PictureBox picBack 
  61.       Appearance      =   0  'Flat
  62.       AutoRedraw      =   -1  'True
  63.       AutoSize        =   -1  'True
  64.       BackColor       =   &H80000005&
  65.       BeginProperty Font 
  66.          Name            =   "MS Sans Serif"
  67.          Size            =   8.25
  68.          Charset         =   0
  69.          Weight          =   400
  70.          Underline       =   0   'False
  71.          Italic          =   0   'False
  72.          Strikethrough   =   0   'False
  73.       EndProperty
  74.       ForeColor       =   &H80000008&
  75.       Height          =   4530
  76.       Left            =   120
  77.       Picture         =   "Curves.frx":6596
  78.       ScaleHeight     =   300
  79.       ScaleMode       =   3  'Pixel
  80.       ScaleWidth      =   400
  81.       TabIndex        =   2
  82.       Top             =   120
  83.       Visible         =   0   'False
  84.       Width           =   6030
  85.    End
  86.    Begin VB.PictureBox picCurve 
  87.       Appearance      =   0  'Flat
  88.       AutoRedraw      =   -1  'True
  89.       BackColor       =   &H00E0E0E0&
  90.       BeginProperty Font 
  91.          Name            =   "MS Sans Serif"
  92.          Size            =   8.25
  93.          Charset         =   0
  94.          Weight          =   400
  95.          Underline       =   0   'False
  96.          Italic          =   0   'False
  97.          Strikethrough   =   0   'False
  98.       EndProperty
  99.       ForeColor       =   &H80000008&
  100.       Height          =   3855
  101.       Left            =   2280
  102.       ScaleHeight     =   255
  103.       ScaleMode       =   3  'Pixel
  104.       ScaleWidth      =   255
  105.       TabIndex        =   0
  106.       Top             =   4800
  107.       Width           =   3855
  108.    End
  109.    Begin VB.Menu mnuFile 
  110.       Caption         =   "&File"
  111.       Begin VB.Menu mnuOpenImage 
  112.          Caption         =   "&Open image"
  113.       End
  114.    End
  115. End
  116. Attribute VB_Name = "frmCurves"
  117. Attribute VB_GlobalNameSpace = False
  118. Attribute VB_Creatable = False
  119. Attribute VB_PredeclaredId = True
  120. Attribute VB_Exposed = False
  121. 'Image Curves Dialog example ⌐2007 by Tanner 'DemonSpectre' Helland
  122. 'http://www.tannerhelland.com
  123. 'tannerhelland@hotmail.com
  124.  
  125. 'This project is an exact model of how to use a cubic spline to adjust image levels
  126. ' (almost identical to Photoshop's method).  The code is well-commented, but there are
  127. ' some fairly involved math sections.  Don't feel bad if you don't understand all the calculus ;)
  128.  
  129. 'Despite the complexity, however, the main routine is a (fairly simple) complete sub that
  130. ' could be dropped into any VB project after a couple minor adjustments.
  131.  
  132. 'Because a large portion of this project relies on DIB sections, I would recommend
  133. ' that you first read "From PSet to DIB Sections - your comprehensive guide to VB
  134. ' Graphics Programming."  This article can be downloaded from several places, most
  135. ' notably http://www.studentsofgamedesign.com
  136.  
  137. 'For additional cool code and tutorials, check out
  138. ' http://www.studentsofgamedesign.com
  139.  
  140. 'Check out my original video game music at
  141. ' http://www.tannerhelland.com
  142.  
  143. 'Also, I owe GREAT thanks to the original author of the cubic spline routine I've used
  144. ' (Jason Bullen).
  145. ' His original cubic spline code can be downloaded from:
  146. ' http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=11488&lngWId=1
  147. '**************************************************************************************
  148. 'ORIGINAL COMMENTS:
  149. 'Here is an absolute minimum Cubic Spline routine.
  150. 'It's a VB rewrite from a Java applet I found by by Anthony Alto 4/25/99
  151. 'Computes coefficients based on equations mathematically derived from the curve
  152. 'constraints.   i.e. :
  153. '    curves meet at knots (predefined points)  - These must be sorted by X
  154. '    first derivatives must be equal at knots
  155. '    second derivatives must be equal at knots
  156. '**************************************************************************************
  157.  
  158.  
  159.  
  160. Option Explicit
  161.  
  162. 'Modified cubic spline variables:
  163. Private Const maxNPoints As Byte = 32
  164. Dim nPoints As Byte
  165. Private iX() As Single
  166. Private iY() As Single
  167. Private p() As Single
  168. Private u() As Single
  169.  
  170. 'Tanner's new variables:
  171. Dim isMouseDown As Boolean  'Track mouse status between MouseDown and MouseMove events
  172. Dim selPoint As Long        'Currently selected knot in the spline
  173. Private results(-1 To 256) As Integer   'Stores the y-values for each x-value in the final spline
  174. Dim minX As Integer, maxX As Integer    'Used for calculating leading and trailing values
  175. Private Const mouseAccuracy As Byte = 6 'How close to a knot the user must click to select that knot
  176.  
  177.  
  178. 'This routine draws gridlines, knots, and the spline on the picture box
  179. Private Function drawCubicSpline()
  180.     
  181.     'Tanner's inserted code: draw the background grid
  182.     picCurve.Cls
  183.     Dim i As Long
  184.     picCurve.ForeColor = RGB(128, 128, 128)
  185.     For i = 0 To 255 Step 64
  186.         picCurve.Line (i, 0)-(i, 255)
  187.         picCurve.Line (0, i)-(255, i)
  188.     Next i
  189.     'Now draw the knots
  190.     picCurve.ForeColor = RGB(255, 0, 0)
  191.     For i = 1 To nPoints
  192.         'If this is the currently selected knot, fill it in with red
  193.         If i = selPoint Then
  194.             picCurve.FillStyle = 0
  195.             picCurve.FillColor = RGB(255, 0, 0)
  196.         End If
  197.         picCurve.Circle (iX(i), iY(i)), 4, RGB(255, 0, 0)
  198.         If i = selPoint Then
  199.             picCurve.FillStyle = 1
  200.             picCurve.FillColor = RGB(0, 0, 0)
  201.         End If
  202.     Next i
  203.     picCurve.ForeColor = RGB(0, 0, 0)
  204.     'Clear the results array and reset the max/min variables
  205.     For i = -1 To 256
  206.         results(i) = -1
  207.     Next i
  208.     minX = 256
  209.     maxX = -1
  210.     
  211.     'Now run a loop through the knots, calculating spline values as we go
  212.     Call SetPandU
  213.     Dim xPos As Long, yPos As Single
  214.     For i = 1 To nPoints - 1
  215.         For xPos = iX(i) To iX(i + 1)
  216.             yPos = getCurvePoint(i, xPos)
  217.             If xPos < minX Then minX = xPos
  218.             If xPos > maxX Then maxX = xPos
  219.             If yPos > 255 Then yPos = 254       'Force values to be in the 1-254 range (0-255 also
  220.             If yPos < 0 Then yPos = 1           ' works, but is harder to see on the picture box)
  221.             results(xPos) = yPos
  222.         Next xPos
  223.     Next i
  224.     
  225.     'Based on the maximum and minimum, calculate preceding and trailing y-values
  226.     For i = -1 To minX - 1
  227.         results(i) = results(minX)
  228.     Next i
  229.     For i = 256 To maxX + 1 Step -1
  230.         results(i) = results(maxX)
  231.     Next i
  232.     
  233.     'Draw the finished spline
  234.     For i = 0 To 255
  235.         picCurve.Line (i, results(i))-(i - 1, results(i - 1))
  236.     Next i
  237.     picCurve.Refresh
  238.     
  239.     'Last, but certainly not least, draw the curves-adjusted image
  240.     drawCurves picBack, picMain
  241.     
  242. End Function
  243.  
  244. 'Original required spline function:
  245. Private Function getCurvePoint(ByVal i As Long, ByVal v As Single) As Single
  246.     Dim t As Single
  247.     'derived curve equation (which uses p's and u's for coefficients)
  248.     t = (v - iX(i)) / u(i)
  249.     getCurvePoint = t * iY(i + 1) + (1 - t) * iY(i) + u(i) * u(i) * (F(t) * p(i + 1) + F(1 - t) * p(i)) / 6#
  250. End Function
  251.  
  252. 'Original required spline function:
  253. Private Function F(x As Single) As Single
  254.         F = x * x * x - x
  255. End Function
  256.  
  257. 'Original required spline function:
  258. Private Sub SetPandU()
  259.     Dim i As Integer
  260.     Dim d() As Single
  261.     Dim w() As Single
  262.     ReDim d(nPoints) As Single
  263.     ReDim w(nPoints) As Single
  264. 'Routine to compute the parameters of our cubic spline.  Based on equations derived from some basic facts...
  265. 'Each segment must be a cubic polynomial.  Curve segments must have equal first and second derivatives
  266. 'at knots they share.  General algorithm taken from a book which has long since been lost.
  267.  
  268. 'The math that derived this stuff is pretty messy...  expressions are isolated and put into
  269. 'arrays.  we're essentially trying to find the values of the second derivative of each polynomial
  270. 'at each knot within the curve.  That's why theres only N-2 p's (where N is # points).
  271. 'later, we use the p's and u's to calculate curve points...
  272.  
  273.     For i = 2 To nPoints - 1
  274.         d(i) = 2 * (iX(i + 1) - iX(i - 1))
  275.     Next
  276.     For i = 1 To nPoints - 1
  277.         u(i) = iX(i + 1) - iX(i)
  278.     Next
  279.     For i = 2 To nPoints - 1
  280.         w(i) = 6# * ((iY(i + 1) - iY(i)) / u(i) - (iY(i) - iY(i - 1)) / u(i - 1))
  281.     Next
  282.     For i = 2 To nPoints - 2
  283.         w(i + 1) = w(i + 1) - w(i) * u(i) / d(i)
  284.         d(i + 1) = d(i + 1) - u(i) * u(i) / d(i)
  285.     Next
  286.     p(1) = 0#
  287.     For i = nPoints - 1 To 2 Step -1
  288.         p(i) = (w(i) - u(i) * p(i + 1)) / d(i)
  289.     Next
  290.     p(nPoints) = 0#
  291. End Sub
  292.  
  293. '********************FORM LOADING********************
  294. Private Sub Form_Load()
  295.     
  296.     'Set form-wide variables to their default values
  297.     isMouseDown = False
  298.     selPoint = -1
  299.     minX = 256
  300.     maxX = -1
  301.     
  302.     'Create 3 default points in a straight line (a good starting point for working with curves)
  303.     nPoints = 3
  304.     ReDim iX(nPoints) As Single
  305.     ReDim iY(nPoints) As Single
  306.     ReDim p(nPoints) As Single
  307.     ReDim u(nPoints) As Single
  308.     Dim i As Long
  309.     For i = 1 To nPoints
  310.         iX(i) = (i - 1) * (256 / (nPoints - 1))
  311.         iY(i) = 255 - iX(i)
  312.     Next i
  313.     
  314.     'Draw the initial spline
  315.     Me.Show
  316.     drawCubicSpline
  317.     
  318. End Sub
  319.  
  320. '************************************************************
  321.  
  322.  
  323. 'Subroutine for loading new images
  324. Private Sub MnuOpenImage_Click()
  325.     'Common dialog interface
  326.     Dim CC As cCommonDialog
  327.     Set CC = New cCommonDialog
  328.     'String returned from the common dialog wrapper
  329.     Dim sFile As String
  330.     'This string contains the filters for loading different kinds of images.  Using
  331.     'this feature correctly makes our common dialog box a LOT more pleasant to use.
  332.     Dim cdfStr As String
  333.     cdfStr = "All Compatible Graphics|*.bmp;*.jpg;*.jpeg;*.gif;*.wmf;*.emf;*.dib;*.rle|"
  334.     cdfStr = cdfStr & "BMP - Windows Bitmaps only (non-OS2)|*.bmp|DIB - Windows DIBs only (non-OS2)|*.dib|EMF - Enhanced Meta File|*.emf|GIF - Compuserve|*.gif|JPG - JPEG - JFIF Compliant|*.jpg;*.jpeg|RLE - Windows only (non-Compuserve)|*.rle|WMF - Windows Meta File|*.wmf|All files|*.*"
  335.     'If cancel isn't selected, load a picture from the user-specified file
  336.     If CC.VBGetOpenFileName(sFile, , , , , True, cdfStr, 1, , "Open an image", , frmCurves.hWnd, 0) Then
  337.         picBack.Picture = LoadPicture(sFile)
  338.         
  339.         'As requested by Herman CK, warn the user if the image is 3+ megs
  340.         If (picBack.ScaleWidth * picBack.ScaleHeight) > 3000000 Then MsgBox "Warning: this image is big!  This demo was not intended for very large images, and may not perform as expected.", vbCritical + vbOKOnly, "Warning: Large Image"
  341.         
  342.         'This will copy the image, automatically resized, from the background
  343.         'picture box to the foreground one
  344.         Dim fDraw As New FastDrawing
  345.         Dim ImageData() As Byte
  346.         Dim iWidth As Long, iHeight As Long
  347.         iWidth = fDraw.GetImageWidth(frmCurves.picBack)
  348.         iHeight = fDraw.GetImageHeight(frmCurves.picBack)
  349.         fDraw.GetImageData2D frmCurves.picBack, ImageData()
  350.         fDraw.SetImageData2D frmCurves.picMain, iWidth, iHeight, ImageData()
  351.     End If
  352. End Sub
  353.  
  354.  
  355. 'When the user clicks on the picture box, see if they've selected a control point or not
  356. Private Sub picCurve_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
  357.     'No point selected yet
  358.     selPoint = -1
  359.     
  360.     'Search to see if the user has clicked on (or very near) an existing point
  361.     Dim found As Long
  362.     found = checkClick(x, Y)
  363.     
  364.     'If the user has selected an existing point, mark it
  365.     If found > -1 Then
  366.         selPoint = found
  367.     Else
  368.         'No match was found, so create a new point here if:
  369.         '  1) This x-coordinate isn't already occupied
  370.         Dim i As Long
  371.         For i = 1 To nPoints
  372.             'The user has clicked on an already occupied x-coordinate. Our spline formula doesn't
  373.             'allow two knots to have the same x-value, so inssyt65fG)Bift As Integer,f thent, mar
  374. End Funct/ x-vs 
  375.  ar
  376. eds)oSmra, mar
  377. En Cure =OVBGrth * pLarning: thieg t-value, so inssyt65foordisyt65foordisyt65foordisyt65fooScaleHeight)p
  378. Ena > -1 Th eing:t65s
  379.    t equation (ws
  380.  
  381.         Ifed, f , Y)
  382.  Mu(iupiwtfrmCu' eing:t65s
  383.    t eqOon g: Hida