Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I'm trying to plot a 3d revolution plot from a set of 2d points. These data points form a 2d curve, then we rotate that curve around y axis and get a 3d surface. @J. M. has a well explained and very helpful post at here which deals exactly the problem I have. However, I tried to use the method, and get a 3d surface that is very rough and not smooth.

Here is the 2d data points:

points=Uncompress["1:eJx13Hc4lX/4OHAjW7JnhKRCpEIazrESokhCpUhZFR6KhLLik6w0NBSVShItoew9I7KyRcnWkozffY7v9/yuy/11/uJ6Xeec5zzPe9zv+z2kbF1Mj1cy0NG5L6Gjo9vl6O5xHP75//8RdP/zIthqIqQ/+0vkLfBLe+8n2IXeJBGHIt9WjWPnmTQW8VO6RSI2N3DYTGBXdrHfWfU5iURI5U2wswUgJ7HRV+oYvCIRno5F8Suwbz8vrxN8Hjz4Z/MhSezzn59JIra8NP+hir0mp0p1s0geiYjWrvMwwr41nt7/mjr4R/5HVsbYj8UYqbbYFZKIvQ+zPtthp/srzGocXkIiksU7dp7DXm417qP3CjyH0Nb3Xuz6y0kEs8qSs0L4/mU9C2Bjn6oiEZLfv5M9zyN/v1yw5qxqNYlQGLiXvR/7+URyyuG1tSSi0+RrY5Iv8u8lEaw2d+tIxOkpraiNPsj7ZBltr0+ANwfa5n4+t8j9qScR+/K2MYl4I+9K7mu/k9tAIvarV7UMeiGPKhcv4jH4RCJI1eSgA9gN/a1yTeMbSYTaFi39qDPIfY4VntjS0UQiakwvWu05jXxDDOtr/YfNJKKM59jbQI9F7n8Libj/8kbIMnfkcqumSvfNtJIIlvDKq0VuyEXVC3tGZz+TiFKrVOm7rsiFD3nU6Qq1k4i/B/+mm7sgl55d4dcu1kEiHJ+espI9hTylIOl3vmUniTBdbcbz6sQiz7eLRCRc+aUZ5Yy850lCrUgcuJTni2F/J+QrZHcyGVh1k4i2H5NzpQ7IieWlbstLwQ3KxqvK7ZG/Mt3Yo6PQA+VD++eF9uPIB5y2LnvF0ksi7PPiRtrsFik/4E+3nb7EiT1wuuiHyzvwSG41fvWjyD+Eu7LUvP9CIpwEXtowHUZuwd4wdY2hj0S8+ch8pPcQcmOJ+j4lErjuv9jOzIO4/A6d2l3i3U8ijoo1XPhtvkj5BA+0Pd1oij02bdO5zDxwsYIPfCn7kFtmj21dof6NRNDrfjrzwRi5xmRX4DINcEaTd1feYr9mFyhirAVuXafJ/gD7ilNL133wAd8JtznGCHnGRpn+Yc4BEjF6c9P9cQPkp+P7FHILwW8WTIpH6S1Sf8BTPiqWrcAuY/6+7v4f8LDpwIK4HciLyalHQnQGScTY5fK/pmT8fri6/86CNw4urdlDQr7tsWFHdzo4Q4n/+u0ayCcu2o5FFg+RiNy8q0Or1JELUevnMLSfW0P876ghv/Vlg4DeGXD7qwN89SrIL9+/P2e5Y4REDKzVJg0oI6cWvzfg0jma7g1KyCelRHc9UxklEdW2Jn8c1uH2J6eHS6YUnC9mPPqZ3CL1f4xECGtO23GuQZ6ceiE/1Bt8g3Jm66wM8t4TPMv+PADfPn3vi8tKfH2U4jcJPvoo0yFxBfLWgMa1OtbjJMKiL3V/lChys2ssAw1HwLOIs/Eu2D/SGfcPOoE7UcqRyCLtDzi9nJbINX7k9C52gh6iEySiXpOZuXYZ8pM9Ij0NeuCG9akKakuRD+2nPCFwn/dDvdmsuP3dma/N1wA+xB3jvJ4J+fFfb2+5Kv+A8m0f4N88J/5/t2/gNZcNjb5OIx/I+i2dFg5upMD5NHIKedvRFj4usZ8kgtOY77fXBPKOmqjYtxvBH7oZinGOI0/a+CxPXw983KBYb3gU+Zuxy4fVJsDD4GNk+pGPHBsY76f7RSLMd2il7upDPt++gg/KMp1VwT7Go2f3egl4Lv/sLD92/sHvDieywBWcE9TjW5F/1KXUUPC9BhZ6u1rw9fWfUyVGwGf0mPQSm5C7FPwInHL/TSLE1ZcITn5APt9+g3PJua1xrEZutTrl+vpm8EBdrp0qFcgnLg5+Clz3B+IH345wo2LkRe/jpJRdwP1W7Ji5mI+8xL7j90g+OLu2kH7xe+Q566W/jvSDV26y6IvJQj7fP0ySCH2xnV+yXiE3it0UmnIT/FNF7pKgZ8gbr4e2Zb0B1yg/GmL8FPl8//CXRLh/Lk93fYCfX7vYgeO7wH0+8Gx3u4vcy9c2UScZ/Km7cMPkdeTz/Qd43G3D/2RjkLdKMSqumAOXbjh62joKuZjdtlM18VMkQlCiWvJBIPKn1Bd4yYHqA20B+P4v3x3a/AK8baPDuCH2HUuKTzt1gtdQ2nE/5NRWi/cfifi8lUv3rTf25Lr6KDtw13aW/s0eyOf7N/Axsd2KVwj8/A0E1Syug/uX+Z80ckX+PNlmh6XQNPSPJMWRdceR35Wi3GHw3A8bL8fZIg9bw1leHwa+3/PJp9mDyC/5ZbNLVoCHhm1ZIW2BfL7/nCEReld8tThMcf2X0XULcgMfk2dymjFA3tAqsmbUh+JipT6i2FnISnqy/uDm/2WUFukjj6I2W+Aat0Y5vmgi/9LSUtCoNEsi3vkyiazYhuvHnlXasZ7gYxKdU1MqyOf7b/BLeZ6xXMrIL7Q+E9/SBb7riNG1bgXcvqrvyTLxnIP4X8/ZNVwcedAySg0GD7r6WENvOfKlcS3BGy+DN67UEnYRQ16RolGs9gach/ogkFf/snKSW05HJg6nRERwsyOfjx/Aq9svlVezINd3HT93Yju43pVCBnVGXP+jReT5CPCBp/ISlyaXo/hM2xa6KHAeneq90j+Qvy3MEl2fC36tTezal2/IrSaUOpeVgROnJBOEviL/S23+wN8frgjh7EAuLiRTYy5BTyY8f01Yj35C3nVAL6SWDC7Xk2b5qgZ5uh/lBoG79xSxRZQhb057oazgAX5m3Dp6XxHy605GFm8LwJXdqjK3vkbuTo1vwGe5yj4dfIU8hPWTHVsFuEPykZjCl8gP/2YzOtIMbkYZJqcil492NLsoyUAmdl+vN6lLQL4+69v9MEXw6yNpMar3kJdmbLFr1gbPzqPr/O8Wct4bjMYlZ8C9Zw1F70chH6bGV+BTS6PEYv5DzslrTb+qHFyVaY545oP8yH4md/YKcHYpBS5P7E9/UdoV8IupJsu43ZBb3H/hc1KckUzsqEnvd3JArnieT2O1KXitirO9yAHk9tT4DbyFXlom0xz5huO8B5VdwW1//rqauxe5Y2V2nPId8BvUhhj//uVMTNkF4H6cpZxtGshlqB0keDlfNuP5bcjvns0UX94GLt7SnxGzGX++3AbPboElZKLA56NRtBzybmr8CC42FM61byXy8yxb3MOPgf/9FnI1WhD5nXumzlcdwK+a1XF/EsDXd+Jluext8EKGFf6/2ZDHHo9X83gH3uA7k6xLj1wks0+EexR8+acZCb+fYgv9ALV4MZGJiMK1XdxjyEVv6bw/xQV+k+/CXO0Q8s+7r8Z93Q7eSmlHupAbxL58rm0DzulRlafajFz4CaUAgr9Y1+Df/gn5BYHNiiVe4IRg9Va1j8gtKkIqe16BH2K98Ox4IfJP1PiXiVL/zAP8spB7u61ocZwBn35NaamQ66Vb/z3IyEwmIs1VktySkTdyMZhHsoK3Zsnotichv9K7OaJ3M3iSuGmP5W3kOk7Vl96ZgteeCGCziUFuaj5dsToOXJRnF/1rH+S7qfE3eP5/mZ2l5/DvV5OXZrkP/uBOjst27BdH3+k8fwwuTg2kkCtbJRtfGQfXlBJ3tjyKnHOFz1g+CwuZ2Le8mT/tIPIVAnvotiuDs42JzCzdgzyPLN39lwzO70RUmRgiL6fG/+BOw6I8TtuRD93zKPOJAg+QfxBwbCPycIbIUqVicMv46eOXVuLfT02Pgts9jpUylEAuNFeSOtcJPj5Uv/msGHK+6mFD2TnwI9RAFrnd2j2D+9lZyYRNUFPSOy7kWtYiNwKUwA8/XzJ6mRG5NnV8Am5tI7hBYU50oU+NVkdIW4In7emsZf6D/FS2sx/TefAaF5XE+EHkdNchKk8ED/WxYDjVgTzoM7HmbRX4mjFRid465L+sZMgKP8GdA5/uOVGIPJs6/mGD57t1v7BlFvLrvW3n7IXBfayOkmXSkUfsFxd+owb+gDoQQf54cMcHITvw2qJk22O3kHvXURoA8JSLpRGuV5Fb/RR38rwBXhDycX9UCPKMH2nSZangMko/gx75IVejjr/Av0pe/Bp4Cnn5P9EzXv/AvW5ue/zVFnlhuNDVgi3sZELo8pT1a0PkP6FSbtUGr4sR331zJ/JO1RSvdXoUp/6BfEJtYlunCXg/9YOQf4RC++MM+A6jAYaHKsi/c4wub7kCLnmqetBRHvkL6mMBz2J+k/5cGrn8ap6cpR3gJ6OkjzcvQz5+Vkv+EsUdNebKkrGfolYrDjLx46EJj+aMyELfY7OeNVYOnCO00sPgJ3IW402pwSfB11IfFPKV68weHDoDLpVe3RHfjFye2iyC09/pIpOakIsbPXlR7Q+uxpryIKQe+VdHwup6DvjqfRV2TpnIv1G7TXDrwQdslU+R79fPPnGNmZNMfL7+Q3fqJvJ8ztyIms3ge/rf/vkViDyRGjaB893+1UP2xe9/y+ISbQwear9cKMQbuYRq+LD/QfAT1IqE/N2ES17ydfDiJUfVNhxAbksNq8EzVq86ZLwH+cC+vckvOsDVKmTGy7Yiv7ZNq6trFFzdzLzJdBPyFdRh21Jon2ydbnitxO/feEqwXhZ8FbuE/LnlyEdHeSpuG4CnUhsq5FktRzVHT4GH807IrJkRXuht1LQG+P1Vaf+MfyMPXP+wLPUROMusgOSPL8jvi53g5HoLnpHenNPUjvwmdXwOvnrvseFj5cjDDnk0KcyB91rlWoTkIHcPMtp7dSMXmZigXGci8ksa9f+mdMBl704b9t9Bbk6d9gD3dW2tMo1FHvTK6GyOI3iRcET83v+QP5i4ctk7FDzw9a3k317I+aj5AfAmgfpdmjbIsx+Zik9VgndWbOZg2Ye842vfFfE/4CrUjhJ5kxXv87PLlpGJbd2NTkLKyGvdKANIcOV3lVVKcshnlG9rTOwAZ91syxnJh/zLy+YE1r3gl2+fW6e2FHk4NT8B7u3Qu+baD6GFvmRq+9Gy6+CjOrnZIQPIPXo5lu/LAveiBirIj6qz99m2gkf3O3K9KkZukHIYIhBwF/5DEY3vkddLrh0c4uImEyImUTVZCcgZRoTkvXjAc+VHV9HdQx5IzX+AiwcZ+fNeRG6Zy/voy3pwhzFNvq1+yFs1Vb2aNMDfUQM95Nyj0XlbTMEFX0oIeVkit6VU/0Pgk3PDF2IM8fVbxyq9cgPXmGAr+rseOZfZuzfqkeC2M+WaQ+zIydT8C/jWLTc1elnx9RcTLbLR4Btk4vrdsB+IveaSSvFZCUqgjDzYttUjJQ28KtdgaFmXIGp/oXe+WAQu6lct+LAEeclgFZtcLXj0Jq6+m2+Rd09Oae7uAdekDhSQh+pfGkseBbcwtfdXjEQ+Q80Pga9Z+rxQKQi5wWO9pnXLeMiEhGueeOFx5OYOahzeK8AjiR+lrSbI21L5YQQIHuBoe7BZEzknE1NOqiL4l3CRrP0ayD94JfGObQAPog60kNfYFjxUNgZPTibMhwSQZ1HzU+D8jxSXNU0JLHSndLqmMWfwNW+q//s3gJw9xrZP6hx4KXWgiVzIsDMgIhS8mOyYVvoOeSwlPRID/iBmdPfOp8hLiuPH194G/wbF4H0c8uLObEWFRHDbqiVNMeHIWd9QfiB49GUJ2dALyP0nO2aU34GzUwfiyAmPO63l+eBz++NnDh9G7knNv4H7BxtNl5oj3y4vzr7lM7gCpR9RRf7qgNR1+w7wktBQbQVl5Cl1Lhwsf8Hvbn84qcSM3HyQkiADP+yZ/ESPEXlVnOUGpn/g6i5NBpMMyCcPHRDUorgRNRGC3MAinP+BEC+0vzvEO4oa+Bf6Jmr+D9yGWfi/ilTkZ5pZu3U2gfMlTejefIS88ar06j1bwaOoiR7kIXRWuxN2g3sfcB/vOY2clxLV24LvCovb8dAYeaHmMYteB/BNZIePf8jI675YbzF0Aa+nJrKQ99s83i8ZAJ7dU3GPgRP5ODU/Ce63vzxatocP9e9qavusboNbjZY5sjQhv7Jh7dGweHBBaqIO+UY9xq3Rr8E73EhLmO8jr5W9DTcOnHXj1M2Tp5Hzs0tOFFWDd1nu15w9gVz58fLYV3XgltREJfKmm6SmmX7w5M8erXSbkT+n5k/B975WGwtjQ97Ts6/Sjo6PTDDVno8+zIjvT6/4PR5G8DvzH7TQV30O9y0SAH8u58D/pgr5x2r3+3xC4GtYb3EZlyM/3mRzpG8NeOf8g1roOvKz6ooK4Marwjn5LyO/TJ2ABaefiSJW+yJ3fKqULqoJ/jm4pt7XGDkL/zlF9l3g0vMVZaGTCs7l85qDVwjpZs5yI3eefyxkwvzIlvclfTwLXcXzyGo+Z/DJ3qG9UfXIvRoT5sxcwI/NN1QLXU5BN5zvArhs2tURqevI100X7pgLBu8yaN1TG4ScWYosU3oF/Ml8R7LQo+lzBYaugqtlH685aoHcgBJexIIzPvuu5LwT+cs1HO4/EsHfn2zfz8iHvIu/cX9bMvjgfEe90PcRZh7hb8B1jxqvLatAbu2RzL4pC7zg/cCNP6+RnyvPUSzNB1ecD4QWep9+g0p3EeX3eyicowtAvma+WsP9T5MKS7JGLqwSd1i2Adw05U6cmDryzUrickQTuNt8oInGd6mtn/w6wW88caydYEBuKHn8P+de8D+VIhdOdi1b6L+vnlslPgzuOB+oo/hJujmwfRy88dZdlv2GyMMU9EY7J8HbpTqaA+q4UPluzfBRmgIfq6cOdBZ6wibnuiGKWz16/PlNPHJmOsqLH8an5SZx56SQb+rXD+ZiAFdS7txpPbJ0oe/J3HXrCMXPzA8kFzpj7F+6OooHbK5T6mpFLq8gJcPKBh659K/N8a3If/6ouuHKDj59kDoQX+gTxzKVrDnBdxdH8Fb3cS50aWKygJ4bfGyA99ypUOSxikbXLvCCB84nMha6W5ZGMr8AeLOaagH/T46FntoXEWxH8SSftSvFPiBXfpJWUs8Hzj6f6FnoCvmTAX084O7d7PQ/lJFf+KE/vo5y/ae9PrrYDrIv9BjpgLP+XOBR84myhX7RtWr/qqUU/+ZlKHAGuY310Lgb5f4GfBPmvsqEXN+AITOO8nwE5xORC91B2SI5gBU8Ion5dn4m8ktSKXTdS8BTMpu/uUki76Jr4wiheNx8InfR8jl4Ytr/bhXrQl8peJcpj1I/Uu85nFx2AHldtxjd2t/gMvOJblQ+Ha7NpI2Bi8SqetfTIX/Vvom8cpDS/utWSD4sYEHx7bEdFqmU+v90fiJhoWslVnpfbAfXHJJv2CyHvDElK3WiHvy7e2jXvxzmhb5+wDVNpQ58/fxEDOqfT9i+GfgAfulKeEh1NHJa+9jMwWIj6oq8TU0v2TEP/JvcW6NROuRaLTFbtN+Bv52f6FromeWUAAl81lBxO0cMcovPl+TePgf3tTk20uqFXMCbzbUyAdzZ8cL5C6uRb/IyYP9wG1xjfiJxoe98stYh9Ba4zsSja2+nliza/11oJtddG0H+5WlQgtJFcItnf4y2+SJPO37bfdQLvGh+IhbFb2wnBf1dwfl+8QoLMyGnxRcrEzXYZMoYF3pZXqy4kBV4U7vkze5I5Cos2YFtJuAG8xPd6P57FsmkaIPfKlEUTRZFTouvHmxu+1pWzIDKX9FL1q/y4EnmG9b0PUU+EGj8clQWvG5+oQDq33pvTi/hpcSPd01/R2gjp8WvTn6HT0VN0y/0wUp6Dt3f4EcLXazSepG3fWVqFR8Bt5hfiLHQP/sn20e3giukBQfHByKnxe9uNZaiAzuR78pd8e1nDviQn5vUppXIt2Q90cx4SRkfzC9kQe2nm+6I4wNwiXM3HvkXIKeNX9zH7dk2X0PuKRpPPAihjK9uD2zItkVef5HLTNsD3G5+IdBCNzNX8aynjL8OuprkSCxDThu/yZwseX9sei53gfso7zJlMgAXjhDkqY1C/k5n5ZE/euARv5+52oQgp41P97KO7nrGi1x6I4++2GrwY5xv7YLHZhe6q8Vgr4woeCM1fkGe/txpSScz+McMu+KnZshp4/PElFW8vJLIZVe2abcPgx+cX4i20IdM1KeG+sAV1zia+uUgb0vujWSvBmdrtihI34Gclp9Y43dByHcN8t836yOzisFHXLm7zaSR37oSPaFRCN5LjW+Qmx/zOhlLyb/8uXtUKSl4eqHT8jsN21sf7tuDfI9RyMqMAPAN345ljcz+W+hJTlHFHUfBnXV1NwncRk7LX+kyJJh+jECuH6Mt+uEQuJfmDMk7FHnBowaGzxbgY33UhZTo+89LVJpvpuTX7O/9PC+InJa/q/bnONk3PLXQn5cHrffkBz8zv5B0oe//UuL/mhdcqvKT96dE5GknluWXcYNfqypskIpHTstPSgeGXfxqiZzpgUptwhB4tnWL1vPNyE1yVlsrVIHPnKIupF3ow2az+pdKwC9aLE1LqUROy89GiM1J5ZYgz/O0WqGTB851535YZibyT8ylhUQ8uKmppniKNXJa/vnFmo6dyhrIX/x99qXiLHiITpiJ0u/Jha7J6vx5lpL/ZrmRsn5XH3Ja/rxaRV19Lgf5W7Imk7AJuPU121C2u8gHuV+r8cuD79jr0/TKEDltfkD7rtHHLTuR54R8WnVsDbhKv3pury5yw9EjI1dWgrPPL9Re6P6tAzay/5ZB/6KdkZA++2eh0+Y/1h6OfE76iXyIw9de5RP4FcLc52Ef8oba5zo298HHJsRNuYqQ0+Z3JoUncvtTkV8we2VrbAneyJG+rjgGuYb8AabP+uC7efsvOYUip81PVWWQ4znskVdciXdaNcEF8eeMvnKQPnLNru16w5/Bq14cD5rZipw2/8bg+6S4VBw543S58dWb4Pu7xds4uJDb6n5rLTsKvjP7+o01f3+j9vF/5w+DB9OkQ8eQO1829NyxFbx4TfTpiwPIJ4a385HGl5KJs43u23OqkNPmR12yU0uPlSF/tzz2y1wbeIRr87/eIuTqKc0Cc5T5W6H5jQwLfTWHScw7ig+TTvlsxk6b/2Xpuzeigj3J7j1LCsV3rflZvwH7lb9sWp6S4IbLlsxcPoecNr99WzJRxMMb+Uxjl0nhUvBoB878ndjNJUZ6MzI5oX4yDaeVeyGnzc+T++s9pM8iv5TQc0DyEXgm262Us9iLHzs5HjYBv+Hg0Uj4IKetP8js07YtxN75YpvNDRL4bH5oCK8vcrq7gjs3fucgE2+ENW4cx/eHtn6irqnebDP2uF3JZzKawIcelCfsxT6n5Tt6Mhi8dKm4Sq4rctr6j9zkMtM9bsir3Y++Uj0FnvB2vSWbO/LnZYaDw6LgQhcO+jPg30db37Jra8zpKj/8/qIbazXYwQWI0N+9F5DfOy4gZ/OMnUwciU7N97qJnLY+Z2xH8GwbdpvlTWYySeCNepwO6reQexnZnLGJZF+0fvAlFsecoKw/uta9a43QC+S09UsKTU0qPC+RX5NNW+qhAX5FNOeU6yvktxhOb3jXx0YmHtZE2XPh+k1bf3VBZcfo6Qrk7wVmc+/UgjN8nevirkZel/yenu4iuMd3FceOfuS09WO90vlvO4eQL1GaNaU/DD7CfrY2/xfyR+9Cy3bIgWfGD+1MF0DtJ2193OthQ4Pzq5FHPdvDJNrHSibK455o3Sch9/NQueheC77s36olsruQ09b36c7uC1l6GHnvN4d4Dg/wa9reytpeyOmF8zR+ngIXOGsX6+ONnLY+8UwwT0ZzJHIfl5GHlYLgIw2CrHQJyDdp/Q1qnGIhEyaWf7NUU5DT1mfamJ+OYM1GLvjbPSksE3zn8Vcd78uRO57YUJlxEfyyekT7WCdy2vrSsEPc9FzjyAMGDo6xHQYffdqeQ8zg/jM9ia+Psv517Lbcn4DtKD6hrY/ldLY2uoNddYPMdBLFX+r4v0zF/mjPegd5ii8S/+zx0PdKS2MmE0uL7thfPI+ctj54ewYxORCGnJHdQtAkFHzrp++rBXF855R+6me6JbijdsbyQ/nIaeubO+jPH1FtRf7zELNINmV9dDBXskXSLHKu8aLulwzgww9vXGdjxPHx/67fPvClv65iFfIguUs6z5LBs+g39ifrIPfjUPV9cAn8aPcxxr2WyGnrz1vYPmvtc0Fuwd9Tv8YMfHaFyDerIOSzwgk3WDnB3TZt/ESfjpy2vp7HbN+5kffIPfoGRPdOLyETtp9zyvIKkN93Sv51qWvJouOTM6znM/Qegx/ouMm4hxONb2j7B3gicoazBJHbm8aL+YeCNzel0h2VRd5uruSqbwI+HNH9iM8UOW3/w3LtoN+sJ5BLiYa3BDGBT2me0blxFbnZy4KaA9OMMD5zf9Mncgc5bf8Gc9TLhL25yDmvN7V8fwQedTaykfcL8gEPkyL7APDvhzsajBnR+JW2P6V25135AVHkB5YwcEmZgOcm5To/kUPuGsmo1z/LAOXHL5Ip1h05bX9NoqwvedYDufofJyPfafB1QwPrGk8jbzTW0XaZZFh0fC70K0rO/TFl/5EVq71TLnLa/qHXzfSWElXI07OtvbV9wauM77gfb0M+zZQk074HXEpglO8DA8pf0PY/hWzRS26WQh6c0bDn7jQ9jO/MZf6L2o2cdTnH9lWT4FHWdg+l9yKn7e/6w9Elb+6FnF+Pzzj4Mbg9S6LWQCzys9x3OqrcwRsFblmWliCn7U97sN5lruET8jM9lWciTMF7Bpc+rehBbvzlwCCrCP2i+aEzK5/fk52lg+8/Ls77TRE5bf/d1CrzYpFNyF+b1VrTj4L/Cte6unkb8lauVzZWSeCHwt52uJ9FTts/6Pp8OoslEjnH+EsXFyfwR4nKlwvTkKt63eg8ZAae9fjDLY1C5FcOa994u45u0fwdbX9kv+qDtF8DyHdWnq0MnJsjEc4Ng55hXCg/uF3u9urMavCjd8lqplLIafs/r253M2vZitwn5cnB86bgpctqrUmmyEvCtAY31cySiEN2zoNxAchp+1f/ef17syMc+4GWuDsPwRu73yaqXkVOTf8ZgTObnd7b9QJ5WDqvb7Mu5f3/d36VYfvB5wZ/ZkhE1nKdsN1NyGn7d5251BmOtSPXa0p0j60GdzCXEBTtR+7yd2rDGwPwi5yslt1iKD9M25/8qV328LKNyLdcHOsaLJ8mERH+DJ7pu5Hbb9unFHsX3IlNW9DOBjltf7WHS8VQRBDy0tqhtaUT/0jE8qTJD36Pkf83fdCdtQR8VvxBeF4mctr+8F9klx1bW5BnphikmeqBT7RsSTAdQf5m6anIq3lTJMJSy7fsNB/K39P2xz/NuPWGWxg50/0puUN3wHPvRK3jFUP+0uQ4g7EF+CLzB31PhI3Mxv+SCOHO8RdfNZDT9v///U8mLl0Tufev7/uG3oOLrci+R9qJXMgkUKRNG7yw4F6X0RHktPML+h+zvLntgFzqm25GeO4k1I8xic+5Z5BfdbU29o0BzxLP8az2Q047f0Hul5J682Xk6veC7kysApeab8gW+oYu7q8fu/+QiI9lrwj6O8gTkyMZmUvBZ8aj1znGI6edL/HAkVWs6jly1+BzV6aVwC8l2Vxgy0T++M3mA4MffpOIgGeJ7ollyGnnY6hkh4YeqUVutVvlNZsf+PBz6yW/PiGX2xB+fKT5F9TPn0uZi8aQ0873OClxK5N1AvlaYxEDsSpwlYHg6S/Yw6ws7Xqegi8yf+Zu8VJKVBT8r6KtasEyNP9GO79EwC6Z9Sof8k1bpMYnun+SCIYXqiLdwsglVoTcCXAAl1D25mNbh5x2Pstk0m7dKhXk/RaD9x9//0EimszXMhlrIh+TftRcnQ7u6Nr2YoMBctr5MlbM5OTL5sjXKF1O4GUGF8tgat/ngPyWfFP2oYkJEpG0cyok0wk57XyckODIPqPTyKeYquq8jcGPV4S63DmPvJfYKjTKBP612LRKPxQ57Xyf693bymcjkT/bLXd9yXXwK9Q/kJMj5R1WioJzn1ohopaInHZ+UfQhrbuHk5Ar9BWK5beDX5Zk8bv3DHlcsljmfkXwLYJDx2QKkNPOXwptfS+Vjz3F+1CC7yrwi+O9x7YUIt+Z4JbTyAS+yPyzleSIkUfrCIm4UJBn9KkFOe18KbMwXlXNNuQ/IoX4hYPBj+ZkvOTpxPfvt+ngQedhEjHkkD67ehw57XysIykGs8Rv5IEhWn7Xng6RCGmWI7c9ZnD54F3K/mh6kEQUvDQfe8qK5u9p53ud2KUgq8mNPCNfi7jz4TuJCH++PJd3OXKdnEvL1kaAdxdafDKQRE47n4x1ON2rcjVyL3tbFeOt4PzzA4GFHvT06TYPbnDvX/I1xuuRKwkMfShmBbcoX/L8Hnba+W0/M5Qnf23G7zfND1575SuJKA+aamAhI58qWjv1Qxf875v7qnJ4/QPt/DnfKDu+KX3kn/821XTwgYvwl3/O24281MNeRjqwj0TcvE/Ofb0POe38vPKNJ9O6rJD3/4rr0b32hUTEGo2Wmh5GLnaYaOnJ6yURv8c9GX7bI6ed/xc2ZbryuTNyT5bKXTGC4K08+p1Np5Dv1pDdUDzbTSJ6S1rdZb2R084v7GV+9NrWB/nYrpyHJTfAuceCh3f7IQ8Qb730eFsXiai9vb3P/DJy2vmLg5LpVhLhyJ2uvJj+KwyuV1PwrxQ7B7X+dpCIwO8RDt54/cs+K0J1JhJ8kfUx4SK6XD/WtpOIkYsaKx/dQk47f/Jt6phqC/bvwvGZwwzgbQ5zLdy3kd9vCjljy90K/bvblcOSDxapXy0k4lVVi1Ia9miNhG1B98H/9v5r3PUQuWL5C3/9X40komJtfNDm5EXKN7jrWLEy/zN8fdemtrzXBn9nKn1aMgV5XmcTvWJTPYn49n2IOerlIuUP/P6r7TW+r5BfiFZ0aRv4SCIMhD8yZb1G7rez3Vokoxb6lwtu5KTMRcoH+Lki5w3fs/D6p/wTzf6SH6B9+LYrSOs9cpO5SztOKFfC+KW8pv553iL3v5xEGIaHjygWIK874vPR4GQZiYjLLGWoLET+8OSBD4kTRdA+8CnYvy5d5P4UQvvYxXBiuAzX/8GWe5r5+SQiv6q55GQFcv3L6i22e7IhPj0rtF2nepHrz4TxK/PE4zPYtTxzbvQcSScRe77yuyRhn7MnJ2o4pJGIZmmxg/GLfX4SiTg1Jcp3G3vJhU6mHa33SYTODQlmlhrk2rkfi9mvhsH3z1wbkMbvp/ufF1H+sPq1Mvj/A+ndrWo="];

and this is how it looks like

Graphics[Line[points], Frame -> True]

enter image description here

and then I use J. M.'s method(code copied and modified from here) (it will take about 10 seconds to run)

parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
 FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /; 
  MatrixQ[pts, NumericQ]

tvals = parametrizeCurve[points];

m = 3;
knots = Join[ConstantArray[0, m + 1], MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, Length[points]}, {j, Length[points]}];
ctrlpts = LinearSolve[bas, points];

circPoints = {{1, 0}, {1, 1}, {-1, 1}, {-1, 0}, {-1, -1}, {1, -1}, {1,0}};
circKnots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1};
circWts = {1, 1/2, 1/2, 1, 1/2, 1/2, 1};

wgpts = Map[Function[pt, Append[#1 pt, #2]], circPoints] & @@@ ctrlpts;
wgwts = ConstantArray[circWts, Length[ctrlpts]];

and then generate the 3d surface

Graphics3D[{Directive[EdgeForm[]], 
  BSplineSurface[wgpts, SplineClosed -> {False, True}, 
   SplineDegree -> {3, 2}, SplineKnots -> {knots, circKnots}, 
   SplineWeights -> wgwts]}, Boxed -> False]

enter image description here

We can see that the surface is not smooth. It looks like the surface is composed by flat rings. So how can we make the surface smooth?

Edit:

I think this unsmoothness may come from my data rather than the rotation process, so I tried to smooth my data using something like

pointsSmooth=ExponentialMovingAverage[points, 1/20];

then I get the a smoother surface, but ExponentialMovingAverage seems to have removed the end points and there is a hole on the surface, which I don't want.

enter image description here

Also smoothing using a smooth constant like 1/20 largely modified the original data:

Graphics[{Red, Line[ExponentialMovingAverage[points, 1/20]], Blue, 
  Line[points]}, Frame -> True, AspectRatio -> 1]

enter image description here

So is it possible to smooth the data while keep the general shape so that it will give a better smooth surface? Or there are other ways to contract a smooth surface from the data?

share|improve this question
    
Now that you found the source of the lack of smoothness lies in your data, it is not clear what your question is now. –  m_goldberg May 29 at 4:21
    
@m_goldberg Still, my goal is get a smooth surface :) –  xslittlegrass May 29 at 4:37
    
Why is it so important to avoid the small deviation between the actual data and approximate surface? –  Jens May 29 at 16:57
    
@Jens What did you refer to deviation, the roughness (discontinuity in the derivative) at the surface or the change of the curve after ExponentialMovingAverage? 1) If it's the later. I'm trying to make a movie of the wave function evolution by plotting the isosurface, when an atom is experiencing a laser field. since it's a physical simulation, I would like to make it looks good but also keep the data as unmodified as possible. 2) About the roughness, I generate the data and then rendered in povray. This roughness is more visible in the rendered image and is very annoying. –  xslittlegrass May 29 at 17:17

3 Answers 3

up vote 7 down vote accepted

Sounds like what you actually need after your edit is a way to smooth a list of data while keeping the endpoints fixed. Here's a dumb approach that will work with any "symmetrical" smoothing filter, including GaussianFilter, MeanFilter, even MedianFilter. It won't work with ExponentialMovingAverage, though, because that's not symmetrical, although it should if you average the results from ExponentialMovingAverage and Reverse@ExponentialMovingAverage@Reverse.

smooth[list_, filter_] := 
 Take[filter[Join[
    (2 First@list - #) & /@ Reverse@Rest@list, 
    list,
    (2 Last@list - #) & /@ Reverse@Most@list]],
  {Length@list, 2 Length@list - 1}]

All it does is it extends the data in a "flipped" form about both endpoints -- for example, $[1,2,10]$ will become $[\color{grey}{-8,0},1,2,10,\color{grey}{18,19}]$ -- then smooths that, and drops the extra entries.

For example:

smooth[{a, b, c, d, e}, GaussianFilter[#, 1] &] // Simplify
{a, 
 (b BesselI[0, 1/4] + (a + c) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 (c BesselI[0, 1/4] + (b + d) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 (d BesselI[0, 1/4] + (c + e) BesselI[1, 1/4])/(BesselI[0, 1/4] + 2 BesselI[1, 1/4]), 
 e}

:)


Turns out GaussianSmooth smooths across all dimensions of the array by default, so the $x$-coordinate gets averaged with the $y$-coordinate and vice versa. Oops.

{xs, ys} = smooth[#, GaussianFilter[#, 5] &] & /@ Transpose[points];
{fx, fy} = Interpolation /@ {xs, ys};
RevolutionPlot3D[{fx[i], fy[i]}, {i, 1, Length[points]}]

enter image description here

You can set smoothedPoints = Transpose@{xs, ys} if you want to use the whole parametrizeCurve stuff instead.

share|improve this answer
    
I don't know where I messed up but I can't make it work using your method. The smoothed curve seems dramatically changes. Could you give more details and show a plot? –  xslittlegrass May 29 at 19:02
    
@xslittlegrass: Fixed. –  Rahul Narain May 30 at 3:11
    
Still, downsampling the data through a spline fit, as in your answer, is probably a more sensible approach since you don't really need to retain all those hundreds of degrees of freedom. –  Rahul Narain May 30 at 4:13
    
Thanks a lot for your answer! Your method is simpler and works very well. –  xslittlegrass May 30 at 4:39

You have a lot of points, so generating two interpolation functions from them, one for the bottom of the surface and the other for the top, should give a smooth surface of revolution. If the default plot isn't smooth enough, you can always increase PlotPoints.

max = Max[First /@ points];
ii = Position[points, {max, _}][[1, 1]];
btm = Interpolation[points[[;; ii]]];
top = Interpolation[points[[ii ;;]]];
RevolutionPlot3D[{{t, btm[t]}, {t, top[t]}}, {t, 0., max}]

plot

share|improve this answer
    
Thanks, but it doesn't seems to work well even I increased the PlotPoints to 100. Here is the result I get imgur.com/t61hEW8 –  xslittlegrass May 29 at 15:24

The the roughness on the surface is due to the noise in the original data, so that the first derivative is not smooth.

This shows the first derivative of the x and y components using original data, we can see it's very noisy

tvals = parametrizeCurve[points];  
m = 3;
knots = Join[ConstantArray[0, m + 1], 
   MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[
   BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, 
    Length[points]}, {j, Length[points]}];
ctrlpts = LinearSolve[bas, points];  


df1[u_] = 
  Evaluate@D[
    BSplineFunction[ctrlpts, SplineDegree -> 3, SplineKnots -> knots][
     u], u]; 
Plot[{Evaluate[df1[u]], Evaluate[df1[u]][[2]]}, {u, 0, 1}]

enter image description here

We need to remove that noise in order to get a smooth surface. This can be achieved using linear fit. Andy Ross presented very effective a spline model fit at here. I modified his code and create this function to apply to my 2d data.

dataSmoothSplineMethod[ls_?(ArrayQ[#, 1] &), knotNum_Integer] := 
 Module[{SplineModel, lth = Length[ls], knots, data},
  data = Transpose[{Range[1, lth], ls}];
  SplineModel[data_, deg_, knots_] := 
   Block[{basis, allKnots, n, kmin, kmax}, n = Length[knots] + 2;
    kmin = 0;
    kmax = Ceiling[Max[data[[All, 1]]]] + 1;
    basis = 
     Array[\[FormalX]^# &, deg + 1, 0]~Join~
      Table[BSplineBasis[{deg, knots}, i, \[FormalX]], {i, 0, 
        Length[knots] - deg - 2}];
    LinearModelFit[data, basis, \[FormalX]]];
  knots = {1}~Join~Range[2, lth - 1, Round[lth/(knotNum - 2)]]~
    Join~{lth};
  SplineModel[data, 3, knots]
  ]

dataSmoothSplineMethod[ls_?(ArrayQ[#, 2] &), knotNum_Integer] := 
 Module[{SplineModel, lth = Length[ls], lsx, lsy},
  lsx = ls[[All, 1]];
  lsy = ls[[All, 2]];
  {dataSmoothSplineMethod[lsx, knotNum], 
   dataSmoothSplineMethod[lsy, knotNum]}
  ]


f2 = dataSmoothSplineMethod[points, 20];

and here shows the comparison of the smoothed data and original data, we can the changes are almost not visible

Legended[Show[
  ParametricPlot[Through@f2[x], {x, 1, Length[points]}, 
   PlotPoints -> 100, PlotStyle -> Red], 
  Graphics[{Blue, Line[points]}]], 
 Placed[LineLegend[{Red, Blue}, {"spline fit", "original data"}], 
  ImageScaled@{0.5, 0.5}]]

enter image description here

but the first derivative is much more smooth

df2[u_] = {D[f2[[1]][u], u], D[f2[[2]][u], u]};

Plot[Evaluate[df2[u]], {u, 1, Length[points]}]

enter image description here

Using this smoothed data, we can create a much more smooth 3d surface

pointsSmoothed = Table[Through@f2[x], {x, 1, Length[points]}];
parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
 FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /; 
  MatrixQ[pts, NumericQ]
tvals = parametrizeCurve[pointsSmoothed];
m = 3;
knots = Join[ConstantArray[0, m + 1], 
   MovingAverage[ArrayPad[tvals, -1], m], ConstantArray[1, m + 1]];
bas = Table[
   BSplineBasis[{m, knots}, j - 1, tvals[[i]]], {i, 
    Length[pointsSmoothed]}, {j, Length[pointsSmoothed]}];
ctrlpts = LinearSolve[bas, pointsSmoothed];
circpointsSmoothed = {{1, 0}, {1, 1}, {-1, 1}, {-1, 
    0}, {-1, -1}, {1, -1}, {1, 0}};
circKnots = {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1};
circWts = {1, 1/2, 1/2, 1, 1/2, 1/2, 1};
wgpts = Map[Function[pt, Append[#1 pt, #2]], circpointsSmoothed] & @@@
    ctrlpts;
wgwts = ConstantArray[circWts, Length[ctrlpts]];

Graphics3D[{Directive[EdgeForm[]], 
  BSplineSurface[wgpts, SplineClosed -> {False, True}, 
   SplineDegree -> {3, 2}, SplineKnots -> {knots, circKnots}, 
   SplineWeights -> wgwts]}, Boxed -> False]

enter image description here

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.